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

'Fixed' issue #8; but done so by introducing a goto. Not entirely happy about this.

Browse source
This commit is contained in:
Simon Brooke 2026-03-18 21:35:34 +00:00
parent dc5cac0bd8
commit a20c956288
11 changed files with 63 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

4
lisp/member.lisp
View file

@ -11,8 +11,8 @@
(set! member? (set! member?
(lambda (lambda
(item collection) (item collection)
(print (list "in member?: " 'item item 'collection collection) *log*)(println *log*) ;; (print (list "in member?: " 'item item 'collection collection) *log*)(println *log*)
(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))))))

3
src/arith/integer.c
View file

@ -245,8 +245,7 @@ struct cons_pointer add_integers( struct cons_pointer a,
debug_print( L"\n", DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH );
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) { if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) {
result = result = acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
break; break;
} else { } else {
struct cons_pointer new = make_integer( 0, NIL ); struct cons_pointer new = make_integer( 0, NIL );

2
src/debug.h
View file

@ -84,7 +84,7 @@
* *
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
*/ */
#define DEBUG_EQUAL 512 #define DEBUG_EQUAL 512
extern int verbosity; extern int verbosity;

11
src/init.c
View file

@ -50,7 +50,7 @@ struct cons_pointer check_exception( struct cons_pointer pointer,
struct cons_pointer result = pointer; struct cons_pointer result = pointer;
if ( exceptionp( pointer ) ) { if ( exceptionp( pointer ) ) {
struct cons_space_object * object = &pointer2cell( pointer); struct cons_space_object *object = &pointer2cell( pointer );
result = NIL; result = NIL;
fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor ); fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor );
@ -74,7 +74,8 @@ void maybe_bind_init_symbols( ) {
privileged_keyword_name = c_string_to_lisp_keyword( L"name" ); privileged_keyword_name = c_string_to_lisp_keyword( L"name" );
} }
if ( nilp( privileged_keyword_primitive ) ) { if ( nilp( privileged_keyword_primitive ) ) {
privileged_keyword_primitive = c_string_to_lisp_keyword( L"primitive" ); privileged_keyword_primitive =
c_string_to_lisp_keyword( L"primitive" );
} }
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" );
@ -122,7 +123,8 @@ struct cons_pointer bind_function( wchar_t *name,
make_cons( make_cons( privileged_keyword_primitive, TRUE ), make_cons( make_cons( privileged_keyword_primitive, TRUE ),
make_cons( make_cons( privileged_keyword_name, n ), make_cons( make_cons( privileged_keyword_name, n ),
make_cons( make_cons make_cons( make_cons
( privileged_keyword_documentation, d ), ( privileged_keyword_documentation,
d ),
NIL ) ) ); NIL ) ) );
struct cons_pointer r = struct cons_pointer r =
@ -151,7 +153,8 @@ struct cons_pointer bind_special( wchar_t *name,
make_cons( make_cons( privileged_keyword_primitive, TRUE ), make_cons( make_cons( privileged_keyword_primitive, TRUE ),
make_cons( make_cons( privileged_keyword_name, n ), make_cons( make_cons( privileged_keyword_name, n ),
make_cons( make_cons make_cons( make_cons
( privileged_keyword_documentation, d ), ( privileged_keyword_documentation,
d ),
NIL ) ) ); NIL ) ) );
struct cons_pointer r = struct cons_pointer r =

4
src/io/io.c
View file

@ -508,8 +508,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( readp( frame->arg[0] ) ) { if ( readp( frame->arg[0] ) ) {
result = result =
make_string( url_fgetwc make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload. ( pointer2cell( frame->arg[0] ).payload.stream.
stream.stream ), NIL ); stream ), NIL );
} }
return result; return result;

6
src/memory/conspage.c
View file

@ -67,7 +67,7 @@ struct cons_page *conspages[NCONSPAGES];
void make_cons_page( ) { void make_cons_page( ) {
struct cons_page *result = NULL; struct cons_page *result = NULL;
if ( initialised_cons_pages < NCONSPAGES) { if ( initialised_cons_pages < NCONSPAGES ) {
result = malloc( sizeof( struct cons_page ) ); result = malloc( sizeof( struct cons_page ) );
} }
@ -121,7 +121,9 @@ void make_cons_page( ) {
initialised_cons_pages++; initialised_cons_pages++;
} else { } else {
fwide( stderr, 1 ); fwide( stderr, 1 );
fwprintf( stderr, L"FATAL: Failed to allocate memory for cons page %d\n", initialised_cons_pages ); fwprintf( stderr,
L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages );
exit( 1 ); exit( 1 );
} }
} }

8
src/memory/dump.c
View file

@ -114,10 +114,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
case RATIOTV: case RATIOTV:
url_fwprintf( output, url_fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n", L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ). pointer2cell( cell.payload.ratio.dividend ).payload.
payload.integer.value, integer.value,
pointer2cell( cell.payload.ratio.divisor ). pointer2cell( cell.payload.ratio.divisor ).payload.
payload.integer.value, cell.count ); integer.value, cell.count );
break; break;
case READTV: case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output ); url_fputws( L"\t\tInput stream; metadata: ", output );

7
src/memory/stack.c
View file

@ -66,7 +66,8 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
// debug_printf( DEBUG_STACK, // debug_printf( DEBUG_STACK,
// L"\nget_stack_frame: all good, returning %p\n", result ); // L"\nget_stack_frame: all good, returning %p\n", result );
} else { } else {
debug_print( L"\nget_stack_frame: fail, returning NULL\n", DEBUG_STACK ); debug_print( L"\nget_stack_frame: fail, returning NULL\n",
DEBUG_STACK );
} }
return result; return result;
@ -134,7 +135,7 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
result = in_make_empty_frame( previous, depth ); result = in_make_empty_frame( previous, depth );
} else { } else {
debug_printf( DEBUG_STACK, debug_printf( DEBUG_STACK,
L"WARNING: Exceeded stack limit of %d\n", stack_limit); L"WARNING: Exceeded stack limit of %d\n", stack_limit );
result = result =
make_exception( c_string_to_lisp_string make_exception( c_string_to_lisp_string
( L"Stack limit exceeded." ), previous ); ( L"Stack limit exceeded." ), previous );
@ -187,7 +188,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
debug_printf( DEBUG_STACK, L"\tSetting argument %d to ", debug_printf( DEBUG_STACK, L"\tSetting argument %d to ",
frame->args ); frame->args );
debug_print_object( cell.payload.cons.car, DEBUG_STACK ); debug_print_object( cell.payload.cons.car, DEBUG_STACK );
debug_print(L"\n", DEBUG_STACK); debug_print( L"\n", DEBUG_STACK );
set_reg( frame, frame->args, val ); set_reg( frame, frame->args, val );
} }

16
src/ops/intern.c
View file

@ -338,13 +338,11 @@ struct cons_pointer search_store( struct cons_pointer key,
result = result =
return_key ? c_car( entry_ptr ) return_key ? c_car( entry_ptr )
: c_cdr( entry_ptr ); : c_cdr( entry_ptr );
break; goto found;
} }
break; break;
case HASHTV: case HASHTV:
case NAMESPACETV: case NAMESPACETV:
// TODO: I think this should be impossible, and we should maybe
// throw an exception.
result = result =
hashmap_get( entry_ptr, key, hashmap_get( entry_ptr, key,
return_key ); return_key );
@ -414,6 +412,8 @@ struct cons_pointer search_store( struct cons_pointer key,
c_type( key ) ), NIL ); c_type( key ) ), NIL );
} }
found:
debug_print( L"search-store: returning `", DEBUG_BIND ); debug_print( L"search-store: returning `", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND ); debug_print_object( result, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND ); debug_print( L"`\n", DEBUG_BIND );
@ -438,17 +438,17 @@ struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( store ) ) { if ( consp( store ) ) {
for ( struct cons_pointer pair = c_car( store ); eq( result, NIL) && !nilp( pair ); for ( struct cons_pointer pair = c_car( store );
pair = c_car( store ) ) { eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) {
if ( consp( pair ) ) { if ( consp( pair ) ) {
if ( equal( c_car( pair), key)) { if ( equal( c_car( pair ), key ) ) {
// yes, this should be `eq`, but if symbols are correctly // yes, this should be `eq`, but if symbols are correctly
// interned this will work efficiently, and if not it will // interned this will work efficiently, and if not it will
// still work. // still work.
result = TRUE; result = TRUE;
} }
} else if ( hashmapp( pair ) ) { } else if ( hashmapp( pair ) ) {
result=internedp( key, pair); result = internedp( key, pair );
} }
store = c_cdr( store ); store = c_cdr( store );
@ -459,7 +459,7 @@ struct cons_pointer internedp( struct cons_pointer key,
for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) { for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
for ( struct cons_pointer c = map->payload.hashmap.buckets[i]; for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
!nilp( c ); c = c_cdr( c ) ) { !nilp( c ); c = c_cdr( c ) ) {
result = internedp( key, c); result = internedp( key, c );
} }
} }
} }

35
src/ops/lispops.c
View file

@ -363,8 +363,8 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
pointer2cell( result ).payload.exception.payload = pointer2cell( result ).payload.exception.payload =
make_cons( make_cons( privileged_keyword_location, make_cons( make_cons( privileged_keyword_location,
c_assoc( privileged_keyword_name, c_assoc( privileged_keyword_name,
fn_cell->payload.function. fn_cell->payload.
meta ) ), function.meta ) ),
make_cons( make_cons make_cons( make_cons
( privileged_keyword_payload, ( privileged_keyword_payload,
payload ), NIL ) ); payload ), NIL ) );
@ -416,7 +416,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
get_stack_frame( next_pointer ); get_stack_frame( next_pointer );
result = maybe_fixup_exception_location( ( * result = maybe_fixup_exception_location( ( *
( fn_cell->payload.function.executable ) ) ( fn_cell->
payload.
function.
executable ) )
( next, ( next,
next_pointer, next_pointer,
env ), env ),
@ -490,7 +493,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer; result = next_pointer;
} else { } else {
result = maybe_fixup_exception_location( ( * result = maybe_fixup_exception_location( ( *
( fn_cell->payload.special.executable ) ) ( fn_cell->
payload.
special.
executable ) )
( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer ); ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer );
debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL );
@ -923,9 +929,9 @@ struct cons_pointer c_keys( struct cons_pointer store ) {
for ( struct cons_pointer pair = c_car( store ); !nilp( pair ); for ( struct cons_pointer pair = c_car( store ); !nilp( pair );
pair = c_car( store ) ) { pair = c_car( store ) ) {
if ( consp( pair ) ) { if ( consp( pair ) ) {
result = make_cons( c_car( pair), result); result = make_cons( c_car( pair ), result );
} else if ( hashmapp( pair ) ) { } else if ( hashmapp( pair ) ) {
result=c_append( hashmap_keys( pair), result); result = c_append( hashmap_keys( pair ), result );
} }
store = c_cdr( store ); store = c_cdr( store );
@ -1270,14 +1276,14 @@ struct cons_pointer eval_cond_clause( struct cons_pointer clause,
env ) ); env ) );
#ifdef DEBUG #ifdef DEBUG
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL); debug_print( L"\n\t\tCond clause ", DEBUG_EVAL );
debug_print_object( clause, DEBUG_EVAL); debug_print_object( clause, DEBUG_EVAL );
debug_print( L" succeeded; returning: ", DEBUG_EVAL ); debug_print( L" succeeded; returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL ); debug_println( DEBUG_EVAL );
} else { } else {
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL); debug_print( L"\n\t\tCond clause ", DEBUG_EVAL );
debug_print_object( clause, DEBUG_EVAL); debug_print_object( clause, DEBUG_EVAL );
debug_print( L" failed.\n", DEBUG_EVAL ); debug_print( L" failed.\n", DEBUG_EVAL );
#endif #endif
} }
@ -1626,14 +1632,13 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
if ( nilp( c_cdr( l1 ) ) ) { if ( nilp( c_cdr( l1 ) ) ) {
return return
make_string_like_thing( ( pointer2cell( l1 ). make_string_like_thing( ( pointer2cell( l1 ).payload.
payload.string.character ), string.character ), l2,
l2,
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} else { } else {
return return
make_string_like_thing( ( pointer2cell( l1 ). make_string_like_thing( ( pointer2cell( l1 ).payload.
payload.string.character ), string.character ),
c_append( c_cdr( l1 ), l2 ), c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} }