From 90e862cc5917dbcdc742814fa0389df4a11766b8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 25 Feb 2026 20:13:57 +0000 Subject: [PATCH 1/3] `let` segfault bug "fixed". *But* I suspect there's memory leaking here. --- src/ops/lispops.c | 12 +++++++----- unit-tests/let.sh | 40 ++++++++++++++++++++-------------------- 2 files changed, 27 insertions(+), 25 deletions(-) diff --git a/src/ops/lispops.c b/src/ops/lispops.c index fc91e9c..074566e 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1639,7 +1639,6 @@ struct cons_pointer lisp_let( struct stack_frame *frame, bindings = make_cons( make_cons( symbol, val ), bindings ); - } else { result = throw_exception( c_string_to_lisp_string @@ -1649,6 +1648,8 @@ struct cons_pointer lisp_let( struct stack_frame *frame, } } + debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND); + /* i.e., no exception yet */ for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) { result = @@ -1656,10 +1657,11 @@ struct cons_pointer lisp_let( struct stack_frame *frame, bindings ); } - // release the local bindings as they go out of scope! - for (struct cons_pointer cursor = bindings; !eq( cursor, env); cursor = c_cdr(cursor)) { - dec_ref( cursor); - } + /* release the local bindings as they go out of scope! **BUT** + * bindings were consed onto the front of env, so caution... */ + // for (struct cons_pointer cursor = bindings; !eq( cursor, env); cursor = c_cdr(cursor)) { + // dec_ref( cursor); + // } return result; diff --git a/unit-tests/let.sh b/unit-tests/let.sh index ad75185..037a96a 100755 --- a/unit-tests/let.sh +++ b/unit-tests/let.sh @@ -2,28 +2,28 @@ result=0 -# echo -n "$0: let with two bindings, one form in body..." -# expected='11' -# actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse 2>/dev/null | tail -1` +echo -n "$0: let with two bindings, one form in body..." +expected='11' +actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse 2>/dev/null | tail -1` -# if [ "${expected}" = "${actual}" ] -# then -# echo "OK" -# else -# echo "Fail: expected '$expected', got '$actual'" -# result=`echo "${result} + 1" | bc` -# fi +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '$expected', got '$actual'" + result=`echo "${result} + 1" | bc` +fi -# echo -n "$0: let with two bindings, two forms in body..." -# expected='1' -# actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse 2>/dev/null | tail -1` +echo -n "$0: let with two bindings, two forms in body..." +expected='1' +actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse 2>/dev/null | tail -1` -# if [ "${expected}" = "${actual}" ] -# then -# echo "OK" -# else -# echo "Fail: expected '$expected', got '$actual'" -# result=`echo "${result} + 1" | bc` -# fi +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '$expected', got '$actual'" + result=`echo "${result} + 1" | bc` +fi exit ${result} \ No newline at end of file From ffceda5edc572a49fc49d333d2c6bcf9803e64bf Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 25 Feb 2026 22:10:37 +0000 Subject: [PATCH 2/3] Greatly improved performance of `equal` for string like things. --- src/memory/consspaceobject.c | 2 +- src/ops/equal.c | 47 ++++++++++++++++++++++++------------ src/ops/equal.h | 6 +++++ 3 files changed, 39 insertions(+), 16 deletions(-) diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 3f85ed6..0bd0b90 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -150,7 +150,7 @@ struct cons_pointer c_car( struct cons_pointer arg ) { /** * Implementation of cdr in C. If arg is not a sequence, or the current user is - * not authorised to read it,does not error but returns nil. + * not authorised to read it, does not error but returns nil. */ struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer result = NIL; diff --git a/src/ops/equal.c b/src/ops/equal.c index 1ad2fdc..fca8f61 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -9,6 +9,7 @@ #include #include +#include #include "arith/integer.h" #include "arith/peano.h" @@ -363,22 +364,38 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { /* 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) */ + if (cell_a->payload.string.hash == cell_b->payload.string.hash) { + wchar_t a_buff[ STRING_SHIPYARD_SIZE], b_buff[ STRING_SHIPYARD_SIZE]; + uint32_t tag = cell_a->tag.value; + int i = 0; + + memset(a_buff,0,sizeof(a_buff)); + memset(b_buff,0,sizeof(b_buff)); + + for (; (i < (STRING_SHIPYARD_SIZE - 1)) && !nilp( a) && !nilp( b); i++) { + a_buff[i] = cell_a->payload.string.character; + a = c_cdr(a); + cell_a = &pointer2cell( a ); + + b_buff[i] = cell_b->payload.string.character; + b = c_cdr( b); + cell_b = &pointer2cell( b); + } + #ifdef DEBUG - debug_print( L"Comparing '", DEBUG_ARITH); - debug_print_object( a, DEBUG_ARITH); - debug_print( L"' to '", DEBUG_ARITH); - debug_print_object( b, DEBUG_ARITH); + debug_print( L"Comparing '", DEBUG_LAMBDA); + debug_print( a_buff, DEBUG_LAMBDA); + debug_print( L"' to '", DEBUG_LAMBDA); + debug_print( b_buff, DEBUG_LAMBDA); + debug_print( L"'\n", DEBUG_LAMBDA); #endif - result = - cell_a->payload.string.hash == cell_b->payload.string.hash - && 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 ) ) ); + + /* OK, now we have wchar string buffers loaded from the objects. We + * may not have exhausted either string, so the buffers being equal + * isn't sufficient. So we recurse at least once. */ + + result = (wcsncmp( a_buff, b_buff, i) == 0) && equal( c_cdr(a), c_cdr(b)); + } break; case VECTORPOINTTV: if ( cell_b->tag.value == VECTORPOINTTV) { @@ -403,7 +420,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * I'll ignore them, too, for now. */ - debug_printf( DEBUG_ARITH, L"\nequal returning %d\n", result ); + debug_printf( DEBUG_LAMBDA, L"\nequal returning %d\n", result ); return result; } diff --git a/src/ops/equal.h b/src/ops/equal.h index 1f27104..061eb94 100644 --- a/src/ops/equal.h +++ b/src/ops/equal.h @@ -15,6 +15,12 @@ #ifndef __equal_h #define __equal_h +/** + * size of buffer for assembling strings. Likely to be useful to + * read, too. + */ +#define STRING_SHIPYARD_SIZE 1024 + /** * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. From af21e506efbf22884d5eb30fb1cbb504afe43a51 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 25 Feb 2026 22:16:14 +0000 Subject: [PATCH 3/3] Whoops! Had the wrong debug tag on debug calls in equal.c --- src/ops/equal.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/ops/equal.c b/src/ops/equal.c index fca8f61..cdfabbf 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -383,11 +383,11 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { } #ifdef DEBUG - debug_print( L"Comparing '", DEBUG_LAMBDA); - debug_print( a_buff, DEBUG_LAMBDA); - debug_print( L"' to '", DEBUG_LAMBDA); - debug_print( b_buff, DEBUG_LAMBDA); - debug_print( L"'\n", DEBUG_LAMBDA); + debug_print( L"Comparing '", DEBUG_ARITH); + debug_print( a_buff, DEBUG_ARITH); + debug_print( L"' to '", DEBUG_ARITH); + debug_print( b_buff, DEBUG_ARITH); + debug_print( L"'\n", DEBUG_ARITH); #endif /* OK, now we have wchar string buffers loaded from the objects. We @@ -420,7 +420,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * I'll ignore them, too, for now. */ - debug_printf( DEBUG_LAMBDA, L"\nequal returning %d\n", result ); + debug_printf( DEBUG_ARITH, L"\nequal returning %d\n", result ); return result; }