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

16
src/debug.c
View file

@ -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
}

4
src/debug.h
View file

@ -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
View file

@ -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( ) {

6
src/memory/conspage.c
View file

@ -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.
*/

2
src/memory/conspage.h
View file

@ -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];

56
src/memory/stack.c
View file

@ -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 );
}
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 );

131
src/ops/intern.c
View file

@ -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;

134
src/ops/lispops.c
View file

@ -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;