From bcb227a5f99b172b48e629dd88941f5eebdcf21b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Feb 2026 18:09:48 +0000 Subject: [PATCH] Still not working, but I have increasing confidence I'm on the right track. --- src/arith/peano.c | 58 +++++++++++++++++++----------------- src/arith/ratio.c | 21 +++++++------ src/init.c | 5 +++- src/io/io.c | 4 +-- src/io/read.c | 20 ++++++------- src/memory/consspaceobject.c | 8 ++--- src/memory/dump.c | 8 ++--- src/memory/stack.c | 4 +++ src/ops/intern.c | 33 ++++++++++---------- src/ops/lispops.c | 57 ++++++++++++++++------------------- 10 files changed, 110 insertions(+), 108 deletions(-) diff --git a/src/arith/peano.c b/src/arith/peano.c index 3e85412..9a1b478 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -296,10 +296,11 @@ struct cons_pointer add_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"+"), - c_string_to_lisp_string - ( L"Cannot add: not a number" ), - frame_pointer ); + result = + throw_exception( c_string_to_lisp_symbol( L"+" ), + c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); break; } break; @@ -320,10 +321,11 @@ struct cons_pointer add_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"+"), - c_string_to_lisp_string - ( L"Cannot add: not a number" ), - frame_pointer ); + result = + throw_exception( c_string_to_lisp_symbol( L"+" ), + c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); break; } break; @@ -334,8 +336,8 @@ struct cons_pointer add_2( struct stack_frame *frame, break; default: result = exceptionp( arg2 ) ? arg2 : - throw_exception( c_string_to_lisp_symbol( L"+"), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_symbol( L"+" ), + c_string_to_lisp_string ( L"Cannot add: not a number" ), frame_pointer ); } @@ -431,8 +433,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = - throw_exception( c_string_to_lisp_symbol( L"*"), - make_cons + throw_exception( c_string_to_lisp_symbol( L"*" ), + make_cons ( c_string_to_lisp_string ( L"Cannot multiply: argument 2 is not a number: " ), c_type( arg2 ) ), @@ -458,8 +460,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = - throw_exception( c_string_to_lisp_symbol( L"*"), - make_cons + throw_exception( c_string_to_lisp_symbol( L"*" ), + make_cons ( c_string_to_lisp_string ( L"Cannot multiply: argument 2 is not a number" ), c_type( arg2 ) ), @@ -472,8 +474,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"*"), - make_cons( c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_symbol( L"*" ), + make_cons( c_string_to_lisp_string ( L"Cannot multiply: argument 1 is not a number" ), c_type( arg1 ) ), frame_pointer ); @@ -626,8 +628,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"-"), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_symbol( L"-" ), + c_string_to_lisp_string ( L"Cannot subtract: not a number" ), frame_pointer ); break; @@ -657,8 +659,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"-"), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_symbol( L"-" ), + c_string_to_lisp_string ( L"Cannot subtract: not a number" ), frame_pointer ); break; @@ -669,8 +671,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame, make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"-"), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_symbol( L"-" ), + c_string_to_lisp_string ( L"Cannot subtract: not a number" ), frame_pointer ); break; @@ -741,8 +743,8 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"/"), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_symbol( L"/" ), + c_string_to_lisp_string ( L"Cannot divide: not a number" ), frame_pointer ); break; @@ -772,8 +774,8 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"/"), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_symbol( L"/" ), + c_string_to_lisp_string ( L"Cannot divide: not a number" ), frame_pointer ); break; @@ -785,8 +787,8 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"/"), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_symbol( L"/" ), + c_string_to_lisp_string ( L"Cannot divide: not a number" ), frame_pointer ); break; diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 011ef43..82f9138 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -114,9 +114,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, cell1->payload.ratio.divisor ) ); r = make_ratio( dividend, divisor, true ); } else { - r = throw_exception( c_string_to_lisp_symbol( L"+"), - make_cons( - c_string_to_lisp_string + r = throw_exception( c_string_to_lisp_symbol( L"+" ), + make_cons( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to add_ratio_ratio" ), make_cons( arg1, make_cons( arg2, NIL ) ) ), @@ -156,8 +155,8 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, dec_ref( ratio ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"+"), - make_cons( c_string_to_lisp_string + throw_exception( c_string_to_lisp_symbol( L"+" ), + make_cons( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to add_integer_ratio" ), make_cons( intarg, make_cons( ratarg, @@ -237,8 +236,8 @@ struct cons_pointer multiply_ratio_ratio( struct release_integer( divisor ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"*"), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_symbol( L"*" ), + c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), NIL ); } @@ -273,8 +272,8 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, release_integer( one ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"*"), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_symbol( L"*" ), + c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), NIL ); } @@ -342,8 +341,8 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, } } else { result = - throw_exception( c_string_to_lisp_symbol( L"make_ratio"), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_symbol( L"make_ratio" ), + c_string_to_lisp_string ( L"Dividend and divisor of a ratio must be integers" ), NIL ); } diff --git a/src/init.c b/src/init.c index 8c8da7c..04eeeed 100644 --- a/src/init.c +++ b/src/init.c @@ -293,6 +293,8 @@ int main( int argc, char *argv[] ) { */ bind_symbol_value( privileged_symbol_nil, NIL, true ); bind_value( L"t", TRUE, true ); + bind_symbol_value( privileged_keyword_location, TRUE, true ); + bind_symbol_value( privileged_keyword_payload, TRUE, true ); /* * standard input, output, error and sink streams @@ -413,7 +415,8 @@ int main( int argc, char *argv[] ) { bind_function( L"keys", L"`(keys store)`: Return a list of all keys in this `store`.", &lisp_keys ); - bind_function( L"list", L"`(list args...): Return a list of these `args`.", + bind_function( L"list", + L"`(list args...)`: Return a list of these `args`.", &lisp_list ); bind_function( L"mapcar", L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.", diff --git a/src/io/io.c b/src/io/io.c index 51a05cc..cf0894f 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -508,8 +508,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload.stream. - stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload. + stream.stream ), NIL ); } return result; diff --git a/src/io/read.c b/src/io/read.c index 5ffb143..fee80b3 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -167,8 +167,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, if ( url_feof( input ) ) { result = - throw_exception( c_string_to_lisp_symbol( L"read"), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_symbol( L"read" ), + c_string_to_lisp_string ( L"End of file while reading" ), frame_pointer ); } else { switch ( c ) { @@ -178,8 +178,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, /* skip all characters from semi-colon to the end of the line */ break; case EOF: - result = throw_exception( c_string_to_lisp_symbol( L"read"), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_symbol( L"read" ), + c_string_to_lisp_string ( L"End of input while reading" ), frame_pointer ); break; @@ -268,8 +268,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, result = read_symbol_or_key( input, SYMBOLTV, c ); } else { result = - throw_exception(c_string_to_lisp_symbol( L"read"), - make_cons( c_string_to_lisp_string + throw_exception( c_string_to_lisp_symbol( L"read" ), + make_cons( c_string_to_lisp_string ( L"Unrecognised start of input character" ), make_string( c, NIL ) ), frame_pointer ); @@ -316,8 +316,8 @@ struct cons_pointer read_number( struct stack_frame *frame, switch ( c ) { case LPERIOD: if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_symbol( L"read"), - c_string_to_lisp_string + return throw_exception( c_string_to_lisp_symbol( L"read" ), + c_string_to_lisp_string ( L"Malformed number: too many periods" ), frame_pointer ); } else { @@ -328,8 +328,8 @@ struct cons_pointer read_number( struct stack_frame *frame, break; case LSLASH: if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_symbol( L"read"), - c_string_to_lisp_string + return throw_exception( c_string_to_lisp_symbol( L"read" ), + c_string_to_lisp_string ( L"Malformed number: dividend of rational must be integer" ), frame_pointer ); } else { diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index c461f10..2848b83 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -39,8 +39,6 @@ struct cons_pointer privileged_keyword_location = NIL; */ struct cons_pointer privileged_keyword_payload = NIL; - - /** * True if the value of the tag on the cell at this `pointer` is this `value`, * or, if the tag of the cell is `VECP`, if the value of the tag of the @@ -49,11 +47,11 @@ struct cons_pointer privileged_keyword_payload = NIL; bool check_tag( struct cons_pointer pointer, uint32_t value ) { bool result = false; - struct cons_space_object cell = pointer2cell( pointer ); - result = cell.tag.value == value; + struct cons_space_object *cell = &pointer2cell( pointer ); + result = cell->tag.value == value; if ( result == false ) { - if ( cell.tag.value == VECTORPOINTTV ) { + if ( cell->tag.value == VECTORPOINTTV ) { struct vector_space_object *vec = pointer_to_vso( pointer ); if ( vec != NULL ) { diff --git a/src/memory/dump.c b/src/memory/dump.c index b065661..3a83866 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -114,10 +114,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) { case RATIOTV: url_fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload. - integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload. - integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ). + payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ). + payload.integer.value, cell.count ); break; case READTV: url_fputws( L"\t\tInput stream; metadata: ", output ); diff --git a/src/memory/stack.c b/src/memory/stack.c index b6833c9..7f5d581 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -161,6 +161,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, env ); frame->more = more; inc_ref( more ); + + for ( ; !nilp( args ); args = c_cdr( args ) ) { + frame->args++; + } } } debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); diff --git a/src/ops/intern.c b/src/ops/intern.c index 2764bae..ee15485 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -311,17 +311,17 @@ struct cons_pointer interned( struct cons_pointer key, map->payload.hashmap.buckets[bucket_no] ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"interned?"), - make_cons - ( c_string_to_lisp_string - ( L"Unexpected store type: " ), - c_type( store ) ), NIL ); + throw_exception( c_string_to_lisp_symbol + ( L"interned?" ), + make_cons( c_string_to_lisp_string + ( L"Unexpected store type: " ), + c_type( store ) ), NIL ); } break; default: result = - throw_exception( c_string_to_lisp_symbol( L"interned?"), - make_cons + throw_exception( c_string_to_lisp_symbol( L"interned?" ), + make_cons ( c_string_to_lisp_string ( L"Unexpected store type: " ), c_type( store ) ), NIL ); @@ -329,8 +329,8 @@ struct cons_pointer interned( struct cons_pointer key, } } else { result = - throw_exception( c_string_to_lisp_symbol( L"interned?"), - make_cons + throw_exception( c_string_to_lisp_symbol( L"interned?" ), + make_cons ( c_string_to_lisp_string ( L"Unexpected key type: " ), c_type( key ) ), NIL ); @@ -392,11 +392,12 @@ struct cons_pointer c_assoc( struct cons_pointer key, result = hashmap_get( entry_ptr, key ); break; default: - throw_exception( c_string_to_lisp_symbol( L"assoc"), - c_append - ( c_string_to_lisp_string - ( L"Store entry is of unknown type: " ), - c_type( entry_ptr ) ), NIL ); + throw_exception( c_string_to_lisp_symbol + ( L"assoc" ), + c_append( c_string_to_lisp_string + ( L"Store entry is of unknown type: " ), + c_type( entry_ptr ) ), + NIL ); } // #ifdef DEBUG @@ -417,8 +418,8 @@ struct cons_pointer c_assoc( struct cons_pointer key, // debug_print( L"`\n", DEBUG_BIND ); // #endif result = - throw_exception( c_string_to_lisp_symbol(L"assoc"), - c_append + throw_exception( c_string_to_lisp_symbol( L"assoc" ), + c_append ( c_string_to_lisp_string ( L"Store is of unknown type: " ), c_type( store ) ), NIL ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 3cb0287..98497f6 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -336,44 +336,43 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r, struct cons_pointer fn_pointer ) { struct cons_pointer result = r; - - if ( exceptionp( result ) && (functionp( fn_pointer) || specialp(fn_pointer))) { + + if ( exceptionp( result ) + && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); struct cons_pointer payload = pointer2cell( result ).payload.exception.payload; /* TODO: should name_key also be a privileged keyword? */ - struct cons_pointer name_key = - c_string_to_lisp_keyword( L"name" ); + struct cons_pointer name_key = c_string_to_lisp_keyword( L"name" ); switch ( get_tag_value( payload ) ) { case NILTV: case CONSTV: case HASHTV: { - if ( nilp( c_assoc( privileged_keyword_location , - payload ) )) { + if ( nilp( c_assoc( privileged_keyword_location, + payload ) ) ) { pointer2cell( result ).payload.exception.payload = set( privileged_keyword_location, - c_assoc( name_key, - fn_cell->payload.function.meta ), - payload ); + c_assoc( name_key, + fn_cell->payload.function.meta ), + payload ); } } break; default: pointer2cell( result ).payload.exception.payload = - make_cons( - make_cons( privileged_keyword_location, - c_assoc( name_key, - fn_cell->payload.function.meta ) ), - make_cons( - make_cons( privileged_keyword_payload, - payload ) , - NIL )); + make_cons( make_cons( privileged_keyword_location, + c_assoc( name_key, + fn_cell->payload.function. + meta ) ), + make_cons( make_cons + ( privileged_keyword_payload, + payload ), NIL ) ); } - dec_ref( name_key); + dec_ref( name_key ); } return result; @@ -421,10 +420,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, get_stack_frame( next_pointer ); result = maybe_fixup_exception_location( ( * - ( fn_cell-> - payload. - function. - executable ) ) + ( fn_cell->payload.function.executable ) ) ( next, next_pointer, env ), @@ -498,10 +494,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = maybe_fixup_exception_location( ( * - ( fn_cell-> - payload. - special. - executable ) ) + ( fn_cell->payload.special.executable ) ) ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); @@ -1385,7 +1378,8 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, return exceptionp( message ) ? message : throw_exception( message, frame->arg[1], - frame->previous ); + frame-> + previous ); } /** @@ -1569,13 +1563,14 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { if ( nilp( c_cdr( l1 ) ) ) { return - make_string_like_thing( ( pointer2cell( l1 ).payload. - string.character ), l2, + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), + l2, pointer2cell( l1 ).tag.value ); } else { return - make_string_like_thing( ( pointer2cell( l1 ).payload. - string.character ), + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), c_append( c_cdr( l1 ), l2 ), pointer2cell( l1 ).tag.value ); }