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

Compare commits

base: simon:72548097cf9362e0c1f29559e81403267940a8c0
Branches Tags
simon:master
simon:develop
simon:intern-rewrite
simon:feature-2
simon:feature/all-integers-are-bignums
simon:release/0.0.6
simon:release_0.0.5
..
compare: simon:a1c377bc7c7ded8b175a346e9028212db418bc51
Branches Tags
simon:develop
simon:master
simon:intern-rewrite
simon:feature-2
simon:feature/all-integers-are-bignums
simon:release/0.0.6
simon:release_0.0.5

2 commits
72548097cf ... a1c377bc7c

Author SHA1 Message Date
Simon Brooke
a1c377bc7c Established intern bug is in getting, not setting; improved exceptions. 2026-02-28 15:15:42 +00:00
Simon Brooke
54f6f023c6 More debugging output. Getting desperate! 2026-02-28 12:24:59 +00:00
11 changed files with 272 additions and 131 deletions
Download patch file Download diff file Expand all files Collapse all files

36
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_string result = throw_exception( c_string_to_lisp_symbol( L"+"),
c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -319,7 +320,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_string result = throw_exception( c_string_to_lisp_symbol( L"+"),
c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -332,7 +334,8 @@ 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_string throw_exception( c_string_to_lisp_symbol( L"+"),
c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
} }
@ -428,7 +431,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = result =
throw_exception( make_cons throw_exception( c_string_to_lisp_symbol( L"*"),
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: " ),
c_type( arg2 ) ), c_type( arg2 ) ),
@ -454,7 +458,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = result =
throw_exception( make_cons throw_exception( c_string_to_lisp_symbol( L"*"),
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" ),
c_type( arg2 ) ), c_type( arg2 ) ),
@ -467,7 +472,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( make_cons( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_symbol( L"*"),
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 ) ),
frame_pointer ); frame_pointer );
@ -620,7 +626,8 @@ 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_string result = throw_exception( c_string_to_lisp_symbol( L"-"),
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -650,7 +657,8 @@ 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_string result = throw_exception( c_string_to_lisp_symbol( L"-"),
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -661,7 +669,8 @@ 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_string result = throw_exception( c_string_to_lisp_symbol( L"-"),
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -732,7 +741,8 @@ 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_string result = throw_exception( c_string_to_lisp_symbol( L"/"),
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -762,7 +772,8 @@ 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_string result = throw_exception( c_string_to_lisp_symbol( L"/"),
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -774,7 +785,8 @@ 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_string result = throw_exception( c_string_to_lisp_symbol( L"/"),
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;

16
src/arith/ratio.c
View file

@ -114,7 +114,9 @@ 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( make_cons( c_string_to_lisp_string r = throw_exception( c_string_to_lisp_symbol( L"+"),
make_cons(
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 ) ) ),
@ -154,7 +156,8 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = result =
throw_exception( make_cons( c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( L"+"),
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,
make_cons( ratarg, make_cons( ratarg,
@ -234,7 +237,8 @@ struct cons_pointer multiply_ratio_ratio( struct
release_integer( divisor ); release_integer( divisor );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( L"*"),
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 );
} }
@ -269,7 +273,8 @@ 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_string throw_exception( c_string_to_lisp_symbol( L"*"),
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 );
} }
@ -337,7 +342,8 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
} }
} else { } else {
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( L"make_ratio"),
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 );
} }

8
src/init.c
View file

@ -84,12 +84,18 @@ void maybe_bind_init_symbols( ) {
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" );
} }
if ( nilp( privileged_string_memory_exhausted ) ) {
// we can't make this string when we need it, because memory is then // we can't make this string when we need it, because memory is then
// exhausted! // exhausted!
if ( nilp( privileged_string_memory_exhausted ) ) {
privileged_string_memory_exhausted = privileged_string_memory_exhausted =
c_string_to_lisp_string( L"Memory exhausted." ); c_string_to_lisp_string( L"Memory exhausted." );
} }
if ( nilp( privileged_keyword_location ) ) {
privileged_keyword_location = c_string_to_lisp_keyword( L"location" );
}
if ( nilp( privileged_keyword_payload ) ) {
privileged_keyword_location = c_string_to_lisp_keyword( L"payload" );
}
} }
void free_init_symbols( ) { void free_init_symbols( ) {

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;

15
src/io/read.c
View file

@ -167,7 +167,8 @@ 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_string throw_exception( c_string_to_lisp_symbol( L"read"),
c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer ); ( L"End of file while reading" ), frame_pointer );
} else { } else {
switch ( c ) { switch ( c ) {
@ -177,7 +178,8 @@ 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_string result = throw_exception( c_string_to_lisp_symbol( L"read"),
c_string_to_lisp_string
( L"End of input while reading" ), ( L"End of input while reading" ),
frame_pointer ); frame_pointer );
break; break;
@ -266,7 +268,8 @@ 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( make_cons( c_string_to_lisp_string throw_exception(c_string_to_lisp_symbol( L"read"),
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 ) ),
frame_pointer ); frame_pointer );
@ -313,7 +316,8 @@ 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_string return throw_exception( c_string_to_lisp_symbol( L"read"),
c_string_to_lisp_string
( L"Malformed number: too many periods" ), ( L"Malformed number: too many periods" ),
frame_pointer ); frame_pointer );
} else { } else {
@ -324,7 +328,8 @@ 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_string return throw_exception( c_string_to_lisp_symbol( L"read"),
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 );
} else { } else {

14
src/memory/consspaceobject.c
View file

@ -27,6 +27,20 @@
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
#include "ops/intern.h" #include "ops/intern.h"
/**
* Keywords used when constructing exceptions: `:location`. Instantiated in
* `init.c`q.v.
*/
struct cons_pointer privileged_keyword_location = NIL;
/**
* Keywords used when constructing exceptions: `:payload`. Instantiated in
* `init.c`, q.v.
*/
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

17
src/memory/consspaceobject.h
View file

@ -56,6 +56,18 @@
*/ */
#define EXCEPTIONTV 1346721861 #define EXCEPTIONTV 1346721861
/**
* Keywords used when constructing exceptions: `:location`. Instantiated in
* `init.c`.
*/
extern struct cons_pointer privileged_keyword_location;
/**
* Keywords used when constructing exceptions: `:payload`. Instantiated in
* `init.c`.
*/
extern struct cons_pointer privileged_keyword_payload;
/** /**
* An unallocated cell on the free list - should never be encountered by a Lisp * An unallocated cell on the free list - should never be encountered by a Lisp
* function. * function.
@ -296,6 +308,11 @@
*/ */
#define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset])) #define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset]))
/**
* given a cons_pointer as argument, return the tag.
*/
#define get_tag_value(conspoint) ((pointer2cell(conspoint)).tag.value)
/** /**
* true if `conspoint` points to the special cell NIL, else false * true if `conspoint` points to the special cell NIL, else false
* (there should only be one of these so it's slightly redundant). * (there should only be one of these so it's slightly redundant).

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

52
src/ops/intern.c
View file

@ -278,19 +278,22 @@ struct cons_pointer interned( struct cons_pointer key,
struct cons_pointer store ) { struct cons_pointer store ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
debug_print( L"interned: Checking for interned value of `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
if ( symbolp( key ) || keywordp( key ) ) { if ( symbolp( key ) || keywordp( key ) ) {
struct cons_space_object *cell = &pointer2cell( store ); struct cons_space_object *cell = &pointer2cell( store );
switch ( cell->tag.value ) { switch ( cell->tag.value ) {
case CONSTV: case CONSTV:
for ( struct cons_pointer next = store; for ( struct cons_pointer next = store;
nilp( result ) && consp( next ); nilp( result ) && consp( next ); next = c_cdr( next ) ) {
next = c_cdr( next) ) {
if ( !nilp( next ) ) { if ( !nilp( next ) ) {
// struct cons_space_object entry = // struct cons_space_object entry =
// pointer2cell( c_car( next) ); // pointer2cell( c_car( next) );
if ( equal( key, c_car(next) ) ) { if ( equal( key, c_car( next ) ) ) {
result = key; result = key;
} }
} }
@ -308,7 +311,8 @@ 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( make_cons throw_exception( c_string_to_lisp_symbol( L"interned?"),
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Unexpected store type: " ), ( L"Unexpected store type: " ),
c_type( store ) ), NIL ); c_type( store ) ), NIL );
@ -316,7 +320,8 @@ struct cons_pointer interned( struct cons_pointer key,
break; break;
default: default:
result = result =
throw_exception( make_cons throw_exception( c_string_to_lisp_symbol( L"interned?"),
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Unexpected store type: " ), ( L"Unexpected store type: " ),
c_type( store ) ), NIL ); c_type( store ) ), NIL );
@ -324,12 +329,17 @@ struct cons_pointer interned( struct cons_pointer key,
} }
} else { } else {
result = result =
throw_exception( make_cons throw_exception( c_string_to_lisp_symbol( L"interned?"),
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 ) ),
NIL ); NIL );
} }
debug_print( L"interned: returning `", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
return result; return result;
} }
@ -382,7 +392,8 @@ 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_append throw_exception( c_string_to_lisp_symbol( L"assoc"),
c_append
( c_string_to_lisp_string ( 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 );
@ -406,7 +417,8 @@ 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_append throw_exception( c_string_to_lisp_symbol(L"assoc"),
c_append
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Store is of unknown type: " ), ( L"Store is of unknown type: " ),
c_type( store ) ), NIL ); c_type( store ) ), NIL );
@ -441,11 +453,15 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp,
map->payload.hashmap.buckets[bucket_no] ); map->payload.hashmap.buckets[bucket_no] );
} }
debug_print( L"hashmap_put:\n", DEBUG_BIND );
debug_dump_object( mapp, DEBUG_BIND );
return mapp; return mapp;
} }
/** /**
* Return a new key/value store containing all the key/value pairs in this * If this store is modifiable, add this key value pair to it. Otherwise,
* return a new key/value store containing all the key/value pairs in this
* store with this key/value pair added to the front. * store with this key/value pair added to the front.
*/ */
struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
@ -453,7 +469,7 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
#ifdef DEBUG #ifdef DEBUG
bool deep = eq( store, oblist); bool deep = eq( store, oblist );
debug_print_binding( key, value, deep, DEBUG_BIND ); debug_print_binding( key, value, deep, DEBUG_BIND );
if ( deep ) { if ( deep ) {
@ -461,9 +477,7 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
pointer2cell( store ).payload.vectorp.tag.bytes ); pointer2cell( store ).payload.vectorp.tag.bytes );
} }
#endif #endif
if ( nilp( value ) ) { if ( nilp( store ) || consp( store ) ) {
result = store;
} else if ( nilp( store ) || consp( store ) ) {
result = make_cons( make_cons( key, value ), store ); result = make_cons( make_cons( key, value ), store );
} else if ( hashmapp( store ) ) { } else if ( hashmapp( store ) ) {
result = hashmap_put( store, key, value ); result = hashmap_put( store, key, value );
@ -479,16 +493,8 @@ struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) { deep_bind( struct cons_pointer key, struct cons_pointer value ) {
debug_print( L"Entering deep_bind\n", DEBUG_BIND ); debug_print( L"Entering deep_bind\n", DEBUG_BIND );
struct cons_pointer old = oblist;
oblist = set( key, value, oblist ); oblist = set( key, value, oblist );
// 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( L"deep_bind returning ", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND ); debug_print_object( key, DEBUG_BIND );
debug_println( DEBUG_BIND ); debug_println( DEBUG_BIND );
@ -507,7 +513,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
struct cons_pointer canonical = internedp( key, environment ); struct cons_pointer canonical = internedp( key, environment );
if ( nilp( canonical ) ) { if ( nilp( canonical ) ) {
/* /*
* not currently bound. TODO: should this bind to NIL? * not currently bound. TODO: this should bind to NIL?
*/ */
result = set( key, TRUE, environment ); result = set( key, TRUE, environment );
} }

206
src/ops/lispops.c
View file

@ -248,7 +248,7 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
* Evaluate a lambda or nlambda expression. * Evaluate a lambda or nlambda expression.
*/ */
struct cons_pointer struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame, eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
#ifdef DEBUG #ifdef DEBUG
@ -257,8 +257,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
#endif #endif
struct cons_pointer new_env = env; struct cons_pointer new_env = env;
struct cons_pointer names = cell.payload.lambda.args; struct cons_pointer names = cell->payload.lambda.args;
struct cons_pointer body = cell.payload.lambda.body; struct cons_pointer body = cell->payload.lambda.body;
if ( consp( names ) ) { if ( consp( names ) ) {
/* if `names` is a list, bind successive items from that list /* if `names` is a list, bind successive items from that list
@ -328,6 +328,57 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
return result; return result;
} }
/**
* if `r` is an exception, and it doesn't have a location, fix up its location from
* the name associated with this fn_pointer, if any.
*/
struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
struct cons_pointer
fn_pointer ) {
struct cons_pointer result = r;
if ( exceptionp( result ) && (functionp( fn_pointer) || specialp(fn_pointer))) {
struct cons_space_object *fn_cell = &pointer2cell( fn_pointer );
struct cons_pointer payload =
pointer2cell( result ).payload.exception.payload;
/* TODO: should name_key also be a privileged keyword? */
struct cons_pointer name_key =
c_string_to_lisp_keyword( L"name" );
switch ( get_tag_value( payload ) ) {
case NILTV:
case CONSTV:
case HASHTV:
{
if ( nilp( c_assoc( privileged_keyword_location ,
payload ) )) {
pointer2cell( result ).payload.exception.payload =
set( privileged_keyword_location,
c_assoc( name_key,
fn_cell->payload.function.meta ),
payload );
}
}
break;
default:
pointer2cell( result ).payload.exception.payload =
make_cons(
make_cons( privileged_keyword_location,
c_assoc( name_key,
fn_cell->payload.function.meta ) ),
make_cons(
make_cons( privileged_keyword_payload,
payload ) ,
NIL ));
}
dec_ref( name_key);
}
return result;
}
/** /**
* Internal guts of apply. * Internal guts of apply.
@ -348,10 +399,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( exceptionp( fn_pointer ) ) { if ( exceptionp( fn_pointer ) ) {
result = fn_pointer; result = fn_pointer;
} else { } else {
struct cons_space_object fn_cell = pointer2cell( fn_pointer ); struct cons_space_object *fn_cell = &pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] ); struct cons_pointer args = c_cdr( frame->arg[0] );
switch ( fn_cell.tag.value ) { switch ( get_tag_value( fn_pointer ) ) {
case EXCEPTIONTV: case EXCEPTIONTV:
/* just pass exceptions straight back */ /* just pass exceptions straight back */
result = fn_pointer; result = fn_pointer;
@ -369,10 +420,15 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct stack_frame *next = struct stack_frame *next =
get_stack_frame( next_pointer ); get_stack_frame( next_pointer );
result = result = maybe_fixup_exception_location( ( *
( *fn_cell.payload.function.executable ) ( next, ( fn_cell->
payload.
function.
executable ) )
( next,
next_pointer, next_pointer,
env ); env ),
fn_pointer );
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
} }
@ -406,8 +462,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
break; break;
case VECTORPOINTTV:
switch ( pointer_to_vso( fn_pointer )->header.tag.value ) {
case HASHTV: case HASHTV:
/* \todo: if arg[0] is a CONS, treat it as a path */ /* \todo: if arg[0] is a CONS, treat it as a path */
result = c_assoc( eval_form( frame, result = c_assoc( eval_form( frame,
@ -417,8 +471,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
[0] ) ), env ), [0] ) ), env ),
fn_pointer ); fn_pointer );
break; break;
}
break;
case NLAMBDATV: case NLAMBDATV:
{ {
@ -441,15 +493,16 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
{ {
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env ); make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer ); // inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
result = result = maybe_fixup_exception_location( ( *
( *fn_cell.payload. ( fn_cell->
special.executable ) ( get_stack_frame payload.
( next_pointer ), special.
next_pointer, env ); executable ) )
( 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 );
debug_println( DEBUG_EVAL ); debug_println( DEBUG_EVAL );
@ -465,13 +518,16 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
memset( buffer, '\0', bs ); memset( buffer, '\0', bs );
swprintf( buffer, bs, swprintf( buffer, bs,
L"Unexpected cell with tag %d (%4.4s) in function position", L"Unexpected cell with tag %d (%4.4s) in function position",
fn_cell.tag.value, &fn_cell.tag.bytes[0] ); fn_cell->tag.value, &( fn_cell->tag.bytes[0] ) );
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( buffer ); c_string_to_lisp_string( buffer );
free( buffer ); free( buffer );
result = throw_exception( message, frame_pointer ); result =
throw_exception( c_string_to_lisp_symbol( L"apply" ),
message, frame_pointer );
} }
} }
} }
debug_print( L"c_apply: returning: ", DEBUG_EVAL ); debug_print( L"c_apply: returning: ", DEBUG_EVAL );
@ -508,9 +564,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
debug_dump_object( frame_pointer, DEBUG_EVAL ); debug_dump_object( frame_pointer, DEBUG_EVAL );
struct cons_pointer result = frame->arg[0]; struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_space_object *cell = &pointer2cell( frame->arg[0] );
switch ( cell.tag.value ) { switch ( cell->tag.value ) {
case CONSTV: case CONSTV:
result = c_apply( frame, frame_pointer, env ); result = c_apply( frame, frame_pointer, env );
break; break;
@ -523,7 +579,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
make_cons( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( L"Attempt to take value of unbound symbol." ), ( L"Attempt to take value of unbound symbol." ),
frame->arg[0] ); frame->arg[0] );
result = throw_exception( message, frame_pointer ); result =
throw_exception( c_string_to_lisp_symbol( L"eval" ),
message, frame_pointer );
} else { } else {
result = c_assoc( canonical, env ); result = c_assoc( canonical, env );
inc_ref( result ); inc_ref( result );
@ -624,7 +682,8 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = frame->arg[1]; result = frame->arg[1];
} else { } else {
result = result =
throw_exception( make_cons throw_exception( c_string_to_lisp_symbol( L"set" ),
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"The first argument to `set` is not a symbol: " ), ( L"The first argument to `set` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), make_cons( frame->arg[0], NIL ) ),
@ -663,7 +722,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = val; result = val;
} else { } else {
result = result =
throw_exception( make_cons throw_exception( c_string_to_lisp_symbol( L"set!" ),
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"The first argument to `set!` is not a symbol: " ), ( L"The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), make_cons( frame->arg[0], NIL ) ),
@ -735,24 +795,25 @@ struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_space_object *cell = &pointer2cell( frame->arg[0] );
switch ( cell.tag.value ) { switch ( cell->tag.value ) {
case CONSTV: case CONSTV:
result = cell.payload.cons.car; result = cell->payload.cons.car;
break; break;
case NILTV: case NILTV:
break; break;
case READTV: case READTV:
result = result =
make_string( url_fgetwc( cell.payload.stream.stream ), NIL ); make_string( url_fgetwc( cell->payload.stream.stream ), NIL );
break; break;
case STRINGTV: case STRINGTV:
result = make_string( cell.payload.string.character, NIL ); result = make_string( cell->payload.string.character, NIL );
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( L"car" ),
c_string_to_lisp_string
( L"Attempt to take CAR of non sequence" ), ( L"Attempt to take CAR of non sequence" ),
frame_pointer ); frame_pointer );
} }
@ -779,24 +840,25 @@ struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_space_object *cell = &pointer2cell( frame->arg[0] );
switch ( cell.tag.value ) { switch ( cell->tag.value ) {
case CONSTV: case CONSTV:
result = cell.payload.cons.cdr; result = cell->payload.cons.cdr;
break; break;
case NILTV: case NILTV:
break; break;
case READTV: case READTV:
url_fgetwc( cell.payload.stream.stream ); url_fgetwc( cell->payload.stream.stream );
result = frame->arg[0]; result = frame->arg[0];
break; break;
case STRINGTV: case STRINGTV:
result = cell.payload.string.cdr; result = cell->payload.string.cdr;
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( L"cdr" ),
c_string_to_lisp_string
( L"Attempt to take CDR of non sequence" ), ( L"Attempt to take CDR of non sequence" ),
frame_pointer ); frame_pointer );
} }
@ -850,15 +912,15 @@ struct cons_pointer
lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = internedp( frame->arg[0], struct cons_pointer result = internedp( frame->arg[0],
nilp( frame-> nilp( frame->arg[1] ) ? oblist :
arg[1] ) ? oblist : frame-> frame->arg[1] );
arg[1] );
if ( exceptionp( result ) ) { if ( exceptionp( result ) ) {
struct cons_pointer old = result; struct cons_pointer old = result;
struct cons_space_object *cell = &( pointer2cell( result ) ); struct cons_space_object *cell = &( pointer2cell( result ) );
result = result =
throw_exception( cell->payload.exception.payload, frame_pointer ); throw_exception( c_string_to_lisp_symbol( L"interned?" ),
cell->payload.exception.payload, frame_pointer );
dec_ref( old ); dec_ref( old );
} }
@ -1215,7 +1277,8 @@ struct cons_pointer eval_cond_clause( struct cons_pointer clause,
#endif #endif
} }
} else { } else {
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_symbol( L"cond" ),
c_string_to_lisp_string
( L"Arguments to `cond` must be lists" ), ( L"Arguments to `cond` must be lists" ),
frame_pointer ); frame_pointer );
} }
@ -1273,18 +1336,25 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
* pointer to the frame in which the exception occurred. * pointer to the frame in which the exception occurred.
*/ */
struct cons_pointer struct cons_pointer
throw_exception( struct cons_pointer message, throw_exception( struct cons_pointer location,
struct cons_pointer message,
struct cons_pointer frame_pointer ) { struct cons_pointer frame_pointer ) {
debug_print( L"\nERROR: ", DEBUG_EVAL ); debug_print( L"\nERROR: ", DEBUG_EVAL );
debug_dump_object( message, DEBUG_EVAL ); debug_dump_object( message, DEBUG_EVAL );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( message ); struct cons_space_object *cell = &pointer2cell( message );
if ( cell.tag.value == EXCEPTIONTV ) { if ( cell->tag.value == EXCEPTIONTV ) {
result = message; result = message;
} else { } else {
result = make_exception( message, frame_pointer ); result =
make_exception( make_cons
( make_cons( privileged_keyword_location,
location ),
make_cons( make_cons
( privileged_keyword_payload,
message ), NIL ) ), frame_pointer );
} }
return result; return result;
@ -1297,7 +1367,7 @@ throw_exception( struct cons_pointer message,
* normally return. A function which detects a problem it cannot resolve * normally return. A function which detects a problem it cannot resolve
* *should* return an exception. * *should* return an exception.
* *
* * (exception message frame) * * (exception message location)
* *
* @param frame my stack frame. * @param frame my stack frame.
* @param frame_pointer a pointer to my stack_frame. * @param frame_pointer a pointer to my stack_frame.
@ -1312,9 +1382,10 @@ struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0]; struct cons_pointer message = frame->arg[0];
return exceptionp( message ) ? message : throw_exception( message, return exceptionp( message ) ? message : throw_exception( message,
frame-> frame->arg[1],
previous ); frame->previous );
} }
/** /**
@ -1447,24 +1518,24 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_space_object *cell = &pointer2cell( frame->arg[0] );
struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" ); struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" );
switch ( cell.tag.value ) { switch ( cell->tag.value ) {
case FUNCTIONTV: case FUNCTIONTV:
result = c_assoc( source_key, cell.payload.function.meta ); result = c_assoc( source_key, cell->payload.function.meta );
break; break;
case SPECIALTV: case SPECIALTV:
result = c_assoc( source_key, cell.payload.special.meta ); result = c_assoc( source_key, cell->payload.special.meta );
break; break;
case LAMBDATV: case LAMBDATV:
result = make_cons( c_string_to_lisp_symbol( L"lambda" ), result = make_cons( c_string_to_lisp_symbol( L"lambda" ),
make_cons( cell.payload.lambda.args, make_cons( cell->payload.lambda.args,
cell.payload.lambda.body ) ); cell->payload.lambda.body ) );
break; break;
case NLAMBDATV: case NLAMBDATV:
result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), result = make_cons( c_string_to_lisp_symbol( L"nlambda" ),
make_cons( cell.payload.lambda.args, make_cons( cell->payload.lambda.args,
cell.payload.lambda.body ) ); cell->payload.lambda.body ) );
break; break;
} }
// \todo suffers from premature GC, and I can't see why! // \todo suffers from premature GC, and I can't see why!
@ -1487,7 +1558,8 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
c_append( c_cdr( l1 ), l2 ) ); c_append( c_cdr( l1 ), l2 ) );
} }
} else { } else {
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( L"append" ),
c_string_to_lisp_string
( L"Can't append: not same type" ), NIL ); ( L"Can't append: not same type" ), NIL );
} }
break; break;
@ -1497,24 +1569,25 @@ 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 );
} }
} else { } else {
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( L"append" ),
c_string_to_lisp_string
( L"Can't append: not same type" ), NIL ); ( L"Can't append: not same type" ), NIL );
} }
break; break;
default: default:
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( L"append" ),
c_string_to_lisp_string
( L"Can't append: not a sequence" ), NIL ); ( L"Can't append: not a sequence" ), NIL );
break; break;
} }
@ -1626,7 +1699,8 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
bindings = make_cons( make_cons( symbol, val ), bindings ); bindings = make_cons( make_cons( symbol, val ), bindings );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( L"let" ),
c_string_to_lisp_string
( L"Let: cannot bind, not a symbol" ), ( L"Let: cannot bind, not a symbol" ),
frame_pointer ); frame_pointer );
break; break;

3
src/ops/lispops.h
View file

@ -196,7 +196,8 @@ struct cons_pointer lisp_cond( struct stack_frame *frame,
* signature of a lisp function; but it is nevertheless to be preferred to * signature of a lisp function; but it is nevertheless to be preferred to
* make_exception. A real `throw_exception`, which does, will be needed. * make_exception. A real `throw_exception`, which does, will be needed.
*/ */
struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer throw_exception( struct cons_pointer location,
struct cons_pointer message,
struct cons_pointer frame_pointer ); struct cons_pointer frame_pointer );
struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer lisp_exception( struct stack_frame *frame,