From 8c63272214936514950a61e66441c94856b2275f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 25 Feb 2026 11:17:40 +0000 Subject: [PATCH] Fixed runaway recursion in `cond`. However, `let` is still segfaulting, and `member` does not work correctly. --- docs/state-of-play.md | 105 +++++++++++++++++++++++++++++++ lisp/documentation.lisp | 27 +++++--- lisp/member.lisp | 11 +++- src/debug.c | 16 +++++ src/debug.h | 4 ++ src/init.c | 20 +++--- src/memory/conspage.c | 6 ++ src/memory/conspage.h | 2 + src/memory/stack.c | 56 +++++++++++++---- src/ops/intern.c | 131 ++++++++++++++++++--------------------- src/ops/lispops.c | 134 +++++++++++++++++++++++----------------- unit-tests/add.sh | 2 +- 12 files changed, 358 insertions(+), 156 deletions(-) diff --git a/docs/state-of-play.md b/docs/state-of-play.md index fc94b76..6893091 100644 --- a/docs/state-of-play.md +++ b/docs/state-of-play.md @@ -1,5 +1,110 @@ # State of Play +## 20260224 + +Found a bug in subtraction, which I hoped might be a clue into the bignum bug; +but it proved just to be a careless bug in the small integer cache code (and +therefore a new regression). Fixed this one, easily. + +In the process spotted a new bug in subtracting rationals, which I haven't yet +looked at. + +Currently working on a bug which is either in `let` or `cond`, which is leading +to non-terminating recursion... + +H'mmm, there are bugs in both. + +#### `let` + +The unit test for let is segfaulting. That's a new regression today, because in +last night's buildv it doesn't segfault. I don't know what's wrong, but to be +honest I haven't looked very hard because I'm trying to fix the bug in `cond`. + +#### `cond` + +The unit test for `cond` still passes, so the bug that I'm seeing is not +triggered by it. So it's not necessarily a new bug. What's happening? Well, +`member` doesn't terminate. + +The definition is as follows: + +```lisp +(set! nil? + (lambda + (o) + "`(nil? object)`: Return `t` if object is `nil`, else `t`." + (= o nil))) + +(set! member + (lambda + (item collection) + "`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`." + (cond + ((nil? collection) nil) + ((= item (car collection)) t) + (t (member item (cdr collection)))))) +``` + +In the execution trace, with tracing of bind, eval and lambda enabled, I'm +seeing this loop on the stack: + +``` +Stack frame with 1 arguments: + Context: <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" +Arg 0: CONS count: 6 value: (member item (cdr collection)) +Stack frame with 3 arguments: + Context: <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection)) +Arg 0: CONS count: 7 value: ((nil? collection) nil) +Arg 1: CONS count: 7 value: ((= item (car collection)) t) +Arg 2: CONS count: 7 value: (t (member item (cdr collection))) +Stack frame with 1 arguments: + Context: <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil) +Arg 0: CONS count: 8 value: (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) +Stack frame with 2 arguments: + Context: <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) +Arg 0: STRG count: 19 value: "LMDA" +Arg 1: NIL count: 4294967295 value: nil +Stack frame with 1 arguments: + Context: <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" +Arg 0: CONS count: 6 value: (member item (cdr collection)) +Stack frame with 3 arguments: + Context: <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection)) +Arg 0: CONS count: 7 value: ((nil? collection) nil) +Arg 1: CONS count: 7 value: ((= item (car collection)) t) +Arg 2: CONS count: 7 value: (t (member item (cdr collection))) +Stack frame with 1 arguments: + Context: <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil) +Arg 0: CONS count: 8 value: (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) +Stack frame with 2 arguments: + Context: <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) +Arg 0: STRG count: 19 value: "LMDA" +Arg 1: NIL count: 4294967295 value: nil +``` + +This then just goes on, and on, and on. The longest instance I've got the trace of wound up more than a third of a million stack frames before I killed it. What appears to be happening is that the cond clause + +```lisp +((nil? collection) nil) +``` + +Executes correctly and returns nil; but that instead of terminating the cond expression at that point it continues and executes the following two clauses, resulting in (infinite) recursion. + +This is bad. + +But what's worse is that the clause + +```lisp +((= item (car collection)) t) +``` + +also doesn't terminate the `cond` expression, even when it should. + +And the reason? From the trace, it appears that clauses *never* succeed. But if that's true, how come the unit tests are passing? + +Problem for another day. + +I'm not going to commit today's work to git, because I don't want to commit something I know segfaults. + ## 20260220 ### State of the build diff --git a/lisp/documentation.lisp b/lisp/documentation.lisp index 22bd9e7..872cd3d 100644 --- a/lisp/documentation.lisp +++ b/lisp/documentation.lisp @@ -1,9 +1,20 @@ -(set! documentation (lambda (object) - (cond ((= (type object) "LMDA") - (let (d (nth 3 (source object))) - (cond ((string? d) d) - (t (source object))))) - ((member (type object) '("FUNC" "SPFM")) - (:documentation (meta object)))))) +;; This version segfaults, I think due to a bug in `let`? +;; (set! documentation (lambda (object) +;; (cond ((= (type object) "LMDA") +;; (let ((d . (nth 3 (source object)))) +;; (cond ((string? d) d) +;; (t (source object))))) +;; ((member (type object) '("FUNC" "SPFM")) +;; (:documentation (meta object)))))) +;; +;; (set! doc documentation) -(set! doc documentation) +;; This version returns nil even when documentation exists, but doesn't segfault. +(set! documentation + (lambda (object) + "`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`." + (cond ((and (member (type object) '("LMDA" "NLMD")) + (string? (nth 3 (source object)))) + (nth 3 (source object))) + ((member (type object) '("FUNC" "SPFM")) + (:documentation (meta object)))))) diff --git a/lisp/member.lisp b/lisp/member.lisp index 4fc29cd..9d8a7a5 100644 --- a/lisp/member.lisp +++ b/lisp/member.lisp @@ -1,9 +1,14 @@ -(set! nil? (lambda (o) (= o nil))) +(set! nil? (lambda + (o) + "`(nil? object)`: Return `t` if object is `nil`, else `t`." + (= o nil))) (set! member (lambda (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 ((nil? collection) nil) ((= item (car collection)) t) - (t (member item (cdr collection)))))) \ No newline at end of file + (t (member item (cdr collection)))))) + +(member (type member) '("LMDA" "NLMD")) diff --git a/src/debug.c b/src/debug.c index d139f8c..6fa258a 100644 --- a/src/debug.c +++ b/src/debug.c @@ -143,3 +143,19 @@ void debug_dump_object( struct cons_pointer pointer, int level ) { } #endif } + +/** + * Standardise printing of binding trace messages. + */ +void debug_print_binding( struct cons_pointer key, struct cons_pointer val, bool deep, int level) { +#ifdef DEBUG + // wchar_t * depth = (deep ? L"Deep" : L"Shallow"); + + debug_print( (deep ? L"Deep" : L"Shallow"), level); + debug_print( L" binding `", level); + debug_print_object( key, level); + debug_print( L"` to `", level); + debug_print_object( val, level); + debug_print( L"`\n", level); +#endif +} \ No newline at end of file diff --git a/src/debug.h b/src/debug.h index 41c1618..1bf2c18 100644 --- a/src/debug.h +++ b/src/debug.h @@ -8,8 +8,11 @@ */ #include +#include #include +#include "memory/consspaceobject.h" + #ifndef __debug_print_h #define __debug_print_h @@ -84,5 +87,6 @@ void debug_println( int level ); void debug_printf( int level, wchar_t *format, ... ); void debug_print_object( struct cons_pointer pointer, int level ); void debug_dump_object( struct cons_pointer pointer, int level ); +void debug_print_binding( struct cons_pointer key, struct cons_pointer val, bool deep, int level); #endif diff --git a/src/init.c b/src/init.c index 6a8ae55..d8e72e7 100644 --- a/src/init.c +++ b/src/init.c @@ -20,23 +20,22 @@ /* libcurl, used for io */ #include +#include "arith/peano.h" #include "arith/ratio.h" -#include "version.h" +#include "debug.h" +#include "io/fopen.h" +#include "io/io.h" +#include "io/print.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" -#include "memory/stack.h" -#include "debug.h" #include "memory/hashmap.h" +#include "memory/stack.h" #include "ops/intern.h" -#include "io/io.h" -#include "io/fopen.h" #include "ops/lispops.h" #include "ops/meta.h" -#include "arith/peano.h" -#include "io/print.h" #include "repl.h" -#include "io/fopen.h" #include "time/psse_time.h" +#include "version.h" /** * @brief If `pointer` is an exception, display that exception to stderr, @@ -84,6 +83,11 @@ void maybe_bind_init_symbols( ) { if ( nilp( privileged_symbol_nil ) ) { privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" ); } + if ( nilp( privileged_string_memory_exhausted)) { + // we can't make this string when we need it, because memory is then + // exhausted! + privileged_string_memory_exhausted = c_string_to_lisp_string( L"Memory exhausted." ); + } } void free_init_symbols( ) { diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 2b236dc..0cc6cc8 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -45,6 +45,12 @@ int initialised_cons_pages = 0; */ struct cons_pointer freelist = NIL; +/** + * The exception message printed when the world blows up, initialised in + * `maybe_bind_init_symbols()` in `init.c`, q.v. + */ +struct cons_pointer privileged_string_memory_exhausted; + /** * An array of pointers to cons pages. */ diff --git a/src/memory/conspage.h b/src/memory/conspage.h index 589f6bf..3bad3ae 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -49,6 +49,8 @@ struct cons_page { struct cons_space_object cell[CONSPAGESIZE]; }; +extern struct cons_pointer privileged_string_memory_exhausted; + extern struct cons_pointer freelist; extern struct cons_page *conspages[NCONSPAGES]; diff --git a/src/memory/stack.c b/src/memory/stack.c index bca9fa0..d1a344e 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -17,14 +17,14 @@ #include -#include "memory/consspaceobject.h" -#include "memory/conspage.h" #include "debug.h" -#include "memory/dump.h" -#include "ops/lispops.h" #include "io/print.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/dump.h" #include "memory/stack.h" #include "memory/vectorspace.h" +#include "ops/lispops.h" /** * set a register in a stack frame. Alwaye use this to do so, @@ -122,7 +122,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, if ( nilp( result ) ) { /* i.e. out of memory */ result = - make_exception( c_string_to_lisp_string( L"Memory exhausted." ), + make_exception( privileged_string_memory_exhausted, previous ); } else { struct stack_frame *frame = get_stack_frame( result ); @@ -163,11 +163,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, frame->more = more; inc_ref( more ); } - } + debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); + debug_dump_object( result, DEBUG_STACK ); } - debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); - debug_dump_object( result, DEBUG_STACK ); return result; } @@ -235,6 +234,40 @@ void free_stack_frame( struct stack_frame *frame ) { debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC ); } +struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer) { + struct stack_frame *frame = get_stack_frame( frame_pointer ); + struct cons_pointer result = NIL; + + if ( frame != NULL ) { + result = frame->previous; + } + + return result; +} + +void dump_frame_context_fragment( URL_FILE *output, struct cons_pointer frame_pointer) { + struct stack_frame *frame = get_stack_frame( frame_pointer ); + + if ( frame != NULL ) { + url_fwprintf( output, L" <= "); + print( output, frame->arg[0]); + } +} + +void dump_frame_context( URL_FILE *output, struct cons_pointer frame_pointer, int depth ) { + struct stack_frame *frame = get_stack_frame( frame_pointer ); + + if ( frame != NULL ) { + url_fwprintf( output, L"\tContext: "); + + int i = 0; + for (struct cons_pointer cursor = frame_pointer; i++ < depth && !nilp( cursor); cursor = frame_get_previous( cursor)) { + dump_frame_context_fragment( output, cursor); + } + + url_fwprintf( output, L"\n"); + } +} /** * Dump a stackframe to this stream for debugging @@ -247,12 +280,13 @@ void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) { if ( frame != NULL ) { url_fwprintf( output, L"Stack frame with %d arguments:\n", frame->args ); + dump_frame_context( output, frame_pointer, 4); + for ( int arg = 0; arg < frame->args; arg++ ) { struct cons_space_object cell = pointer2cell( frame->arg[arg] ); - url_fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", - arg, cell.tag.bytes[0], cell.tag.bytes[1], - cell.tag.bytes[2], cell.tag.bytes[3], cell.count ); + url_fwprintf( output, L"Arg %d:\t%4.4s\tcount: %10u\tvalue: ", + arg, cell.tag.bytes, cell.count ); print( output, frame->arg[arg] ); url_fputws( L"\n", output ); diff --git a/src/ops/intern.c b/src/ops/intern.c index 6ea8261..7ac9d08 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -328,53 +328,63 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ) { struct cons_pointer result = NIL; + + if (!nilp( key)) { + if ( consp( store ) ) { + for ( struct cons_pointer next = store; + nilp( result ) && ( consp( next ) || hashmapp( next ) ); + next = pointer2cell( next ).payload.cons.cdr ) { + if ( consp( next ) ) { +// #ifdef DEBUG +// debug_print( L"\nc_assoc; key is `", DEBUG_BIND ); +// debug_print_object( key, DEBUG_BIND ); +// debug_print( L"`\n", DEBUG_BIND ); +// #endif - debug_print( L"c_assoc; key is `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"`\n", DEBUG_BIND ); + struct cons_pointer entry_ptr = c_car( next ); + struct cons_space_object entry = pointer2cell( entry_ptr ); - if ( consp( store ) ) { - for ( struct cons_pointer next = store; - nilp( result ) && ( consp( next ) || hashmapp( next ) ); - next = pointer2cell( next ).payload.cons.cdr ) { - if ( consp( next ) ) { - struct cons_pointer entry_ptr = c_car( next ); - struct cons_space_object entry = pointer2cell( entry_ptr ); + switch ( entry.tag.value ) { + case CONSTV: + if ( equal( key, entry.payload.cons.car ) ) { + result = entry.payload.cons.cdr; + } + break; + case VECTORPOINTTV: + result = hashmap_get( entry_ptr, key ); + break; + default: + throw_exception( c_append + ( c_string_to_lisp_string + ( L"Store entry is of unknown type: " ), + c_type( entry_ptr ) ), NIL ); + } - switch ( entry.tag.value ) { - case CONSTV: - if ( equal( key, entry.payload.cons.car ) ) { - result = entry.payload.cons.cdr; - } - break; - case VECTORPOINTTV: - result = hashmap_get( entry_ptr, key ); - break; - default: - throw_exception( c_append - ( c_string_to_lisp_string - ( L"Store entry is of unknown type: " ), - c_type( entry_ptr ) ), NIL ); +// #ifdef DEBUG +// debug_print( L"c_assoc `", DEBUG_BIND ); +// debug_print_object( key, DEBUG_BIND ); +// debug_print( L"` returning: ", DEBUG_BIND ); +// debug_print_object( result, DEBUG_BIND ); +// debug_println( DEBUG_BIND ); +// #endif } } + } else if ( hashmapp( store ) ) { + result = hashmap_get( store, key ); + } else if ( !nilp( store ) ) { +// #ifdef DEBUG +// debug_print( L"c_assoc; store is of unknown type `", DEBUG_BIND ); +// debug_printf( DEBUG_BIND, L"%4.4s", (char *)pointer2cell(key).tag.bytes); +// debug_print( L"`\n", DEBUG_BIND ); +// #endif + result = + throw_exception( c_append + ( c_string_to_lisp_string + ( L"Store is of unknown type: " ), + c_type( store ) ), NIL ); } - } else if ( hashmapp( store ) ) { - result = hashmap_get( store, key ); - } else if ( !nilp( store ) ) { - debug_print( L"c_assoc; store is of unknown type `", DEBUG_BIND ); - debug_printf( DEBUG_BIND, L"%4.4s", (char *)pointer2cell(key).tag.bytes); - debug_print( L"`\n", DEBUG_BIND ); - result = - throw_exception( c_append - ( c_string_to_lisp_string - ( L"Store is of unknown type: " ), - c_type( store ) ), NIL ); } - debug_print( L"c_assoc returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND ); - return result; } @@ -415,36 +425,22 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, struct cons_pointer result = NIL; #ifdef DEBUG - debug_print( L"set: binding `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"` to `", DEBUG_BIND ); - debug_print_object( value, DEBUG_BIND ); - debug_print( L"` in store ", DEBUG_BIND ); - debug_dump_object( store, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + bool deep = vectorpointp( store); + debug_print_binding( key, value, deep, DEBUG_BIND); - debug_printf( DEBUG_BIND, L"set: store is %4.4s", - pointer2cell(store).tag.bytes ); - if (strncmp(pointer2cell(store).tag.bytes, VECTORPOINTTAG, TAGLENGTH) == 0) { - debug_printf( DEBUG_BIND, L" -> %4.4s\n", + if (deep) { + debug_printf( DEBUG_BIND, L"\t-> %4.4s\n", pointer2cell(store).payload.vectorp.tag.bytes ); - } else { - debug_println( DEBUG_BIND); - } + } #endif if ( nilp( value ) ) { result = store; } else if ( nilp( store ) || consp( store ) ) { result = make_cons( make_cons( key, value ), store ); } else if ( hashmapp( store ) ) { - debug_print( L"set: storing in hashmap\n", DEBUG_BIND ); result = hashmap_put( store, key, value ); } - debug_print( L"set returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND ); - return result; } @@ -457,18 +453,13 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { struct cons_pointer old = oblist; - debug_print( L"deep_bind: binding `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"` to ", DEBUG_BIND ); - debug_print_object( value, DEBUG_BIND ); - debug_println( DEBUG_BIND ); - oblist = set( key, value, oblist ); - if ( consp( oblist ) ) { - inc_ref( oblist ); - dec_ref( old ); - } + // The oblist is not now an assoc list, and I don't think it will be again. + // if ( consp( oblist ) ) { + // inc_ref( oblist ); + // dec_ref( old ); + // } debug_print( L"deep_bind returning ", DEBUG_BIND ); debug_print_object( key, DEBUG_BIND ); @@ -480,7 +471,7 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { /** * Ensure that a canonical copy of this key is bound in this environment, and * return that canonical copy. If there is currently no such binding, create one - * with the value NIL. + * with the value TRUE. */ struct cons_pointer intern( struct cons_pointer key, struct cons_pointer environment ) { @@ -490,7 +481,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { /* * not currently bound */ - result = set( key, NIL, environment ); + result = set( key, TRUE, environment ); } return result; diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 4f51c3b..4fbebcf 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -109,7 +109,9 @@ struct cons_pointer eval_form( struct stack_frame *parent, break; } - debug_print( L"eval_form returning: ", DEBUG_EVAL ); + debug_print( L"eval_form ", DEBUG_EVAL ); + debug_print_object( form, DEBUG_EVAL ); + debug_print( L" returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -241,12 +243,6 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, return make_nlambda( frame->arg[0], compose_body( frame ) ); } -void log_binding( struct cons_pointer name, struct cons_pointer val ) { - debug_print( L"\n\tBinding ", DEBUG_LAMBDA ); - debug_dump_object( name, DEBUG_LAMBDA ); - debug_print( L" to ", DEBUG_LAMBDA ); - debug_dump_object( val, DEBUG_LAMBDA ); -} /** * Evaluate a lambda or nlambda expression. @@ -255,8 +251,10 @@ struct cons_pointer eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; +#ifdef DEBUG debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); debug_println( DEBUG_LAMBDA ); +#endif struct cons_pointer new_env = env; struct cons_pointer names = cell.payload.lambda.args; @@ -270,11 +268,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer val = frame->arg[i]; new_env = set( name, val, new_env ); - log_binding( name, val ); + debug_print_binding( name, val, false, DEBUG_BIND ); names = c_cdr( names ); } - inc_ref( new_env ); +// inc_ref( new_env ); /* \todo if there's more than `args_in_frame` arguments, bind those too. */ } else if ( symbolp( names ) ) { @@ -295,7 +293,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } new_env = set( names, vals, new_env ); - inc_ref( new_env ); +// inc_ref( new_env ); } while ( !nilp( body ) ) { @@ -311,7 +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 * 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 ); @@ -1156,6 +1154,46 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, return result; } +/** + * @brief evaluate a single cond clause; if the test part succeeds return a + * pair whose car is TRUE and whose cdr is the value of the action part + */ +struct cons_pointer eval_cond_clause( struct cons_pointer clause, + struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env) { + struct cons_pointer result = NIL; + +#ifdef DEBUG + debug_print( L"\n\tCond clause: ", DEBUG_EVAL ); + debug_print_object( clause, DEBUG_EVAL ); + debug_println( DEBUG_EVAL); +#endif + + if (consp(clause)) { + struct cons_pointer val = eval_form( frame, frame_pointer, c_car( clause ), + env ); + + if (!nilp( val)) { + result = make_cons( TRUE, c_progn( frame, frame_pointer, c_cdr( clause ), + env )); + +#ifdef DEBUG + debug_print(L"\n\t\tclause succeeded; returning: ", DEBUG_EVAL); + debug_print_object( result, DEBUG_EVAL); + debug_println( DEBUG_EVAL); + } else { + debug_print(L"\n\t\tclause failed.\n", DEBUG_EVAL); +#endif + } + } else { + result = throw_exception( c_string_to_lisp_string + ( L"Arguments to `cond` must be lists" ), + frame_pointer ); + } + + return result; +} + /** * Special form: conditional. Each `clause` is expected to be a list; if the first * item in such a list evaluates to non-NIL, the remaining items in that list @@ -1175,33 +1213,22 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer result = NIL; bool done = false; - for ( int i = 0; i < args_in_frame && !done; i++ ) { - struct cons_pointer clause_pointer = frame->arg[i]; - debug_print( L"Cond clause: ", DEBUG_EVAL ); - debug_dump_object( clause_pointer, DEBUG_EVAL ); + for ( int i = 0; (i < frame->args) && !done; i++ ) { + struct cons_pointer clause_pointer = fetch_arg( frame, i); - if ( consp( clause_pointer ) ) { - struct cons_space_object cell = pointer2cell( clause_pointer ); - result = - eval_form( frame, frame_pointer, c_car( clause_pointer ), - env ); + result = eval_cond_clause( clause_pointer, frame, frame_pointer, env); - if ( !nilp( result ) ) { - result = - c_progn( frame, frame_pointer, c_cdr( clause_pointer ), - env ); - done = true; - } - } else if ( nilp( clause_pointer ) ) { + if ( !nilp( result ) && truep( c_car( result)) ) { + result = c_cdr( result); done = true; - } else { - result = throw_exception( c_string_to_lisp_string - ( L"Arguments to `cond` must be lists" ), - frame_pointer ); - } + break; + } } - /* \todo if there are more than 8 clauses we need to continue into the - * remainder */ +#ifdef DEBUG + debug_print( L"\tCond returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL); +#endif return result; } @@ -1540,6 +1567,8 @@ struct cons_pointer lisp_list( struct stack_frame *frame, return result; } + + /** * Special form: evaluate a series of forms in an environment in which * these bindings are bound. @@ -1557,11 +1586,13 @@ struct cons_pointer lisp_let( struct stack_frame *frame, struct cons_pointer symbol = c_car( pair ); if ( symbolp( symbol ) ) { + struct cons_pointer val = eval_form( frame, frame_pointer, c_cdr( pair ), + bindings ); + + debug_print_binding( symbol, val, false, DEBUG_BIND); + bindings = - make_cons( make_cons - ( symbol, - eval_form( frame, frame_pointer, c_cdr( pair ), - bindings ) ), bindings ); + make_cons( make_cons( symbol, val ), bindings ); } else { result = @@ -1579,6 +1610,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); + } + return result; } @@ -1597,16 +1633,10 @@ struct cons_pointer lisp_and( struct stack_frame *frame, bool accumulator = true; struct cons_pointer result = frame->more; - for ( int a = 0; accumulator == true && a < args_in_frame; a++) { - accumulator = truthy( frame->arg[ a]); + for ( int a = 0; accumulator == true && a < frame->args; a++) { + accumulator = truthy( fetch_arg( frame, a)); } - - if ( accumulator && ! nilp( frame->more)) { - for ( struct cons_pointer rest = frame->more; accumulator == true && !nilp( rest); rest = c_cdr(rest)) { - accumulator = truthy( c_car( rest)); - } - } - +# return accumulator ? TRUE : NIL; } @@ -1624,14 +1654,8 @@ struct cons_pointer lisp_or( struct stack_frame *frame, bool accumulator = false; struct cons_pointer result = frame->more; - for ( int a = 0; accumulator == false && a < args_in_frame; a++) { - accumulator = truthy( frame->arg[ a]); - } - - if ( ! accumulator && ! nilp( frame->more)) { - for ( struct cons_pointer rest = frame->more; accumulator == false && !nilp( rest); rest = c_cdr(rest)) { - accumulator = truthy( c_car( rest)); - } + for ( int a = 0; accumulator == false && a < frame->args; a++) { + accumulator = truthy( fetch_arg( frame, a)); } return accumulator ? TRUE : NIL; diff --git a/unit-tests/add.sh b/unit-tests/add.sh index ca6f2a8..d4c1d26 100755 --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -86,7 +86,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - result=`echo "${result} + 1" | bc ` + result=`echo "${result} + 1" | bc` fi exit ${result}