From 2536e76617f98f0452f013f1680975eec538e978 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 2 Mar 2026 11:10:29 +0000 Subject: [PATCH] Added 'depth' counter to stack frames. The idea is two-fold: 1. You can limit runaway recursion by binding a symbol *max_stack_depth* in the environment 2. You can limit the number of backtrace frames printed. However, neither of these have been implemented yet. --- src/init.c | 3 + src/memory/consspaceobject.c | 6 ++ src/memory/consspaceobject.h | 8 ++ src/memory/stack.c | 5 +- src/ops/intern.c | 151 +++++++++++++++++++---------------- src/ops/lispops.c | 42 ++++++++-- src/ops/lispops.h | 4 + 7 files changed, 140 insertions(+), 79 deletions(-) diff --git a/src/init.c b/src/init.c index 565065f..a2da5e9 100644 --- a/src/init.c +++ b/src/init.c @@ -96,6 +96,9 @@ void maybe_bind_init_symbols( ) { if ( nilp( privileged_keyword_payload ) ) { privileged_keyword_payload = c_string_to_lisp_keyword( L"payload" ); } + if ( nilp( privileged_keyword_cause)) { + privileged_keyword_cause = c_string_to_lisp_keyword(L"cause"); + } } void free_init_symbols( ) { diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 3d8fe78..ffff610 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -39,6 +39,12 @@ struct cons_pointer privileged_keyword_location = NIL; */ struct cons_pointer privileged_keyword_payload = NIL; +/** + * Keywords used when constructing exceptions: `:payload`. Instantiated in + * `init.c`, q.v. + */ +struct cons_pointer privileged_keyword_cause = 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 diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 1357f34..b456097 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -68,6 +68,12 @@ extern struct cons_pointer privileged_keyword_location; */ extern struct cons_pointer privileged_keyword_payload; +/** + * Keywords used when constructing exceptions: `:cause`. Instantiated in + * `init.c`. + */ +extern struct cons_pointer privileged_keyword_cause; + /** * An unallocated cell on the free list - should never be encountered by a Lisp * function. @@ -456,6 +462,8 @@ struct stack_frame { struct cons_pointer function; /** the number of arguments provided. */ int args; + /** the depth of the stack below this frame */ + int depth; }; /** diff --git a/src/memory/stack.c b/src/memory/stack.c index 7f5d581..7a85f3d 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -98,6 +98,8 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { for ( int i = 0; i < args_in_frame; i++ ) { frame->arg[i] = NIL; } + + frame->depth = (nilp(previous)) ? 0 : (get_stack_frame(previous))->depth + 1; } debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); debug_dump_object( result, DEBUG_ALLOC ); @@ -285,7 +287,8 @@ void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) { struct stack_frame *frame = get_stack_frame( frame_pointer ); if ( frame != NULL ) { - url_fwprintf( output, L"Stack frame with %d arguments:\n", + url_fwprintf( output, L"Stack frame %d with %d arguments:\n", + frame->depth; frame->args ); dump_frame_context( output, frame_pointer, 4 ); diff --git a/src/ops/intern.c b/src/ops/intern.c index ae9800a..f5f1e63 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -316,81 +316,92 @@ struct cons_pointer search_store( struct cons_pointer key, return_key ? "key" : "value" ); #endif - if ( symbolp( key ) || keywordp( key ) ) { - struct cons_space_object *store_cell = &pointer2cell( store ); + switch ( get_tag_value( key) ) { + case SYMBOLTV: + case KEYTV: + struct cons_space_object *store_cell = &pointer2cell( store ); - switch ( get_tag_value( store ) ) { - case CONSTV: - for ( struct cons_pointer cursor = store; - nilp( result ) && ( consp( cursor ) - || hashmapp( cursor ) ); - cursor = pointer2cell( cursor ).payload.cons.cdr ) { - switch ( get_tag_value( cursor ) ) { - case CONSTV: - struct cons_pointer entry_ptr = c_car( cursor ); + switch ( get_tag_value( store ) ) { + case CONSTV: + for ( struct cons_pointer cursor = store; + nilp( result ) && ( consp( cursor ) + || hashmapp( cursor ) ); + cursor = pointer2cell( cursor ).payload.cons.cdr ) { + switch ( get_tag_value( cursor ) ) { + case CONSTV: + struct cons_pointer entry_ptr = c_car( cursor ); - switch ( get_tag_value( entry_ptr ) ) { - case CONSTV: - if ( equal( key, c_car( entry_ptr ) ) ) { + switch ( get_tag_value( entry_ptr ) ) { + case CONSTV: + if ( equal( key, c_car( entry_ptr ) ) ) { + result = + return_key ? c_car( entry_ptr ) : + c_cdr( entry_ptr ); + } + break; + case HASHTV: + case NAMESPACETV: + // TODO: I think this should be impossible, and we should maybe + // throw an exception. result = - return_key ? c_car( entry_ptr ) : - c_cdr( entry_ptr ); - } - break; - case HASHTV: - case NAMESPACETV: - // TODO: I think this should be impossible, and we should maybe - // throw an exception. - result = - hashmap_get( entry_ptr, key, - return_key ); - break; - default: - result = - throw_exception - ( c_string_to_lisp_symbol - ( L"search-store (entry)" ), - make_cons( c_string_to_lisp_string - ( L"Unexpected store type: " ), - c_type( c_car - ( entry_ptr ) ) ), - NIL ); + hashmap_get( entry_ptr, key, + return_key ); + break; + default: + result = + throw_exception + ( c_string_to_lisp_symbol + ( L"search-store (entry)" ), + make_cons( c_string_to_lisp_string + ( L"Unexpected store type: " ), + c_type( c_car + ( entry_ptr ) ) ), + NIL ); - } - break; - case HASHTV: - case NAMESPACETV: - debug_print - ( L"\n\tHashmap as top-level value in list", - DEBUG_BIND ); - result = hashmap_get( cursor, key, return_key ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol - ( L"search-store (cursor)" ), - make_cons - ( c_string_to_lisp_string - ( L"Unexpected store type: " ), - c_type( cursor ) ), NIL ); + } + break; + case HASHTV: + case NAMESPACETV: + debug_print + ( L"\n\tHashmap as top-level value in list", + DEBUG_BIND ); + result = hashmap_get( cursor, key, return_key ); + break; + default: + result = + throw_exception( c_string_to_lisp_symbol + ( L"search-store (cursor)" ), + make_cons + ( c_string_to_lisp_string + ( L"Unexpected store type: " ), + c_type( cursor ) ), NIL ); + } } - } - break; - case HASHTV: - case NAMESPACETV: - result = hashmap_get( store, key, return_key ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol - ( L"search-store (store)" ), - make_cons( c_string_to_lisp_string - ( L"Unexpected store type: " ), - c_type( store ) ), NIL ); - break; - } - } else { - // failing with key type NIL here (?). Probably worth dumping the stack? + break; + case HASHTV: + case NAMESPACETV: + result = hashmap_get( store, key, return_key ); + break; + default: + result = + throw_exception( c_string_to_lisp_symbol + ( L"search-store (store)" ), + make_cons( c_string_to_lisp_string + ( L"Unexpected store type: " ), + c_type( store ) ), NIL ); + break; + } + break; + case EXCEPTIONTV: + result = + throw_exception( c_string_to_lisp_symbol( L"search-store (exception)" ), + make_cons + ( c_string_to_lisp_string + ( L"Unexpected key type: " ), c_type( key ) ), + NIL ); + + break; + default: result = throw_exception( c_string_to_lisp_symbol( L"search-store (key)" ), make_cons diff --git a/src/ops/lispops.c b/src/ops/lispops.c index c2b0e70..fe264e8 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1329,18 +1329,18 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * Throw an exception. + * Throw an exception with a cause. * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a * lisp function; but it is nevertheless to be preferred to make_exception. A * real `throw_exception`, which does, will be needed. * object pointing to it. Then this should become a normal lisp function * which expects a normally bound frame and environment, such that - * frame->arg[0] is the message, and frame->arg[1] is the cons-space + * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space * pointer to the frame in which the exception occurred. */ -struct cons_pointer -throw_exception( struct cons_pointer location, +struct cons_pointer throw_exception_with_cause( struct cons_pointer location, struct cons_pointer message, + struct cons_pointer cause, struct cons_pointer frame_pointer ) { struct cons_pointer result = NIL; @@ -1350,9 +1350,13 @@ throw_exception( struct cons_pointer location, debug_print( L"` at `", 511 ); debug_print_object( location, 511 ); debug_print( L"`\n", 511 ); - debug_print_object( location, 511 ); + if (!nilp( cause)) { + debug_print( L"\tCaused by: ", 511) + ; + debug_print_object( cause, 511); + debug_print( L"`\n", 511 ); + } #endif - struct cons_space_object *cell = &pointer2cell( message ); if ( cell->tag.value == EXCEPTIONTV ) { @@ -1364,10 +1368,31 @@ throw_exception( struct cons_pointer location, location ), make_cons( make_cons ( privileged_keyword_payload, - message ), NIL ) ), frame_pointer ); + message ), + (nilp( cause) ? NIL : + make_cons( make_cons( privileged_keyword_cause, + cause), NIL)) ) ), frame_pointer ); } return result; + +} + +/** + * Throw an exception. + * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a + * lisp function; but it is nevertheless to be preferred to make_exception. A + * real `throw_exception`, which does, will be needed. + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct cons_pointer +throw_exception( struct cons_pointer location, + struct cons_pointer payload, + struct cons_pointer frame_pointer ) { + return throw_exception_with_cause( location, payload, NIL, frame_pointer); } /** @@ -1393,8 +1418,9 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer message = frame->arg[0]; - return exceptionp( message ) ? message : throw_exception( message, + return exceptionp( message ) ? message : throw_exception_with_cause( message, frame->arg[1], + frame->arg[2], frame->previous ); } diff --git a/src/ops/lispops.h b/src/ops/lispops.h index da2428a..630592f 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -190,6 +190,10 @@ struct cons_pointer lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer throw_exception_with_cause( struct cons_pointer location, + struct cons_pointer message, + struct cons_pointer cause, + struct cons_pointer frame_pointer ); /** * Throw an exception. * `throw_exception` is a misnomer, because it doesn't obey the calling