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

Compare commits

base: simon:a1c377bc7c7ded8b175a346e9028212db418bc51
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:72548097cf9362e0c1f29559e81403267940a8c0
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

No commits in common. "a1c377bc7c7ded8b175a346e9028212db418bc51" and "72548097cf9362e0c1f29559e81403267940a8c0" have entirely different histories.
a1c377bc7c ... 72548097cf

11 changed files with 131 additions and 272 deletions
Download patch file Download diff file Expand all files Collapse all files

36
src/arith/peano.c
View file

@ -296,8 +296,7 @@ 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_string
c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -320,8 +319,7 @@ 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_string
c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -334,8 +332,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_string
c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
} }
@ -431,8 +428,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( 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: " ),
c_type( arg2 ) ), c_type( arg2 ) ),
@ -458,8 +454,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( 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" ),
c_type( arg2 ) ), c_type( arg2 ) ),
@ -472,8 +467,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( 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 ) ),
frame_pointer ); frame_pointer );
@ -626,8 +620,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_string
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -657,8 +650,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_string
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -669,8 +661,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_string
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -741,8 +732,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_string
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -772,8 +762,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_string
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -785,8 +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_string
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,9 +114,7 @@ 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( make_cons( c_string_to_lisp_string
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 ) ) ),
@ -156,8 +154,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( 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,
make_cons( ratarg, make_cons( ratarg,
@ -237,8 +234,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_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,8 +269,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_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,8 +337,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_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 );
} }

10
src/init.c
View file

@ -84,18 +84,12 @@ 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" );
} }
// we can't make this string when we need it, because memory is then
// exhausted!
if ( nilp( privileged_string_memory_exhausted ) ) { 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 = 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.stream. ( pointer2cell( frame->arg[0] ).payload.
stream ), NIL ); stream.stream ), NIL );
} }
return result; return result;

15
src/io/read.c
View file

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

14
src/memory/consspaceobject.c
View file

@ -27,20 +27,6 @@
#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,18 +56,6 @@
*/ */
#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.
@ -308,11 +296,6 @@ extern struct cons_pointer privileged_keyword_payload;
*/ */
#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 ).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 );

56
src/ops/intern.c
View file

@ -278,22 +278,19 @@ 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 ); next = c_cdr( next ) ) { nilp( result ) && consp( 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;
} }
} }
@ -311,8 +308,7 @@ 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( make_cons
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 );
@ -320,8 +316,7 @@ struct cons_pointer interned( struct cons_pointer key,
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"interned?"), throw_exception( make_cons
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 );
@ -329,17 +324,12 @@ struct cons_pointer interned( struct cons_pointer key,
} }
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"interned?"), throw_exception( 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 ) ),
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;
} }
@ -392,8 +382,7 @@ 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_append
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 );
@ -417,8 +406,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_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: " ),
c_type( store ) ), NIL ); c_type( store ) ), NIL );
@ -453,23 +441,19 @@ 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;
} }
/** /**
* 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
* 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,
struct cons_pointer store ) { struct cons_pointer store ) {
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 ) {
@ -477,7 +461,9 @@ 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( store ) || consp( store ) ) { if ( nilp( value ) ) {
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 );
@ -493,8 +479,16 @@ 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 );
@ -513,7 +507,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: this should bind to NIL? * not currently bound. TODO: should this bind to NIL?
*/ */
result = set( key, TRUE, environment ); result = set( key, TRUE, environment );
} }

224
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,57 +328,6 @@ 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.
@ -399,10 +348,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 ( get_tag_value( fn_pointer ) ) { switch ( fn_cell.tag.value ) {
case EXCEPTIONTV: case EXCEPTIONTV:
/* just pass exceptions straight back */ /* just pass exceptions straight back */
result = fn_pointer; result = fn_pointer;
@ -420,15 +369,10 @@ 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 = maybe_fixup_exception_location( ( * result =
( fn_cell-> ( *fn_cell.payload.function.executable ) ( next,
payload. next_pointer,
function. env );
executable ) )
( next,
next_pointer,
env ),
fn_pointer );
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
} }
@ -462,14 +406,18 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
break; break;
case HASHTV: case VECTORPOINTTV:
/* \todo: if arg[0] is a CONS, treat it as a path */ switch ( pointer_to_vso( fn_pointer )->header.tag.value ) {
result = c_assoc( eval_form( frame, case HASHTV:
frame_pointer, /* \todo: if arg[0] is a CONS, treat it as a path */
c_car( c_cdr result = c_assoc( eval_form( frame,
( frame->arg frame_pointer,
[0] ) ), env ), c_car( c_cdr
fn_pointer ); ( frame->arg
[0] ) ), env ),
fn_pointer );
break;
}
break; break;
case NLAMBDATV: case NLAMBDATV:
@ -493,16 +441,15 @@ 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 = maybe_fixup_exception_location( ( * result =
( fn_cell-> ( *fn_cell.payload.
payload. special.executable ) ( get_stack_frame
special. ( next_pointer ),
executable ) ) next_pointer, env );
( 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 );
@ -518,16 +465,13 @@ 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 = result = throw_exception( message, frame_pointer );
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 );
@ -564,9 +508,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;
@ -579,9 +523,7 @@ 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 = result = throw_exception( message, frame_pointer );
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 );
@ -682,8 +624,7 @@ 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( c_string_to_lisp_symbol( L"set" ), throw_exception( make_cons
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 ) ),
@ -722,8 +663,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = val; result = val;
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"set!" ), throw_exception( make_cons
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 ) ),
@ -795,25 +735,24 @@ 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_symbol( L"car" ), throw_exception( c_string_to_lisp_string
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 );
} }
@ -840,25 +779,24 @@ 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_symbol( L"cdr" ), throw_exception( c_string_to_lisp_string
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 );
} }
@ -912,15 +850,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->arg[1] ) ? oblist : nilp( frame->
frame->arg[1] ); arg[1] ) ? oblist : frame->
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( c_string_to_lisp_symbol( L"interned?" ), throw_exception( cell->payload.exception.payload, frame_pointer );
cell->payload.exception.payload, frame_pointer );
dec_ref( old ); dec_ref( old );
} }
@ -1277,8 +1215,7 @@ struct cons_pointer eval_cond_clause( struct cons_pointer clause,
#endif #endif
} }
} else { } else {
result = throw_exception( c_string_to_lisp_symbol( L"cond" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Arguments to `cond` must be lists" ), ( L"Arguments to `cond` must be lists" ),
frame_pointer ); frame_pointer );
} }
@ -1336,25 +1273,18 @@ 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 location, throw_exception( struct cons_pointer message,
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 = result = make_exception( message, frame_pointer );
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;
@ -1367,7 +1297,7 @@ throw_exception( struct cons_pointer location,
* 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 location) * * (exception message frame)
* *
* @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.
@ -1382,10 +1312,9 @@ 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->arg[1], frame->
frame->previous ); previous );
} }
/** /**
@ -1518,24 +1447,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!
@ -1558,8 +1487,7 @@ 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_symbol( L"append" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Can't append: not same type" ), NIL ); ( L"Can't append: not same type" ), NIL );
} }
break; break;
@ -1569,25 +1497,24 @@ 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 );
} }
} else { } else {
throw_exception( c_string_to_lisp_symbol( L"append" ), throw_exception( c_string_to_lisp_string
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_symbol( L"append" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Can't append: not a sequence" ), NIL ); ( L"Can't append: not a sequence" ), NIL );
break; break;
} }
@ -1699,8 +1626,7 @@ 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_symbol( L"let" ), throw_exception( c_string_to_lisp_string
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,8 +196,7 @@ 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 location, struct cons_pointer throw_exception( struct cons_pointer message,
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,