Fixed runaway recursion in cond. However, let is still segfaulting, and member
does not work correctly.
This commit is contained in:
Simon Brooke
parent
d34d891211
commit
8c63272214
12 changed files with 358 additions and 156 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
;; 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)
|
||||
|
||||
;; 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))))))
|
||||
|
||||
(set! doc documentation)
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
||||
(member (type member) '("LMDA" "NLMD"))
|
||||
|
|
|
|||
16
src/debug.c
16
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
|
||||
}
|
||||
|
|
@ -8,8 +8,11 @@
|
|||
*/
|
||||
|
||||
#include <ctype.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdio.h>
|
||||
|
||||
#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
|
||||
|
|
|
|||
20
src/init.c
20
src/init.c
|
|
@ -20,23 +20,22 @@
|
|||
/* libcurl, used for io */
|
||||
#include <curl/curl.h>
|
||||
|
||||
#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( ) {
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
*/
|
||||
|
|
|
|||
|
|
@ -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];
|
||||
|
|
|
|||
|
|
@ -17,14 +17,14 @@
|
|||
|
||||
#include <stdlib.h>
|
||||
|
||||
#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 );
|
||||
}
|
||||
|
||||
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 );
|
||||
|
|
|
|||
|
|
@ -329,15 +329,18 @@ struct cons_pointer c_assoc( struct cons_pointer key,
|
|||
struct cons_pointer store ) {
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
debug_print( L"c_assoc; key is `", DEBUG_BIND );
|
||||
debug_print_object( key, DEBUG_BIND );
|
||||
debug_print( L"`\n", DEBUG_BIND );
|
||||
|
||||
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
|
||||
|
||||
struct cons_pointer entry_ptr = c_car( next );
|
||||
struct cons_space_object entry = pointer2cell( entry_ptr );
|
||||
|
||||
|
|
@ -356,24 +359,31 @@ struct cons_pointer c_assoc( struct cons_pointer key,
|
|||
( 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 ) ) {
|
||||
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 );
|
||||
// #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 );
|
||||
}
|
||||
|
||||
debug_print( L"c_assoc returning ", DEBUG_BIND );
|
||||
debug_print_object( result, DEBUG_BIND );
|
||||
debug_println( DEBUG_BIND );
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
|
@ -415,21 +425,12 @@ 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 ) ) {
|
||||
|
|
@ -437,14 +438,9 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
|
|||
} 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;
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
if ( !nilp( result ) && truep( c_car( result)) ) {
|
||||
result = c_cdr( result);
|
||||
done = true;
|
||||
}
|
||||
} else if ( nilp( clause_pointer ) ) {
|
||||
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;
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue