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

Getting closer to tracking down the member bug, but cannot use debugger on laptop screen.

Browse source
This commit is contained in:
Simon Brooke 2026-03-16 15:26:12 +00:00
parent d42ece5711
commit de50a30be2
11 changed files with 89 additions and 55 deletions
Download patch file Download diff file Expand all files Collapse all files

3
Makefile
View file

@ -46,6 +46,9 @@ test: $(TESTS) Makefile $(TARGET)
clean: clean:
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ $(TMP_DIR)/* *~ core.* $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ $(TMP_DIR)/* *~ core.*
coredumps:
ulimit -c unlimited
repl: repl:
$(TARGET) -p 2> psse.log $(TARGET) -p 2> psse.log

9
docs/State-of-play.md
View file

@ -1,5 +1,14 @@
# State of Play # State of Play
## 20260316
OK, where we're at:
* The garbage collector is doing *even worse* than it was on 4th
February, when I did the last serious look at it.
* The bignum bugs are not fixed.
* You can (optionally) limit runaway stack crashes with a new command line option.
* If you enable the stack limiter feature, `(member? 5 '(1 2 3 4))` returns `nil`, as it should, and does not throw a stack limit exception, but if you do not enable it, `(member? 5 '(1 2 3 4))` causes a segfault. WTAF?
## 20260314 ## 20260314
When I put a debugger on it, the stack limit bug proved shallow. When I put a debugger on it, the stack limit bug proved shallow.

4
lisp/documentation.lisp
View file

@ -10,9 +10,7 @@
(set! member? (lambda (set! member? (lambda
(item collection) (item collection)
"`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`." "`(member? item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
(print (list "In member? item is " item "; collection is " collection))
(println)
(cond (cond
((= 0 (count collection)) nil) ((= 0 (count collection)) nil)
((= item (car collection)) t) ((= item (car collection)) t)

2
lisp/member.lisp
View file

@ -5,7 +5,7 @@
(set! member? (lambda (set! member? (lambda
(item collection) (item collection)
"`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`." "`(member? item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
(cond (cond
((nil? collection) nil) ((nil? collection) nil)
((= item (car collection)) t) ((= item (car collection)) t)

43
src/init.c
View file

@ -47,11 +47,12 @@
*/ */
struct cons_pointer check_exception( struct cons_pointer pointer, struct cons_pointer check_exception( struct cons_pointer pointer,
char *location_descriptor ) { char *location_descriptor ) {
struct cons_pointer result = NIL; struct cons_pointer result = pointer;
struct cons_space_object *object = &pointer2cell( pointer );
if ( exceptionp( pointer ) ) { if ( exceptionp( pointer ) ) {
struct cons_space_object * object = &pointer2cell( pointer);
result = NIL;
fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor ); fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor );
URL_FILE *ustderr = file_to_url_file( stderr ); URL_FILE *ustderr = file_to_url_file( stderr );
fwide( stderr, 1 ); fwide( stderr, 1 );
@ -59,27 +60,21 @@ struct cons_pointer check_exception( struct cons_pointer pointer,
free( ustderr ); free( ustderr );
dec_ref( pointer ); dec_ref( pointer );
} else {
result = pointer;
} }
return result; return result;
} }
struct cons_pointer init_documentation_symbol = NIL;
struct cons_pointer init_name_symbol = NIL;
struct cons_pointer init_primitive_symbol = NIL;
void maybe_bind_init_symbols( ) { void maybe_bind_init_symbols( ) {
if ( nilp( init_documentation_symbol ) ) { if ( nilp( privileged_keyword_documentation ) ) {
init_documentation_symbol = privileged_keyword_documentation =
c_string_to_lisp_keyword( L"documentation" ); c_string_to_lisp_keyword( L"documentation" );
} }
if ( nilp( init_name_symbol ) ) { if ( nilp( privileged_keyword_name ) ) {
init_name_symbol = c_string_to_lisp_keyword( L"name" ); privileged_keyword_name = c_string_to_lisp_keyword( L"name" );
} }
if ( nilp( init_primitive_symbol ) ) { if ( nilp( privileged_keyword_primitive ) ) {
init_primitive_symbol = c_string_to_lisp_keyword( L"primitive" ); privileged_keyword_primitive = c_string_to_lisp_keyword( L"primitive" );
} }
if ( nilp( privileged_symbol_nil ) ) { if ( nilp( privileged_symbol_nil ) ) {
privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" ); privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" );
@ -102,9 +97,9 @@ void maybe_bind_init_symbols( ) {
} }
void free_init_symbols( ) { void free_init_symbols( ) {
dec_ref( init_documentation_symbol ); dec_ref( privileged_keyword_documentation );
dec_ref( init_name_symbol ); dec_ref( privileged_keyword_name );
dec_ref( init_primitive_symbol ); dec_ref( privileged_keyword_primitive );
} }
/** /**
@ -124,10 +119,10 @@ struct cons_pointer bind_function( wchar_t *name,
struct cons_pointer d = c_string_to_lisp_string( doc ); struct cons_pointer d = c_string_to_lisp_string( doc );
struct cons_pointer meta = struct cons_pointer meta =
make_cons( make_cons( init_primitive_symbol, TRUE ), make_cons( make_cons( privileged_keyword_primitive, TRUE ),
make_cons( make_cons( init_name_symbol, n ), make_cons( make_cons( privileged_keyword_name, n ),
make_cons( make_cons make_cons( make_cons
( init_documentation_symbol, d ), ( privileged_keyword_documentation, d ),
NIL ) ) ); NIL ) ) );
struct cons_pointer r = struct cons_pointer r =
@ -153,10 +148,10 @@ struct cons_pointer bind_special( wchar_t *name,
struct cons_pointer d = c_string_to_lisp_string( doc ); struct cons_pointer d = c_string_to_lisp_string( doc );
struct cons_pointer meta = struct cons_pointer meta =
make_cons( make_cons( init_primitive_symbol, TRUE ), make_cons( make_cons( privileged_keyword_primitive, TRUE ),
make_cons( make_cons( init_name_symbol, n ), make_cons( make_cons( privileged_keyword_name, n ),
make_cons( make_cons make_cons( make_cons
( init_documentation_symbol, d ), ( privileged_keyword_documentation, d ),
NIL ) ) ); NIL ) ) );
struct cons_pointer r = struct cons_pointer r =

20
src/memory/consspaceobject.c
View file

@ -45,6 +45,26 @@ struct cons_pointer privileged_keyword_payload = NIL;
*/ */
struct cons_pointer privileged_keyword_cause = NIL; struct cons_pointer privileged_keyword_cause = NIL;
/**
* @brief keywords used in documentation: `:documentation`. Instantiated in
* `init.c`, q. v.
*
*/
struct cons_pointer privileged_keyword_documentation = NIL;
/**
* @brief keywords used in documentation: `:name`. Instantiated in
* `init.c`, q. v.
*/
struct cons_pointer privileged_keyword_name = NIL;
/**
* @brief keywords used in documentation: `:primitive`. Instantiated in
* `init.c`, q. v.
*/
struct cons_pointer privileged_keyword_primitive = 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

18
src/memory/consspaceobject.h
View file

@ -74,6 +74,24 @@ extern struct cons_pointer privileged_keyword_payload;
*/ */
extern struct cons_pointer privileged_keyword_cause; extern struct cons_pointer privileged_keyword_cause;
/**
* @brief keywords used in documentation: `:documentation`. Instantiated in
* `init.c`, q. v.
*/
extern struct cons_pointer privileged_keyword_documentation;
/**
* @brief keywords used in documentation: `:name`. Instantiated in
* `init.c`, q. v.
*/
extern struct cons_pointer privileged_keyword_name;
/**
* @brief keywords used in documentation: `:primitive`. Instantiated in
* `init.c`, q. v.
*/
extern struct cons_pointer privileged_keyword_primitive;
/** /**
* 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.

29
src/ops/lispops.c
View file

@ -91,7 +91,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
{ {
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_empty_frame( parent_pointer ); make_empty_frame( parent_pointer );
// inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
@ -275,7 +275,6 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
names = c_cdr( names ); names = c_cdr( names );
} }
// inc_ref( new_env );
/* \todo if there's more than `args_in_frame` arguments, bind those too. */ /* \todo if there's more than `args_in_frame` arguments, bind those too. */
} else if ( symbolp( names ) ) { } else if ( symbolp( names ) ) {
@ -296,7 +295,6 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
} }
new_env = set( names, vals, new_env ); new_env = set( names, vals, new_env );
// inc_ref( new_env );
} }
while ( !nilp( body ) ) { while ( !nilp( body ) ) {
@ -311,9 +309,7 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
/* if a result is not the terminal result in the lambda, it's a /* if a result is not the terminal result in the lambda, it's a
* side effect, and needs to be GCed */ * side effect, and needs to be GCed */
if ( !nilp( result ) ) {
dec_ref( result ); dec_ref( result );
}
result = eval_form( frame, frame_pointer, sexpr, new_env ); result = eval_form( frame, frame_pointer, sexpr, new_env );
@ -322,6 +318,7 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
} }
} }
// TODO: I think we do need to dec_ref everything on new_env back to env
// dec_ref( new_env ); // dec_ref( new_env );
debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA );
@ -346,8 +343,6 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
struct cons_pointer payload = struct cons_pointer payload =
pointer2cell( result ).payload.exception.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" );
switch ( get_tag_value( payload ) ) { switch ( get_tag_value( payload ) ) {
case NILTV: case NILTV:
@ -358,7 +353,7 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
payload ) ) ) { payload ) ) ) {
pointer2cell( result ).payload.exception.payload = pointer2cell( result ).payload.exception.payload =
set( privileged_keyword_location, set( privileged_keyword_location,
c_assoc( name_key, c_assoc( privileged_keyword_name,
fn_cell->payload.function.meta ), fn_cell->payload.function.meta ),
payload ); payload );
} }
@ -367,15 +362,13 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
default: default:
pointer2cell( result ).payload.exception.payload = pointer2cell( result ).payload.exception.payload =
make_cons( make_cons( privileged_keyword_location, make_cons( make_cons( privileged_keyword_location,
c_assoc( name_key, c_assoc( privileged_keyword_name,
fn_cell->payload.function. fn_cell->payload.function.
meta ) ), meta ) ),
make_cons( make_cons make_cons( make_cons
( privileged_keyword_payload, ( privileged_keyword_payload,
payload ), NIL ) ); payload ), NIL ) );
} }
dec_ref( name_key );
} }
return result; return result;
@ -415,7 +408,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env ); make_stack_frame( frame_pointer, args, env );
// inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
@ -446,7 +439,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env ); make_stack_frame( frame_pointer, args, env );
// inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
@ -475,7 +468,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
{ {
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env ); make_special_frame( frame_pointer, args, env );
// inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
@ -492,7 +485,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
{ {
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env ); make_special_frame( frame_pointer, args, env );
// inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
@ -580,7 +573,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
message, frame_pointer ); message, frame_pointer );
} else { } else {
result = c_assoc( canonical, env ); result = c_assoc( canonical, env );
inc_ref( result ); // inc_ref( result );
} }
} }
break; break;
@ -1196,7 +1189,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
while ( consp( expressions ) ) { while ( consp( expressions ) ) {
struct cons_pointer r = result; struct cons_pointer r = result;
inc_ref( r );
result = eval_form( frame, frame_pointer, c_car( expressions ), env ); result = eval_form( frame, frame_pointer, c_car( expressions ), env );
dec_ref( r ); dec_ref( r );
@ -1227,7 +1220,6 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
struct cons_pointer r = result; struct cons_pointer r = result;
inc_ref( r );
result = eval_form( frame, frame_pointer, frame->arg[i], env ); result = eval_form( frame, frame_pointer, frame->arg[i], env );
@ -1672,7 +1664,6 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame,
for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) {
struct cons_pointer expr = struct cons_pointer expr =
make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) ); make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) );
inc_ref( expr );
debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i );
debug_print_object( expr, DEBUG_EVAL ); debug_print_object( expr, DEBUG_EVAL );

8
unit-tests/let.sh
View file

@ -2,9 +2,9 @@
result=0 result=0
echo -n "$0: let with two bindings, one form in body..."
expected='11' expected='11'
actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse 2>/dev/null | tail -1` actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse | tail -1`
echo -n "$0: let with two bindings, one form in body... "
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]
then then
@ -14,9 +14,9 @@ else
result=`echo "${result} + 1" | bc` result=`echo "${result} + 1" | bc`
fi fi
echo -n "$0: let with two bindings, two forms in body..."
expected='1' expected='1'
actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse 2>/dev/null | tail -1` actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse | tail -1`
echo -n "$0: let with two bindings, two forms in body..."
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]
then then

4
unit-tests/progn.sh
View file

@ -4,7 +4,7 @@ result=0
echo -n "$0: progn with one form... " echo -n "$0: progn with one form... "
expected='5' expected='5'
actual=`echo "(progn (add 2 3))" | target/psse 2>/dev/null | tail -1` actual=`echo "(progn (add 2 3))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]
then then
@ -16,7 +16,7 @@ fi
echo -n "$0: progn with two forms... " echo -n "$0: progn with two forms... "
expected='"foo"' expected='"foo"'
actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2>/dev/null | tail -1` actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]
then then

2
unit-tests/recursion.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash #!/bin/bash
expected='nil 3,628,800' expected='nil 3,628,800'
output=`target/psse 2>/dev/null <<EOF output=`target/psse <<EOF
(progn (progn
(set! fact (set! fact
(lambda (n) (lambda (n)