simon/post-scarcity
1
0
Fork 0
Code Issues 7 Pull requests Projects Releases Packages Wiki Activity Actions

Added 'depth' counter to stack frames. The idea is two-fold:

Browse source 
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.
This commit is contained in:
Simon Brooke 2026-03-02 11:10:29 +00:00
parent 72a8bc09e0
commit 2536e76617
7 changed files with 140 additions and 79 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/init.c
View file

@ -96,6 +96,9 @@ void maybe_bind_init_symbols( ) {
if ( nilp( privileged_keyword_payload ) ) { if ( nilp( privileged_keyword_payload ) ) {
privileged_keyword_payload = c_string_to_lisp_keyword( L"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( ) { void free_init_symbols( ) {

6
src/memory/consspaceobject.c
View file

@ -39,6 +39,12 @@ struct cons_pointer privileged_keyword_location = NIL;
*/ */
struct cons_pointer privileged_keyword_payload = 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`, * 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 * or, if the tag of the cell is `VECP`, if the value of the tag of the

8
src/memory/consspaceobject.h
View file

@ -68,6 +68,12 @@ extern struct cons_pointer privileged_keyword_location;
*/ */
extern struct cons_pointer privileged_keyword_payload; 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 * An unallocated cell on the free list - should never be encountered by a Lisp
* function. * function.
@ -456,6 +462,8 @@ struct stack_frame {
struct cons_pointer function; struct cons_pointer function;
/** the number of arguments provided. */ /** the number of arguments provided. */
int args; int args;
/** the depth of the stack below this frame */
int depth;
}; };
/** /**

5
src/memory/stack.c
View file

@ -98,6 +98,8 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
for ( int i = 0; i < args_in_frame; i++ ) { for ( int i = 0; i < args_in_frame; i++ ) {
frame->arg[i] = NIL; 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_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_dump_object( result, 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 ); struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) { 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 ); frame->args );
dump_frame_context( output, frame_pointer, 4 ); dump_frame_context( output, frame_pointer, 4 );

151
src/ops/intern.c
View file

@ -316,81 +316,92 @@ struct cons_pointer search_store( struct cons_pointer key,
return_key ? "key" : "value" ); return_key ? "key" : "value" );
#endif #endif
if ( symbolp( key ) || keywordp( key ) ) { switch ( get_tag_value( key) ) {
struct cons_space_object *store_cell = &pointer2cell( store ); case SYMBOLTV:
case KEYTV:
struct cons_space_object *store_cell = &pointer2cell( store );
switch ( get_tag_value( store ) ) { switch ( get_tag_value( store ) ) {
case CONSTV: case CONSTV:
for ( struct cons_pointer cursor = store; for ( struct cons_pointer cursor = store;
nilp( result ) && ( consp( cursor ) nilp( result ) && ( consp( cursor )
|| hashmapp( cursor ) ); || hashmapp( cursor ) );
cursor = pointer2cell( cursor ).payload.cons.cdr ) { cursor = pointer2cell( cursor ).payload.cons.cdr ) {
switch ( get_tag_value( cursor ) ) { switch ( get_tag_value( cursor ) ) {
case CONSTV: case CONSTV:
struct cons_pointer entry_ptr = c_car( cursor ); struct cons_pointer entry_ptr = c_car( cursor );
switch ( get_tag_value( entry_ptr ) ) { switch ( get_tag_value( entry_ptr ) ) {
case CONSTV: case CONSTV:
if ( equal( key, c_car( entry_ptr ) ) ) { 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 = result =
return_key ? c_car( entry_ptr ) : hashmap_get( entry_ptr, key,
c_cdr( entry_ptr ); return_key );
} break;
break; default:
case HASHTV: result =
case NAMESPACETV: throw_exception
// TODO: I think this should be impossible, and we should maybe ( c_string_to_lisp_symbol
// throw an exception. ( L"search-store (entry)" ),
result = make_cons( c_string_to_lisp_string
hashmap_get( entry_ptr, key, ( L"Unexpected store type: " ),
return_key ); c_type( c_car
break; ( entry_ptr ) ) ),
default: NIL );
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; break;
case HASHTV: case HASHTV:
case NAMESPACETV: case NAMESPACETV:
debug_print debug_print
( L"\n\tHashmap as top-level value in list", ( L"\n\tHashmap as top-level value in list",
DEBUG_BIND ); DEBUG_BIND );
result = hashmap_get( cursor, key, return_key ); result = hashmap_get( cursor, key, return_key );
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol throw_exception( c_string_to_lisp_symbol
( L"search-store (cursor)" ), ( L"search-store (cursor)" ),
make_cons make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Unexpected store type: " ), ( L"Unexpected store type: " ),
c_type( cursor ) ), NIL ); c_type( cursor ) ), NIL );
}
} }
} break;
break; case HASHTV:
case HASHTV: case NAMESPACETV:
case NAMESPACETV: result = hashmap_get( store, key, return_key );
result = hashmap_get( store, key, return_key ); break;
break; default:
default: result =
result = throw_exception( c_string_to_lisp_symbol
throw_exception( c_string_to_lisp_symbol ( L"search-store (store)" ),
( L"search-store (store)" ), make_cons( c_string_to_lisp_string
make_cons( c_string_to_lisp_string ( L"Unexpected store type: " ),
( L"Unexpected store type: " ), c_type( store ) ), NIL );
c_type( store ) ), NIL ); break;
break; }
} break;
} else { case EXCEPTIONTV:
// failing with key type NIL here (?). Probably worth dumping the stack? 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 = result =
throw_exception( c_string_to_lisp_symbol( L"search-store (key)" ), throw_exception( c_string_to_lisp_symbol( L"search-store (key)" ),
make_cons make_cons

42
src/ops/lispops.c
View file

@ -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 * `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 * lisp function; but it is nevertheless to be preferred to make_exception. A
* real `throw_exception`, which does, will be needed. * real `throw_exception`, which does, will be needed.
* object pointing to it. Then this should become a normal lisp function * object pointing to it. Then this should become a normal lisp function
* which expects a normally bound frame and environment, such that * 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. * pointer to the frame in which the exception occurred.
*/ */
struct cons_pointer struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
throw_exception( struct cons_pointer location,
struct cons_pointer message, struct cons_pointer message,
struct cons_pointer cause,
struct cons_pointer frame_pointer ) { struct cons_pointer frame_pointer ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -1350,9 +1350,13 @@ throw_exception( struct cons_pointer location,
debug_print( L"` at `", 511 ); debug_print( L"` at `", 511 );
debug_print_object( location, 511 ); debug_print_object( location, 511 );
debug_print( L"`\n", 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 #endif
struct cons_space_object *cell = &pointer2cell( message ); struct cons_space_object *cell = &pointer2cell( message );
if ( cell->tag.value == EXCEPTIONTV ) { if ( cell->tag.value == EXCEPTIONTV ) {
@ -1364,10 +1368,31 @@ throw_exception( struct cons_pointer location,
location ), location ),
make_cons( make_cons make_cons( make_cons
( privileged_keyword_payload, ( privileged_keyword_payload,
message ), NIL ) ), frame_pointer ); message ),
(nilp( cause) ? NIL :
make_cons( make_cons( privileged_keyword_cause,
cause), NIL)) ) ), frame_pointer );
} }
return result; 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 env ) {
struct cons_pointer message = frame->arg[0]; 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[1],
frame->arg[2],
frame->previous ); frame->previous );
} }

4
src/ops/lispops.h
View file

@ -190,6 +190,10 @@ struct cons_pointer lisp_cond( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); 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 an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling * `throw_exception` is a misnomer, because it doesn't obey the calling