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?
(lambda
(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
((nil? collection) nil)
((= item (car collection)) t)
(t (member? item (CDR collection))))))
(t (member? item (cdr collection))))))

5
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 );
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) {
result =
acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
result = acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
break;
} else {
struct cons_pointer new = make_integer( 0, NIL );
@ -262,7 +261,7 @@ struct cons_pointer add_integers( struct cons_pointer a,
is_first_cell = false;
}
}
debug_print( L"add_integers returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );

2
src/debug.h
View file

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

13
src/init.c
View file

@ -50,9 +50,9 @@ struct cons_pointer check_exception( struct cons_pointer pointer,
struct cons_pointer result = pointer;
if ( exceptionp( pointer ) ) {
struct cons_space_object * object = &pointer2cell( pointer);
struct cons_space_object *object = &pointer2cell( pointer );
result = NIL;
fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor );
URL_FILE *ustderr = file_to_url_file( stderr );
fwide( stderr, 1 );
@ -74,7 +74,8 @@ void maybe_bind_init_symbols( ) {
privileged_keyword_name = c_string_to_lisp_keyword( L"name" );
}
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 ) ) {
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_name, n ),
make_cons( make_cons
( privileged_keyword_documentation, d ),
( privileged_keyword_documentation,
d ),
NIL ) ) );
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_name, n ),
make_cons( make_cons
( privileged_keyword_documentation, d ),
( privileged_keyword_documentation,
d ),
NIL ) ) );
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] ) ) {
result =
make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload.
stream.stream ), NIL );
( pointer2cell( frame->arg[0] ).payload.stream.
stream ), NIL );
}
return result;

6
src/memory/conspage.c
View file

@ -67,7 +67,7 @@ struct cons_page *conspages[NCONSPAGES];
void make_cons_page( ) {
struct cons_page *result = NULL;
if ( initialised_cons_pages < NCONSPAGES) {
if ( initialised_cons_pages < NCONSPAGES ) {
result = malloc( sizeof( struct cons_page ) );
}
@ -121,7 +121,9 @@ void make_cons_page( ) {
initialised_cons_pages++;
} else {
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 );
}
}

8
src/memory/dump.c
View file

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

9
src/memory/stack.c
View file

@ -66,7 +66,8 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
// debug_printf( DEBUG_STACK,
// L"\nget_stack_frame: all good, returning %p\n", result );
} 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;
@ -133,8 +134,8 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
if ( stack_limit == 0 || stack_limit > depth ) {
result = in_make_empty_frame( previous, depth );
} else {
debug_printf( DEBUG_STACK,
L"WARNING: Exceeded stack limit of %d\n", stack_limit);
debug_printf( DEBUG_STACK,
L"WARNING: Exceeded stack limit of %d\n", stack_limit );
result =
make_exception( c_string_to_lisp_string
( 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 ",
frame->args );
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 );
}

22
src/ops/intern.c
View file

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

2
src/ops/intern.h
View file

@ -76,6 +76,6 @@ struct cons_pointer intern( struct cons_pointer key,
struct cons_pointer environment );
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer store );
struct cons_pointer store );
#endif

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