Restandardised formatting.
This commit is contained in:
parent
93d4bd14a0
commit
b0a49fb71d
29 changed files with 1861 additions and 1604 deletions
169
src/ops/equal.c
169
src/ops/equal.c
|
|
@ -20,9 +20,8 @@
|
|||
* Shallow, and thus cheap, equality: true if these two objects are
|
||||
* the same object, else false.
|
||||
*/
|
||||
bool eq(struct cons_pointer a, struct cons_pointer b)
|
||||
{
|
||||
return ((a.page == b.page) && (a.offset == b.offset));
|
||||
bool eq( struct cons_pointer a, struct cons_pointer b ) {
|
||||
return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -32,10 +31,9 @@ bool eq(struct cons_pointer a, struct cons_pointer b)
|
|||
* @return true if the objects at these two cons pointers have the same tag,
|
||||
* else false.
|
||||
*/
|
||||
bool same_type(struct cons_pointer a, struct cons_pointer b)
|
||||
{
|
||||
struct cons_space_object *cell_a = &pointer2cell(a);
|
||||
struct cons_space_object *cell_b = &pointer2cell(b);
|
||||
bool same_type( struct cons_pointer a, struct cons_pointer b ) {
|
||||
struct cons_space_object *cell_a = &pointer2cell( a );
|
||||
struct cons_space_object *cell_b = &pointer2cell( b );
|
||||
|
||||
return cell_a->tag.value == cell_b->tag.value;
|
||||
}
|
||||
|
|
@ -45,104 +43,95 @@ bool same_type(struct cons_pointer a, struct cons_pointer b)
|
|||
* @param string the string to test
|
||||
* @return true if it's the end of a string.
|
||||
*/
|
||||
bool end_of_string(struct cons_pointer string)
|
||||
{
|
||||
return nilp(string) ||
|
||||
pointer2cell(string).payload.string.character == '\0';
|
||||
bool end_of_string( struct cons_pointer string ) {
|
||||
return nilp( string ) ||
|
||||
pointer2cell( string ).payload.string.character == '\0';
|
||||
}
|
||||
|
||||
/**
|
||||
* Deep, and thus expensive, equality: true if these two objects have
|
||||
* identical structure, else false.
|
||||
*/
|
||||
bool equal(struct cons_pointer a, struct cons_pointer b)
|
||||
{
|
||||
bool result = eq(a, b);
|
||||
bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||
bool result = eq( a, b );
|
||||
|
||||
if (!result && same_type(a, b))
|
||||
{
|
||||
struct cons_space_object *cell_a = &pointer2cell(a);
|
||||
struct cons_space_object *cell_b = &pointer2cell(b);
|
||||
if ( !result && same_type( a, b ) ) {
|
||||
struct cons_space_object *cell_a = &pointer2cell( a );
|
||||
struct cons_space_object *cell_b = &pointer2cell( b );
|
||||
|
||||
switch (cell_a->tag.value)
|
||||
{
|
||||
case CONSTV:
|
||||
case LAMBDATV:
|
||||
case NLAMBDATV:
|
||||
/* TODO: it is not OK to do this on the stack since list-like
|
||||
* structures can be of indefinite extent. It *must* be done by
|
||||
* iteration (and even that is problematic) */
|
||||
result =
|
||||
equal(cell_a->payload.cons.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr,
|
||||
cell_b->payload.cons.cdr);
|
||||
break;
|
||||
case KEYTV:
|
||||
case STRINGTV:
|
||||
case SYMBOLTV:
|
||||
/* slightly complex because a string may or may not have a '\0'
|
||||
* cell at the end, but I'll ignore that for now. I think in
|
||||
* practice only the empty string will.
|
||||
*/
|
||||
/* TODO: it is not OK to do this on the stack since list-like
|
||||
* structures can be of indefinite extent. It *must* be done by
|
||||
* iteration (and even that is problematic) */
|
||||
result =
|
||||
cell_a->payload.string.character ==
|
||||
switch ( cell_a->tag.value ) {
|
||||
case CONSTV:
|
||||
case LAMBDATV:
|
||||
case NLAMBDATV:
|
||||
/* TODO: it is not OK to do this on the stack since list-like
|
||||
* structures can be of indefinite extent. It *must* be done by
|
||||
* iteration (and even that is problematic) */
|
||||
result =
|
||||
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
|
||||
&& equal( cell_a->payload.cons.cdr,
|
||||
cell_b->payload.cons.cdr );
|
||||
break;
|
||||
case KEYTV:
|
||||
case STRINGTV:
|
||||
case SYMBOLTV:
|
||||
/* slightly complex because a string may or may not have a '\0'
|
||||
* cell at the end, but I'll ignore that for now. I think in
|
||||
* practice only the empty string will.
|
||||
*/
|
||||
/* TODO: it is not OK to do this on the stack since list-like
|
||||
* structures can be of indefinite extent. It *must* be done by
|
||||
* iteration (and even that is problematic) */
|
||||
result =
|
||||
cell_a->payload.string.character ==
|
||||
cell_b->payload.string.character &&
|
||||
(equal(cell_a->payload.string.cdr,
|
||||
cell_b->payload.string.cdr) ||
|
||||
(end_of_string(cell_a->payload.string.cdr) && end_of_string(cell_b->payload.string.cdr)));
|
||||
break;
|
||||
case INTEGERTV:
|
||||
result =
|
||||
(cell_a->payload.integer.value ==
|
||||
cell_b->payload.integer.value) &&
|
||||
equal(cell_a->payload.integer.more,
|
||||
cell_b->payload.integer.more);
|
||||
break;
|
||||
case RATIOTV:
|
||||
result = equal_ratio_ratio(a, b);
|
||||
break;
|
||||
case REALTV:
|
||||
{
|
||||
double num_a = to_long_double(a);
|
||||
double num_b = to_long_double(b);
|
||||
double max =
|
||||
fabs(num_a) >
|
||||
fabs(num_b)
|
||||
? fabs(num_a)
|
||||
: fabs(num_b);
|
||||
( equal( cell_a->payload.string.cdr,
|
||||
cell_b->payload.string.cdr ) ||
|
||||
( end_of_string( cell_a->payload.string.cdr )
|
||||
&& end_of_string( cell_b->payload.string.cdr ) ) );
|
||||
break;
|
||||
case INTEGERTV:
|
||||
result =
|
||||
( cell_a->payload.integer.value ==
|
||||
cell_b->payload.integer.value ) &&
|
||||
equal( cell_a->payload.integer.more,
|
||||
cell_b->payload.integer.more );
|
||||
break;
|
||||
case RATIOTV:
|
||||
result = equal_ratio_ratio( a, b );
|
||||
break;
|
||||
case REALTV:
|
||||
{
|
||||
double num_a = to_long_double( a );
|
||||
double num_b = to_long_double( b );
|
||||
double max = fabs( num_a ) > fabs( num_b )
|
||||
? fabs( num_a )
|
||||
: fabs( num_b );
|
||||
|
||||
/*
|
||||
* not more different than one part in a million - close enough
|
||||
*/
|
||||
result = fabs(num_a - num_b) < (max / 1000000.0);
|
||||
/*
|
||||
* not more different than one part in a million - close enough
|
||||
*/
|
||||
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
|
||||
}
|
||||
break;
|
||||
default:
|
||||
result = false;
|
||||
break;
|
||||
}
|
||||
break;
|
||||
default:
|
||||
result = false;
|
||||
break;
|
||||
}
|
||||
}
|
||||
else if (numberp(a) && numberp(b))
|
||||
{
|
||||
if (integerp(a))
|
||||
{
|
||||
result = equal_integer_real(a, b);
|
||||
}
|
||||
else if (integerp(b))
|
||||
{
|
||||
result = equal_integer_real(b, a);
|
||||
} else if ( numberp( a ) && numberp( b ) ) {
|
||||
if ( integerp( a ) ) {
|
||||
result = equal_integer_real( a, b );
|
||||
} else if ( integerp( b ) ) {
|
||||
result = equal_integer_real( b, a );
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* there's only supposed ever to be one T and one NIL cell, so each
|
||||
* should be caught by eq; equality of vector-space objects is a whole
|
||||
* other ball game so we won't deal with it now (and indeed may never).
|
||||
* I'm not certain what equality means for read and write streams, so
|
||||
* I'll ignore them, too, for now.
|
||||
*/
|
||||
* there's only supposed ever to be one T and one NIL cell, so each
|
||||
* should be caught by eq; equality of vector-space objects is a whole
|
||||
* other ball game so we won't deal with it now (and indeed may never).
|
||||
* I'm not certain what equality means for read and write streams, so
|
||||
* I'll ignore them, too, for now.
|
||||
*/
|
||||
|
||||
return result;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -89,16 +89,16 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
|
|||
* of that key from the store; otherwise return NIL.
|
||||
*/
|
||||
struct cons_pointer c_assoc( struct cons_pointer key,
|
||||
struct cons_pointer store ) {
|
||||
struct cons_pointer store ) {
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
debug_print( L"c_assoc; key is `", DEBUG_BIND);
|
||||
debug_print_object( key, DEBUG_BIND);
|
||||
debug_print( L"`\n", DEBUG_BIND);
|
||||
debug_print( L"c_assoc; key is `", DEBUG_BIND );
|
||||
debug_print_object( key, DEBUG_BIND );
|
||||
debug_print( L"`\n", DEBUG_BIND );
|
||||
|
||||
if (consp(store)) {
|
||||
if ( consp( store ) ) {
|
||||
for ( struct cons_pointer next = store;
|
||||
consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
|
||||
consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
|
||||
struct cons_space_object entry =
|
||||
pointer2cell( pointer2cell( next ).payload.cons.car );
|
||||
|
||||
|
|
@ -107,15 +107,17 @@ struct cons_pointer c_assoc( struct cons_pointer key,
|
|||
break;
|
||||
}
|
||||
}
|
||||
} else if (hashmapp( store)) {
|
||||
result = hashmap_get( store, key);
|
||||
} else if ( hashmapp( store ) ) {
|
||||
result = hashmap_get( store, key );
|
||||
} else {
|
||||
result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL);
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_string
|
||||
( L"Store is of unknown type" ), NIL );
|
||||
}
|
||||
|
||||
debug_print( L"c_assoc returning ", DEBUG_BIND);
|
||||
debug_print_object( result, DEBUG_BIND);
|
||||
debug_println( DEBUG_BIND);
|
||||
debug_print( L"c_assoc returning ", DEBUG_BIND );
|
||||
debug_print_object( result, DEBUG_BIND );
|
||||
debug_println( DEBUG_BIND );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
|
@ -125,8 +127,8 @@ struct cons_pointer c_assoc( struct cons_pointer key,
|
|||
* with this key/value pair added to the front.
|
||||
*/
|
||||
struct cons_pointer
|
||||
set( struct cons_pointer key, struct cons_pointer value,
|
||||
struct cons_pointer store ) {
|
||||
set( struct cons_pointer key, struct cons_pointer value,
|
||||
struct cons_pointer store ) {
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
debug_print( L"set: binding `", DEBUG_BIND );
|
||||
|
|
@ -134,18 +136,18 @@ struct cons_pointer
|
|||
debug_print( L"` to `", DEBUG_BIND );
|
||||
debug_print_object( value, DEBUG_BIND );
|
||||
debug_print( L"` in store ", DEBUG_BIND );
|
||||
debug_dump_object( store, DEBUG_BIND);
|
||||
debug_dump_object( store, DEBUG_BIND );
|
||||
debug_println( DEBUG_BIND );
|
||||
|
||||
if (nilp( store) || consp(store)) {
|
||||
if ( nilp( store ) || consp( store ) ) {
|
||||
result = make_cons( make_cons( key, value ), store );
|
||||
} else if (hashmapp( store)) {
|
||||
result = hashmap_put( store, key, value);
|
||||
} else if ( hashmapp( store ) ) {
|
||||
result = hashmap_put( store, key, value );
|
||||
}
|
||||
|
||||
debug_print( L"set returning ", DEBUG_BIND);
|
||||
debug_print_object( result, DEBUG_BIND);
|
||||
debug_println( DEBUG_BIND);
|
||||
debug_print( L"set returning ", DEBUG_BIND );
|
||||
debug_print_object( result, DEBUG_BIND );
|
||||
debug_println( DEBUG_BIND );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
|
@ -195,4 +197,3 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
|
|||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
|
|||
list = c_cdr( list );
|
||||
}
|
||||
|
||||
return c_reverse( result);
|
||||
return c_reverse( result );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -121,19 +121,18 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
|
|||
*
|
||||
* This is experimental. It almost certainly WILL change.
|
||||
*/
|
||||
struct cons_pointer lisp_try(struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env) {
|
||||
struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env);
|
||||
struct cons_pointer lisp_try( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
struct cons_pointer result =
|
||||
c_progn( frame, frame_pointer, frame->arg[0], env );
|
||||
|
||||
if (exceptionp(result))
|
||||
{
|
||||
if ( exceptionp( result ) ) {
|
||||
// TODO: need to put the exception into the environment!
|
||||
result = c_progn(frame, frame_pointer, frame->arg[1],
|
||||
make_cons(
|
||||
make_cons(c_string_to_lisp_keyword(L"*exception*"),
|
||||
result),
|
||||
env));
|
||||
result = c_progn( frame, frame_pointer, frame->arg[1],
|
||||
make_cons( make_cons
|
||||
( c_string_to_lisp_keyword
|
||||
( L"*exception*" ), result ), env ) );
|
||||
}
|
||||
|
||||
return result;
|
||||
|
|
@ -282,8 +281,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
|||
|
||||
result = eval_form( frame, frame_pointer, sexpr, new_env );
|
||||
|
||||
if (exceptionp(result))
|
||||
{
|
||||
if ( exceptionp( result ) ) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
|
@ -306,8 +304,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
|||
* @return the result of evaluating the function with its arguments.
|
||||
*/
|
||||
struct cons_pointer
|
||||
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
debug_print( L"Entering c_apply\n", DEBUG_EVAL );
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
|
|
@ -322,122 +320,124 @@ struct cons_pointer
|
|||
|
||||
switch ( fn_cell.tag.value ) {
|
||||
case EXCEPTIONTV:
|
||||
/* just pass exceptions straight back */
|
||||
result = fn_pointer;
|
||||
break;
|
||||
/* just pass exceptions straight back */
|
||||
result = fn_pointer;
|
||||
break;
|
||||
|
||||
case FUNCTIONTV:
|
||||
{
|
||||
struct cons_pointer exep = NIL;
|
||||
struct cons_pointer next_pointer =
|
||||
make_stack_frame( frame_pointer, args, env );
|
||||
inc_ref( next_pointer );
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
struct stack_frame *next =
|
||||
get_stack_frame( next_pointer );
|
||||
{
|
||||
struct cons_pointer exep = NIL;
|
||||
struct cons_pointer next_pointer =
|
||||
make_stack_frame( frame_pointer, args, env );
|
||||
inc_ref( next_pointer );
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
struct stack_frame *next =
|
||||
get_stack_frame( next_pointer );
|
||||
|
||||
result =
|
||||
( *fn_cell.payload.function.executable ) ( next,
|
||||
next_pointer,
|
||||
env );
|
||||
dec_ref( next_pointer );
|
||||
}
|
||||
}
|
||||
break;
|
||||
|
||||
case KEYTV:
|
||||
result = c_assoc( fn_pointer,
|
||||
eval_form(frame,
|
||||
frame_pointer,
|
||||
c_car( c_cdr( frame->arg[0])),
|
||||
env));
|
||||
break;
|
||||
|
||||
case LAMBDATV:
|
||||
{
|
||||
struct cons_pointer exep = NIL;
|
||||
struct cons_pointer next_pointer =
|
||||
make_stack_frame( frame_pointer, args, env );
|
||||
inc_ref( next_pointer );
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
struct stack_frame *next =
|
||||
get_stack_frame( next_pointer );
|
||||
result =
|
||||
eval_lambda( fn_cell, next, next_pointer, env );
|
||||
if ( !exceptionp( result ) ) {
|
||||
result =
|
||||
( *fn_cell.payload.function.executable ) ( next,
|
||||
next_pointer,
|
||||
env );
|
||||
dec_ref( next_pointer );
|
||||
}
|
||||
}
|
||||
}
|
||||
break;
|
||||
break;
|
||||
|
||||
case KEYTV:
|
||||
result = c_assoc( fn_pointer,
|
||||
eval_form( frame,
|
||||
frame_pointer,
|
||||
c_car( c_cdr( frame->arg[0] ) ),
|
||||
env ) );
|
||||
break;
|
||||
|
||||
case LAMBDATV:
|
||||
{
|
||||
struct cons_pointer exep = NIL;
|
||||
struct cons_pointer next_pointer =
|
||||
make_stack_frame( frame_pointer, args, env );
|
||||
inc_ref( next_pointer );
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
struct stack_frame *next =
|
||||
get_stack_frame( next_pointer );
|
||||
result =
|
||||
eval_lambda( fn_cell, next, next_pointer, env );
|
||||
if ( !exceptionp( result ) ) {
|
||||
dec_ref( next_pointer );
|
||||
}
|
||||
}
|
||||
}
|
||||
break;
|
||||
|
||||
case VECTORPOINTTV:
|
||||
switch ( pointer_to_vso(fn_pointer)->header.tag.value) {
|
||||
case HASHTV:
|
||||
/* \todo: if arg[0] is a CONS, treat it as a path */
|
||||
result = c_assoc( eval_form(frame,
|
||||
frame_pointer,
|
||||
c_car( c_cdr( frame->arg[0])),
|
||||
env),
|
||||
fn_pointer);
|
||||
switch ( pointer_to_vso( fn_pointer )->header.tag.value ) {
|
||||
case HASHTV:
|
||||
/* \todo: if arg[0] is a CONS, treat it as a path */
|
||||
result = c_assoc( eval_form( frame,
|
||||
frame_pointer,
|
||||
c_car( c_cdr
|
||||
( frame->
|
||||
arg[0] ) ),
|
||||
env ), fn_pointer );
|
||||
break;
|
||||
}
|
||||
break;
|
||||
}
|
||||
break;
|
||||
|
||||
case NLAMBDATV:
|
||||
{
|
||||
struct cons_pointer next_pointer =
|
||||
make_special_frame( frame_pointer, args, env );
|
||||
inc_ref( next_pointer );
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
struct stack_frame *next =
|
||||
get_stack_frame( next_pointer );
|
||||
result =
|
||||
eval_lambda( fn_cell, next, next_pointer, env );
|
||||
dec_ref( next_pointer );
|
||||
{
|
||||
struct cons_pointer next_pointer =
|
||||
make_special_frame( frame_pointer, args, env );
|
||||
inc_ref( next_pointer );
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
struct stack_frame *next =
|
||||
get_stack_frame( next_pointer );
|
||||
result =
|
||||
eval_lambda( fn_cell, next, next_pointer, env );
|
||||
dec_ref( next_pointer );
|
||||
}
|
||||
}
|
||||
}
|
||||
break;
|
||||
break;
|
||||
|
||||
case SPECIALTV:
|
||||
{
|
||||
struct cons_pointer next_pointer =
|
||||
make_special_frame( frame_pointer, args, env );
|
||||
inc_ref( next_pointer );
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
result =
|
||||
( *fn_cell.payload.special.
|
||||
executable ) ( get_stack_frame( next_pointer ),
|
||||
next_pointer, env );
|
||||
debug_print( L"Special form returning: ", DEBUG_EVAL );
|
||||
debug_print_object( result, DEBUG_EVAL );
|
||||
debug_println( DEBUG_EVAL );
|
||||
dec_ref( next_pointer );
|
||||
{
|
||||
struct cons_pointer next_pointer =
|
||||
make_special_frame( frame_pointer, args, env );
|
||||
inc_ref( next_pointer );
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
result =
|
||||
( *fn_cell.payload.
|
||||
special.executable ) ( get_stack_frame
|
||||
( next_pointer ),
|
||||
next_pointer, env );
|
||||
debug_print( L"Special form returning: ", DEBUG_EVAL );
|
||||
debug_print_object( result, DEBUG_EVAL );
|
||||
debug_println( DEBUG_EVAL );
|
||||
dec_ref( next_pointer );
|
||||
}
|
||||
}
|
||||
}
|
||||
break;
|
||||
break;
|
||||
|
||||
default:
|
||||
{
|
||||
int bs = sizeof( wchar_t ) * 1024;
|
||||
wchar_t *buffer = malloc( bs );
|
||||
memset( buffer, '\0', bs );
|
||||
swprintf( buffer, bs,
|
||||
L"Unexpected cell with tag %d (%4.4s) in function position",
|
||||
fn_cell.tag.value, &fn_cell.tag.bytes[0] );
|
||||
struct cons_pointer message =
|
||||
c_string_to_lisp_string( buffer );
|
||||
free( buffer );
|
||||
result = throw_exception( message, frame_pointer );
|
||||
}
|
||||
{
|
||||
int bs = sizeof( wchar_t ) * 1024;
|
||||
wchar_t *buffer = malloc( bs );
|
||||
memset( buffer, '\0', bs );
|
||||
swprintf( buffer, bs,
|
||||
L"Unexpected cell with tag %d (%4.4s) in function position",
|
||||
fn_cell.tag.value, &fn_cell.tag.bytes[0] );
|
||||
struct cons_pointer message =
|
||||
c_string_to_lisp_string( buffer );
|
||||
free( buffer );
|
||||
result = throw_exception( message, frame_pointer );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -479,7 +479,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
|
||||
switch ( cell.tag.value ) {
|
||||
case CONSTV:
|
||||
result = c_apply( frame, frame_pointer, env );
|
||||
result = c_apply( frame, frame_pointer, env );
|
||||
break;
|
||||
|
||||
case SYMBOLTV:
|
||||
|
|
@ -781,9 +781,10 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
* @param env my environment (ignored).
|
||||
* @return the length of `any`, if it is a sequence, or zero otherwise.
|
||||
*/
|
||||
struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
return make_integer( c_length( frame->arg[0]), NIL);
|
||||
struct cons_pointer lisp_length( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
return make_integer( c_length( frame->arg[0] ), NIL );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -802,24 +803,24 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
return c_assoc( frame->arg[0], frame->arg[1] );
|
||||
}
|
||||
|
||||
struct cons_pointer c_keys(struct cons_pointer store) {
|
||||
struct cons_pointer result = NIL;
|
||||
struct cons_pointer c_keys( struct cons_pointer store ) {
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
if ( hashmapp( store ) ) {
|
||||
result = hashmap_keys( store );
|
||||
} else if ( consp( store ) ) {
|
||||
for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) {
|
||||
result = make_cons( c_car( c ), result );
|
||||
if ( hashmapp( store ) ) {
|
||||
result = hashmap_keys( store );
|
||||
} else if ( consp( store ) ) {
|
||||
for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) {
|
||||
result = make_cons( c_car( c ), result );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return result;
|
||||
return result;
|
||||
}
|
||||
|
||||
struct cons_pointer lisp_keys( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
return c_keys( frame->arg[0]);
|
||||
return c_keys( frame->arg[0] );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -962,26 +963,26 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame,
|
|||
struct cons_pointer lisp_inspect( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
debug_print( L"Entering lisp_inspect\n", DEBUG_IO );
|
||||
struct cons_pointer result = NIL;
|
||||
struct cons_pointer out_stream = writep( frame->arg[1] )
|
||||
? frame->arg[1]
|
||||
: get_default_stream( false, env );
|
||||
URL_FILE *output;
|
||||
debug_print( L"Entering lisp_inspect\n", DEBUG_IO );
|
||||
struct cons_pointer result = NIL;
|
||||
struct cons_pointer out_stream = writep( frame->arg[1] )
|
||||
? frame->arg[1]
|
||||
: get_default_stream( false, env );
|
||||
URL_FILE *output;
|
||||
|
||||
if ( writep( out_stream ) ) {
|
||||
debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO );
|
||||
debug_dump_object( out_stream, DEBUG_IO );
|
||||
output = pointer2cell( out_stream ).payload.stream.stream;
|
||||
} else {
|
||||
output = file_to_url_file( stderr );
|
||||
}
|
||||
if ( writep( out_stream ) ) {
|
||||
debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO );
|
||||
debug_dump_object( out_stream, DEBUG_IO );
|
||||
output = pointer2cell( out_stream ).payload.stream.stream;
|
||||
} else {
|
||||
output = file_to_url_file( stderr );
|
||||
}
|
||||
|
||||
dump_object( output, frame->arg[0] );
|
||||
dump_object( output, frame->arg[0] );
|
||||
|
||||
debug_print( L"Leaving lisp_inspect", DEBUG_IO );
|
||||
debug_print( L"Leaving lisp_inspect", DEBUG_IO );
|
||||
|
||||
return result;
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -1064,7 +1065,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
result = eval_form( frame, frame_pointer, c_car( expressions ), env );
|
||||
dec_ref( r );
|
||||
|
||||
expressions = exceptionp(result) ? NIL : c_cdr( expressions );
|
||||
expressions = exceptionp( result ) ? NIL : c_cdr( expressions );
|
||||
}
|
||||
|
||||
return result;
|
||||
|
|
@ -1332,7 +1333,7 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
|
|||
case SPECIALTV:
|
||||
result = c_assoc( source_key, cell.payload.special.meta );
|
||||
break;
|
||||
case LAMBDATV:
|
||||
case LAMBDATV:
|
||||
result = make_cons( c_string_to_lisp_symbol( L"lambda" ),
|
||||
make_cons( cell.payload.lambda.args,
|
||||
cell.payload.lambda.body ) );
|
||||
|
|
|
|||
|
|
@ -127,8 +127,8 @@ struct cons_pointer lisp_cdr( struct stack_frame *frame,
|
|||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
struct cons_pointer lisp_inspect( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
struct cons_pointer lisp_eq( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue