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

Fixed runaway recursion in cond. However, let is still segfaulting, and member

Browse source 
does not work correctly.
This commit is contained in:
Simon Brooke 2026-02-25 11:17:40 +00:00
parent d34d891211
commit 8c63272214
12 changed files with 358 additions and 156 deletions
Download patch file Download diff file Expand all files Collapse all files

105
docs/state-of-play.md
View file

@ -1,5 +1,110 @@
# State of Play # 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 ## 20260220
### State of the build ### State of the build

27
lisp/documentation.lisp
View file

@ -1,9 +1,20 @@
(set! documentation (lambda (object) ;; This version segfaults, I think due to a bug in `let`?
(cond ((= (type object) "LMDA") ;; (set! documentation (lambda (object)
(let (d (nth 3 (source object))) ;; (cond ((= (type object) "LMDA")
(cond ((string? d) d) ;; (let ((d . (nth 3 (source object))))
(t (source object))))) ;; (cond ((string? d) d)
((member (type object) '("FUNC" "SPFM")) ;; (t (source object)))))
(:documentation (meta 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))))))

9
lisp/member.lisp
View file

@ -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 (set! member (lambda
(item collection) (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)
(t (member item (cdr collection)))))) (t (member item (cdr collection))))))
(member (type member) '("LMDA" "NLMD"))

16
src/debug.c
View file

@ -143,3 +143,19 @@ void debug_dump_object( struct cons_pointer pointer, int level ) {
} }
#endif #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
}

4
src/debug.h
View file

@ -8,8 +8,11 @@
*/ */
#include <ctype.h> #include <ctype.h>
#include <stdbool.h>
#include <stdio.h> #include <stdio.h>
#include "memory/consspaceobject.h"
#ifndef __debug_print_h #ifndef __debug_print_h
#define __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_printf( int level, wchar_t *format, ... );
void debug_print_object( struct cons_pointer pointer, int level ); void debug_print_object( struct cons_pointer pointer, int level );
void debug_dump_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 #endif

20
src/init.c
View file

@ -20,23 +20,22 @@
/* libcurl, used for io */ /* libcurl, used for io */
#include <curl/curl.h> #include <curl/curl.h>
#include "arith/peano.h"
#include "arith/ratio.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/conspage.h"
#include "memory/consspaceobject.h" #include "memory/consspaceobject.h"
#include "memory/stack.h"
#include "debug.h"
#include "memory/hashmap.h" #include "memory/hashmap.h"
#include "memory/stack.h"
#include "ops/intern.h" #include "ops/intern.h"
#include "io/io.h"
#include "io/fopen.h"
#include "ops/lispops.h" #include "ops/lispops.h"
#include "ops/meta.h" #include "ops/meta.h"
#include "arith/peano.h"
#include "io/print.h"
#include "repl.h" #include "repl.h"
#include "io/fopen.h"
#include "time/psse_time.h" #include "time/psse_time.h"
#include "version.h"
/** /**
* @brief If `pointer` is an exception, display that exception to stderr, * @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 ) ) { 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" );
} }
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( ) { void free_init_symbols( ) {

6
src/memory/conspage.c
View file

@ -45,6 +45,12 @@ int initialised_cons_pages = 0;
*/ */
struct cons_pointer freelist = NIL; 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. * An array of pointers to cons pages.
*/ */

2
src/memory/conspage.h
View file

@ -49,6 +49,8 @@ struct cons_page {
struct cons_space_object cell[CONSPAGESIZE]; struct cons_space_object cell[CONSPAGESIZE];
}; };
extern struct cons_pointer privileged_string_memory_exhausted;
extern struct cons_pointer freelist; extern struct cons_pointer freelist;
extern struct cons_page *conspages[NCONSPAGES]; extern struct cons_page *conspages[NCONSPAGES];

56
src/memory/stack.c
View file

@ -17,14 +17,14 @@
#include <stdlib.h> #include <stdlib.h>
#include "memory/consspaceobject.h"
#include "memory/conspage.h"
#include "debug.h" #include "debug.h"
#include "memory/dump.h"
#include "ops/lispops.h"
#include "io/print.h" #include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/dump.h"
#include "memory/stack.h" #include "memory/stack.h"
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
#include "ops/lispops.h"
/** /**
* set a register in a stack frame. Alwaye use this to do so, * 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 ) ) { if ( nilp( result ) ) {
/* i.e. out of memory */ /* i.e. out of memory */
result = result =
make_exception( c_string_to_lisp_string( L"Memory exhausted." ), make_exception( privileged_string_memory_exhausted,
previous ); previous );
} else { } else {
struct stack_frame *frame = get_stack_frame( result ); 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; frame->more = more;
inc_ref( 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; return result;
} }
@ -235,6 +234,40 @@ void free_stack_frame( struct stack_frame *frame ) {
debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC ); 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 * 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 ) { if ( frame != NULL ) {
url_fwprintf( output, L"Stack frame with %d arguments:\n", url_fwprintf( output, L"Stack frame with %d arguments:\n",
frame->args ); frame->args );
dump_frame_context( output, frame_pointer, 4);
for ( int arg = 0; arg < frame->args; arg++ ) { for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] ); struct cons_space_object cell = pointer2cell( frame->arg[arg] );
url_fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", url_fwprintf( output, L"Arg %d:\t%4.4s\tcount: %10u\tvalue: ",
arg, cell.tag.bytes[0], cell.tag.bytes[1], arg, cell.tag.bytes, cell.count );
cell.tag.bytes[2], cell.tag.bytes[3], cell.count );
print( output, frame->arg[arg] ); print( output, frame->arg[arg] );
url_fputws( L"\n", output ); url_fputws( L"\n", output );

129
src/ops/intern.c
View file

@ -329,52 +329,62 @@ struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store ) { struct cons_pointer store ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
debug_print( L"c_assoc; key is `", DEBUG_BIND ); if (!nilp( key)) {
debug_print_object( key, DEBUG_BIND ); if ( consp( store ) ) {
debug_print( L"`\n", DEBUG_BIND ); 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
if ( consp( store ) ) { struct cons_pointer entry_ptr = c_car( next );
for ( struct cons_pointer next = store; struct cons_space_object entry = pointer2cell( entry_ptr );
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 ) { switch ( entry.tag.value ) {
case CONSTV: case CONSTV:
if ( equal( key, entry.payload.cons.car ) ) { if ( equal( key, entry.payload.cons.car ) ) {
result = entry.payload.cons.cdr; result = entry.payload.cons.cdr;
} }
break; break;
case VECTORPOINTTV: case VECTORPOINTTV:
result = hashmap_get( entry_ptr, key ); result = hashmap_get( entry_ptr, key );
break; break;
default: default:
throw_exception( c_append throw_exception( c_append
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Store entry is of unknown type: " ), ( L"Store entry is of unknown type: " ),
c_type( entry_ptr ) ), NIL ); 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; return result;
} }
@ -415,21 +425,12 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
#ifdef DEBUG #ifdef DEBUG
debug_print( L"set: binding `", DEBUG_BIND ); bool deep = vectorpointp( store);
debug_print_object( key, DEBUG_BIND ); debug_print_binding( key, value, deep, 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 );
debug_printf( DEBUG_BIND, L"set: store is %4.4s", if (deep) {
pointer2cell(store).tag.bytes ); debug_printf( DEBUG_BIND, L"\t-> %4.4s\n",
if (strncmp(pointer2cell(store).tag.bytes, VECTORPOINTTAG, TAGLENGTH) == 0) {
debug_printf( DEBUG_BIND, L" -> %4.4s\n",
pointer2cell(store).payload.vectorp.tag.bytes ); pointer2cell(store).payload.vectorp.tag.bytes );
} else {
debug_println( DEBUG_BIND);
} }
#endif #endif
if ( nilp( value ) ) { if ( nilp( value ) ) {
@ -437,14 +438,9 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
} else if ( nilp( store ) || consp( store ) ) { } else if ( nilp( store ) || consp( store ) ) {
result = make_cons( make_cons( key, value ), store ); result = make_cons( make_cons( key, value ), store );
} else if ( hashmapp( store ) ) { } else if ( hashmapp( store ) ) {
debug_print( L"set: storing in hashmap\n", DEBUG_BIND );
result = hashmap_put( store, key, value ); 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; return result;
} }
@ -457,18 +453,13 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) {
struct cons_pointer old = oblist; 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 ); oblist = set( key, value, oblist );
if ( consp( oblist ) ) { // The oblist is not now an assoc list, and I don't think it will be again.
inc_ref( oblist ); // if ( consp( oblist ) ) {
dec_ref( old ); // inc_ref( oblist );
} // dec_ref( old );
// }
debug_print( L"deep_bind returning ", DEBUG_BIND ); debug_print( L"deep_bind returning ", DEBUG_BIND );
debug_print_object( key, 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 * 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 * return that canonical copy. If there is currently no such binding, create one
* with the value NIL. * with the value TRUE.
*/ */
struct cons_pointer struct cons_pointer
intern( struct cons_pointer key, struct cons_pointer environment ) { 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 * not currently bound
*/ */
result = set( key, NIL, environment ); result = set( key, TRUE, environment );
} }
return result; return result;

132
src/ops/lispops.c
View file

@ -109,7 +109,9 @@ struct cons_pointer eval_form( struct stack_frame *parent,
break; 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_print_object( result, DEBUG_EVAL );
debug_println( 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 ) ); 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. * Evaluate a lambda or nlambda expression.
@ -255,8 +251,10 @@ struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame, eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
#ifdef DEBUG
debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); debug_print( L"eval_lambda called\n", DEBUG_LAMBDA );
debug_println( DEBUG_LAMBDA ); debug_println( DEBUG_LAMBDA );
#endif
struct cons_pointer new_env = env; struct cons_pointer new_env = env;
struct cons_pointer names = cell.payload.lambda.args; 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]; struct cons_pointer val = frame->arg[i];
new_env = set( name, val, new_env ); new_env = set( name, val, new_env );
log_binding( name, val ); debug_print_binding( name, val, false, DEBUG_BIND );
names = c_cdr( names ); 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. */ /* \todo if there's more than `args_in_frame` arguments, bind those too. */
} else if ( symbolp( names ) ) { } 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 ); new_env = set( names, vals, new_env );
inc_ref( new_env ); // inc_ref( new_env );
} }
while ( !nilp( body ) ) { 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 /* 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 ) ){ 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 );
@ -1156,6 +1154,46 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
return result; 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 * 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 * 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; struct cons_pointer result = NIL;
bool done = false; bool done = false;
for ( int i = 0; i < args_in_frame && !done; i++ ) { for ( int i = 0; (i < frame->args) && !done; i++ ) {
struct cons_pointer clause_pointer = frame->arg[i]; struct cons_pointer clause_pointer = fetch_arg( frame, i);
debug_print( L"Cond clause: ", DEBUG_EVAL );
debug_dump_object( clause_pointer, DEBUG_EVAL );
if ( consp( clause_pointer ) ) { result = eval_cond_clause( clause_pointer, frame, frame_pointer, env);
struct cons_space_object cell = pointer2cell( clause_pointer );
result =
eval_form( frame, frame_pointer, c_car( clause_pointer ),
env );
if ( !nilp( result ) ) { if ( !nilp( result ) && truep( c_car( result)) ) {
result = result = c_cdr( result);
c_progn( frame, frame_pointer, c_cdr( clause_pointer ),
env );
done = true;
}
} else if ( nilp( clause_pointer ) ) {
done = true; done = true;
} else { break;
result = throw_exception( c_string_to_lisp_string
( L"Arguments to `cond` must be lists" ),
frame_pointer );
} }
} }
/* \todo if there are more than 8 clauses we need to continue into the #ifdef DEBUG
* remainder */ debug_print( L"\tCond returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL);
#endif
return result; return result;
} }
@ -1540,6 +1567,8 @@ struct cons_pointer lisp_list( struct stack_frame *frame,
return result; return result;
} }
/** /**
* Special form: evaluate a series of forms in an environment in which * Special form: evaluate a series of forms in an environment in which
* these bindings are bound. * these bindings are bound.
@ -1557,11 +1586,13 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
struct cons_pointer symbol = c_car( pair ); struct cons_pointer symbol = c_car( pair );
if ( symbolp( symbol ) ) { 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 = bindings =
make_cons( make_cons make_cons( make_cons( symbol, val ), bindings );
( symbol,
eval_form( frame, frame_pointer, c_cdr( pair ),
bindings ) ), bindings );
} else { } else {
result = result =
@ -1579,6 +1610,11 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
bindings ); 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; return result;
} }
@ -1597,16 +1633,10 @@ struct cons_pointer lisp_and( struct stack_frame *frame,
bool accumulator = true; bool accumulator = true;
struct cons_pointer result = frame->more; struct cons_pointer result = frame->more;
for ( int a = 0; accumulator == true && a < args_in_frame; a++) { for ( int a = 0; accumulator == true && a < frame->args; a++) {
accumulator = truthy( frame->arg[ 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; return accumulator ? TRUE : NIL;
} }
@ -1624,14 +1654,8 @@ struct cons_pointer lisp_or( struct stack_frame *frame,
bool accumulator = false; bool accumulator = false;
struct cons_pointer result = frame->more; struct cons_pointer result = frame->more;
for ( int a = 0; accumulator == false && a < args_in_frame; a++) { for ( int a = 0; accumulator == false && a < frame->args; a++) {
accumulator = truthy( frame->arg[ a]); accumulator = truthy( fetch_arg( frame, 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));
}
} }
return accumulator ? TRUE : NIL; return accumulator ? TRUE : NIL;

2
unit-tests/add.sh
View file

@ -86,7 +86,7 @@ then
echo "OK" echo "OK"
else else
echo "Fail: expected '${expected}', got '${actual}'" echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc ` result=`echo "${result} + 1" | bc`
fi fi
exit ${result} exit ${result}