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

Still not working, but I have increasing confidence I'm on the right track.

Browse source
This commit is contained in:
Simon Brooke 2026-02-28 18:09:48 +00:00
parent a1c377bc7c
commit bcb227a5f9
10 changed files with 110 additions and 108 deletions
Download patch file Download diff file Expand all files Collapse all files

26
src/arith/peano.c
View file

@ -296,7 +296,8 @@ struct cons_pointer add_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"+"), result =
throw_exception( c_string_to_lisp_symbol( L"+" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
@ -320,7 +321,8 @@ struct cons_pointer add_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"+"), result =
throw_exception( c_string_to_lisp_symbol( L"+" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
@ -334,7 +336,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
break; break;
default: default:
result = exceptionp( arg2 ) ? arg2 : result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_symbol( L"+"), throw_exception( c_string_to_lisp_symbol( L"+" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
@ -431,7 +433,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"*"), throw_exception( c_string_to_lisp_symbol( L"*" ),
make_cons make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number: " ), ( L"Cannot multiply: argument 2 is not a number: " ),
@ -458,7 +460,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"*"), throw_exception( c_string_to_lisp_symbol( L"*" ),
make_cons make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number" ), ( L"Cannot multiply: argument 2 is not a number" ),
@ -472,7 +474,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"*"), result = throw_exception( c_string_to_lisp_symbol( L"*" ),
make_cons( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( L"Cannot multiply: argument 1 is not a number" ), ( L"Cannot multiply: argument 1 is not a number" ),
c_type( arg1 ) ), c_type( arg1 ) ),
@ -626,7 +628,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"-"), result = throw_exception( c_string_to_lisp_symbol( L"-" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
@ -657,7 +659,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"-"), result = throw_exception( c_string_to_lisp_symbol( L"-" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
@ -669,7 +671,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); make_real( to_long_double( arg1 ) - to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"-"), result = throw_exception( c_string_to_lisp_symbol( L"-" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
@ -741,7 +743,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"/"), result = throw_exception( c_string_to_lisp_symbol( L"/" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
@ -772,7 +774,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"/"), result = throw_exception( c_string_to_lisp_symbol( L"/" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
@ -785,7 +787,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"/"), result = throw_exception( c_string_to_lisp_symbol( L"/" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );

13
src/arith/ratio.c
View file

@ -114,9 +114,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
cell1->payload.ratio.divisor ) ); cell1->payload.ratio.divisor ) );
r = make_ratio( dividend, divisor, true ); r = make_ratio( dividend, divisor, true );
} else { } else {
r = throw_exception( c_string_to_lisp_symbol( L"+"), r = throw_exception( c_string_to_lisp_symbol( L"+" ),
make_cons( make_cons( c_string_to_lisp_string
c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ), ( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1, make_cons( arg1,
make_cons( arg2, NIL ) ) ), make_cons( arg2, NIL ) ) ),
@ -156,7 +155,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"+"), throw_exception( c_string_to_lisp_symbol( L"+" ),
make_cons( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_integer_ratio" ), ( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg, make_cons( intarg,
@ -237,7 +236,7 @@ struct cons_pointer multiply_ratio_ratio( struct
release_integer( divisor ); release_integer( divisor );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"*"), throw_exception( c_string_to_lisp_symbol( L"*" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
NIL ); NIL );
@ -273,7 +272,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
release_integer( one ); release_integer( one );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"*"), throw_exception( c_string_to_lisp_symbol( L"*" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
NIL ); NIL );
@ -342,7 +341,7 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
} }
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"make_ratio"), throw_exception( c_string_to_lisp_symbol( L"make_ratio" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Dividend and divisor of a ratio must be integers" ), ( L"Dividend and divisor of a ratio must be integers" ),
NIL ); NIL );

5
src/init.c
View file

@ -293,6 +293,8 @@ int main( int argc, char *argv[] ) {
*/ */
bind_symbol_value( privileged_symbol_nil, NIL, true ); bind_symbol_value( privileged_symbol_nil, NIL, true );
bind_value( L"t", TRUE, true ); bind_value( L"t", TRUE, true );
bind_symbol_value( privileged_keyword_location, TRUE, true );
bind_symbol_value( privileged_keyword_payload, TRUE, true );
/* /*
* standard input, output, error and sink streams * standard input, output, error and sink streams
@ -413,7 +415,8 @@ int main( int argc, char *argv[] ) {
bind_function( L"keys", bind_function( L"keys",
L"`(keys store)`: Return a list of all keys in this `store`.", L"`(keys store)`: Return a list of all keys in this `store`.",
&lisp_keys ); &lisp_keys );
bind_function( L"list", L"`(list args...): Return a list of these `args`.", bind_function( L"list",
L"`(list args...)`: Return a list of these `args`.",
&lisp_list ); &lisp_list );
bind_function( L"mapcar", bind_function( L"mapcar",
L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.", L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.",

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.stream. ( pointer2cell( frame->arg[0] ).payload.
stream ), NIL ); stream.stream ), NIL );
} }
return result; return result;

10
src/io/read.c
View file

@ -167,7 +167,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
if ( url_feof( input ) ) { if ( url_feof( input ) ) {
result = result =
throw_exception( c_string_to_lisp_symbol( L"read"), throw_exception( c_string_to_lisp_symbol( L"read" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer ); ( L"End of file while reading" ), frame_pointer );
} else { } else {
@ -178,7 +178,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
/* skip all characters from semi-colon to the end of the line */ /* skip all characters from semi-colon to the end of the line */
break; break;
case EOF: case EOF:
result = throw_exception( c_string_to_lisp_symbol( L"read"), result = throw_exception( c_string_to_lisp_symbol( L"read" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"End of input while reading" ), ( L"End of input while reading" ),
frame_pointer ); frame_pointer );
@ -268,7 +268,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
result = read_symbol_or_key( input, SYMBOLTV, c ); result = read_symbol_or_key( input, SYMBOLTV, c );
} else { } else {
result = result =
throw_exception(c_string_to_lisp_symbol( L"read"), throw_exception( c_string_to_lisp_symbol( L"read" ),
make_cons( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( L"Unrecognised start of input character" ), ( L"Unrecognised start of input character" ),
make_string( c, NIL ) ), make_string( c, NIL ) ),
@ -316,7 +316,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
switch ( c ) { switch ( c ) {
case LPERIOD: case LPERIOD:
if ( seen_period || !nilp( dividend ) ) { if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_symbol( L"read"), return throw_exception( c_string_to_lisp_symbol( L"read" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Malformed number: too many periods" ), ( L"Malformed number: too many periods" ),
frame_pointer ); frame_pointer );
@ -328,7 +328,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
break; break;
case LSLASH: case LSLASH:
if ( seen_period || !nilp( dividend ) ) { if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_symbol( L"read"), return throw_exception( c_string_to_lisp_symbol( L"read" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ), ( L"Malformed number: dividend of rational must be integer" ),
frame_pointer ); frame_pointer );

8
src/memory/consspaceobject.c
View file

@ -39,8 +39,6 @@ struct cons_pointer privileged_keyword_location = NIL;
*/ */
struct cons_pointer privileged_keyword_payload = NIL; struct cons_pointer privileged_keyword_payload = NIL;
/** /**
* True if the value of the tag on the cell at this `pointer` is this `value`, * True if the value of the tag on the cell at this `pointer` is this `value`,
* or, if the tag of the cell is `VECP`, if the value of the tag of the * or, if the tag of the cell is `VECP`, if the value of the tag of the
@ -49,11 +47,11 @@ struct cons_pointer privileged_keyword_payload = NIL;
bool check_tag( struct cons_pointer pointer, uint32_t value ) { bool check_tag( struct cons_pointer pointer, uint32_t value ) {
bool result = false; bool result = false;
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
result = cell.tag.value == value; result = cell->tag.value == value;
if ( result == false ) { if ( result == false ) {
if ( cell.tag.value == VECTORPOINTTV ) { if ( cell->tag.value == VECTORPOINTTV ) {
struct vector_space_object *vec = pointer_to_vso( pointer ); struct vector_space_object *vec = pointer_to_vso( pointer );
if ( vec != NULL ) { if ( vec != NULL ) {

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 ).payload. pointer2cell( cell.payload.ratio.dividend ).
integer.value, payload.integer.value,
pointer2cell( cell.payload.ratio.divisor ).payload. pointer2cell( cell.payload.ratio.divisor ).
integer.value, cell.count ); payload.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 );

4
src/memory/stack.c
View file

@ -161,6 +161,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
env ); env );
frame->more = more; frame->more = more;
inc_ref( more ); inc_ref( more );
for ( ; !nilp( args ); args = c_cdr( args ) ) {
frame->args++;
}
} }
} }
debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );

21
src/ops/intern.c
View file

@ -311,16 +311,16 @@ struct cons_pointer interned( struct cons_pointer key,
map->payload.hashmap.buckets[bucket_no] ); map->payload.hashmap.buckets[bucket_no] );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"interned?"), throw_exception( c_string_to_lisp_symbol
make_cons ( L"interned?" ),
( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( L"Unexpected store type: " ), ( L"Unexpected store type: " ),
c_type( store ) ), NIL ); c_type( store ) ), NIL );
} }
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"interned?"), throw_exception( c_string_to_lisp_symbol( L"interned?" ),
make_cons make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Unexpected store type: " ), ( L"Unexpected store type: " ),
@ -329,7 +329,7 @@ struct cons_pointer interned( struct cons_pointer key,
} }
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"interned?"), throw_exception( c_string_to_lisp_symbol( L"interned?" ),
make_cons make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Unexpected key type: " ), c_type( key ) ), ( L"Unexpected key type: " ), c_type( key ) ),
@ -392,11 +392,12 @@ struct cons_pointer c_assoc( struct cons_pointer key,
result = hashmap_get( entry_ptr, key ); result = hashmap_get( entry_ptr, key );
break; break;
default: default:
throw_exception( c_string_to_lisp_symbol( L"assoc"), throw_exception( c_string_to_lisp_symbol
c_append ( L"assoc" ),
( c_string_to_lisp_string c_append( 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 // #ifdef DEBUG
@ -417,7 +418,7 @@ struct cons_pointer c_assoc( struct cons_pointer key,
// debug_print( L"`\n", DEBUG_BIND ); // debug_print( L"`\n", DEBUG_BIND );
// #endif // #endif
result = result =
throw_exception( c_string_to_lisp_symbol(L"assoc"), throw_exception( c_string_to_lisp_symbol( L"assoc" ),
c_append c_append
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Store is of unknown type: " ), ( L"Store is of unknown type: " ),

47
src/ops/lispops.c
View file

@ -337,22 +337,22 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
fn_pointer ) { fn_pointer ) {
struct cons_pointer result = r; struct cons_pointer result = r;
if ( exceptionp( result ) && (functionp( fn_pointer) || specialp(fn_pointer))) { if ( exceptionp( result )
&& ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) {
struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); struct cons_space_object *fn_cell = &pointer2cell( fn_pointer );
struct cons_pointer payload = struct cons_pointer payload =
pointer2cell( result ).payload.exception.payload; pointer2cell( result ).payload.exception.payload;
/* TODO: should name_key also be a privileged keyword? */ /* TODO: should name_key also be a privileged keyword? */
struct cons_pointer name_key = struct cons_pointer name_key = c_string_to_lisp_keyword( L"name" );
c_string_to_lisp_keyword( L"name" );
switch ( get_tag_value( payload ) ) { switch ( get_tag_value( payload ) ) {
case NILTV: case NILTV:
case CONSTV: case CONSTV:
case HASHTV: case HASHTV:
{ {
if ( nilp( c_assoc( privileged_keyword_location , if ( nilp( c_assoc( privileged_keyword_location,
payload ) )) { payload ) ) ) {
pointer2cell( result ).payload.exception.payload = pointer2cell( result ).payload.exception.payload =
set( privileged_keyword_location, set( privileged_keyword_location,
c_assoc( name_key, c_assoc( name_key,
@ -363,17 +363,16 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
break; break;
default: default:
pointer2cell( result ).payload.exception.payload = pointer2cell( result ).payload.exception.payload =
make_cons( make_cons( make_cons( privileged_keyword_location,
make_cons( privileged_keyword_location,
c_assoc( name_key, c_assoc( name_key,
fn_cell->payload.function.meta ) ), fn_cell->payload.function.
make_cons( meta ) ),
make_cons( privileged_keyword_payload, make_cons( make_cons
payload ) , ( privileged_keyword_payload,
NIL )); payload ), NIL ) );
} }
dec_ref( name_key); dec_ref( name_key );
} }
return result; return result;
@ -421,10 +420,7 @@ 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-> ( fn_cell->payload.function.executable ) )
payload.
function.
executable ) )
( next, ( next,
next_pointer, next_pointer,
env ), env ),
@ -498,10 +494,7 @@ 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-> ( fn_cell->payload.special.executable ) )
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 );
@ -1385,7 +1378,8 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
return exceptionp( message ) ? message : throw_exception( message, return exceptionp( message ) ? message : throw_exception( message,
frame->arg[1], frame->arg[1],
frame->previous ); frame->
previous );
} }
/** /**
@ -1569,13 +1563,14 @@ 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 ).payload. make_string_like_thing( ( pointer2cell( l1 ).
string.character ), l2, payload.string.character ),
l2,
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} else { } else {
return return
make_string_like_thing( ( pointer2cell( l1 ).payload. make_string_like_thing( ( pointer2cell( l1 ).
string.character ), payload.string.character ),
c_append( c_cdr( l1 ), l2 ), c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} }