Compare commits
2 commits
72548097cf
...
a1c377bc7c
| Author | SHA1 | Date | |
|---|---|---|---|
| a1c377bc7c | |||
| 54f6f023c6 |
11 changed files with 272 additions and 131 deletions
|
|
@ -296,7 +296,8 @@ struct cons_pointer add_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -319,7 +320,8 @@ struct cons_pointer add_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -332,7 +334,8 @@ struct cons_pointer add_2( struct stack_frame *frame,
|
|||
break;
|
||||
default:
|
||||
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" ),
|
||||
frame_pointer );
|
||||
}
|
||||
|
|
@ -428,7 +431,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
|
|||
break;
|
||||
default:
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"*"),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"Cannot multiply: argument 2 is not a number: " ),
|
||||
c_type( arg2 ) ),
|
||||
|
|
@ -454,7 +458,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
|
|||
break;
|
||||
default:
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"*"),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"Cannot multiply: argument 2 is not a number" ),
|
||||
c_type( arg2 ) ),
|
||||
|
|
@ -467,7 +472,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
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" ),
|
||||
c_type( arg1 ) ),
|
||||
frame_pointer );
|
||||
|
|
@ -620,7 +626,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -650,7 +657,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -661,7 +669,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
|
|||
make_real( to_long_double( arg1 ) - to_long_double( arg2 ) );
|
||||
break;
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -732,7 +741,8 @@ struct cons_pointer lisp_divide( struct
|
|||
to_long_double( frame->arg[1] ) );
|
||||
break;
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -762,7 +772,8 @@ struct cons_pointer lisp_divide( struct
|
|||
to_long_double( frame->arg[1] ) );
|
||||
break;
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -774,7 +785,8 @@ struct cons_pointer lisp_divide( struct
|
|||
to_long_double( frame->arg[1] ) );
|
||||
break;
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -114,7 +114,9 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
|
|||
cell1->payload.ratio.divisor ) );
|
||||
r = make_ratio( dividend, divisor, true );
|
||||
} 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" ),
|
||||
make_cons( arg1,
|
||||
make_cons( arg2, NIL ) ) ),
|
||||
|
|
@ -154,7 +156,8 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
|
|||
dec_ref( ratio );
|
||||
} else {
|
||||
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" ),
|
||||
make_cons( intarg,
|
||||
make_cons( ratarg,
|
||||
|
|
@ -234,7 +237,8 @@ struct cons_pointer multiply_ratio_ratio( struct
|
|||
release_integer( divisor );
|
||||
} else {
|
||||
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" ),
|
||||
NIL );
|
||||
}
|
||||
|
|
@ -269,7 +273,8 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
|
|||
release_integer( one );
|
||||
} else {
|
||||
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" ),
|
||||
NIL );
|
||||
}
|
||||
|
|
@ -337,7 +342,8 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
|
|||
}
|
||||
} else {
|
||||
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" ),
|
||||
NIL );
|
||||
}
|
||||
|
|
|
|||
10
src/init.c
10
src/init.c
|
|
@ -84,12 +84,18 @@ void maybe_bind_init_symbols( ) {
|
|||
if ( nilp( privileged_symbol_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 ) ) {
|
||||
// we can't make this string when we need it, because memory is then
|
||||
// exhausted!
|
||||
privileged_string_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( ) {
|
||||
|
|
|
|||
|
|
@ -508,8 +508,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
if ( readp( frame->arg[0] ) ) {
|
||||
result =
|
||||
make_string( url_fgetwc
|
||||
( pointer2cell( frame->arg[0] ).payload.
|
||||
stream.stream ), NIL );
|
||||
( pointer2cell( frame->arg[0] ).payload.stream.
|
||||
stream ), NIL );
|
||||
}
|
||||
|
||||
return result;
|
||||
|
|
|
|||
|
|
@ -167,7 +167,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
|
|||
|
||||
if ( url_feof( input ) ) {
|
||||
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 );
|
||||
} else {
|
||||
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 */
|
||||
break;
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -266,7 +268,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
|
|||
result = read_symbol_or_key( input, SYMBOLTV, c );
|
||||
} else {
|
||||
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" ),
|
||||
make_string( c, NIL ) ),
|
||||
frame_pointer );
|
||||
|
|
@ -313,7 +316,8 @@ struct cons_pointer read_number( struct stack_frame *frame,
|
|||
switch ( c ) {
|
||||
case LPERIOD:
|
||||
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" ),
|
||||
frame_pointer );
|
||||
} else {
|
||||
|
|
@ -324,7 +328,8 @@ struct cons_pointer read_number( struct stack_frame *frame,
|
|||
break;
|
||||
case LSLASH:
|
||||
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" ),
|
||||
frame_pointer );
|
||||
} else {
|
||||
|
|
|
|||
|
|
@ -27,6 +27,20 @@
|
|||
#include "memory/vectorspace.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`,
|
||||
* or, if the tag of the cell is `VECP`, if the value of the tag of the
|
||||
|
|
|
|||
|
|
@ -56,6 +56,18 @@
|
|||
*/
|
||||
#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
|
||||
* function.
|
||||
|
|
@ -296,6 +308,11 @@
|
|||
*/
|
||||
#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
|
||||
* (there should only be one of these so it's slightly redundant).
|
||||
|
|
|
|||
|
|
@ -114,10 +114,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
|
|||
case RATIOTV:
|
||||
url_fwprintf( output,
|
||||
L"\t\tRational cell: value %ld/%ld, count %u\n",
|
||||
pointer2cell( cell.payload.ratio.dividend ).
|
||||
payload.integer.value,
|
||||
pointer2cell( cell.payload.ratio.divisor ).
|
||||
payload.integer.value, cell.count );
|
||||
pointer2cell( cell.payload.ratio.dividend ).payload.
|
||||
integer.value,
|
||||
pointer2cell( cell.payload.ratio.divisor ).payload.
|
||||
integer.value, cell.count );
|
||||
break;
|
||||
case READTV:
|
||||
url_fputws( L"\t\tInput stream; metadata: ", output );
|
||||
|
|
|
|||
|
|
@ -278,19 +278,22 @@ struct cons_pointer interned( struct cons_pointer key,
|
|||
struct cons_pointer store ) {
|
||||
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 ) ) {
|
||||
struct cons_space_object *cell = &pointer2cell( store );
|
||||
|
||||
switch ( cell->tag.value ) {
|
||||
case CONSTV:
|
||||
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 ) ) {
|
||||
// struct cons_space_object entry =
|
||||
// pointer2cell( c_car( next) );
|
||||
|
||||
if ( equal( key, c_car(next) ) ) {
|
||||
if ( equal( key, c_car( next ) ) ) {
|
||||
result = key;
|
||||
}
|
||||
}
|
||||
|
|
@ -308,7 +311,8 @@ struct cons_pointer interned( struct cons_pointer key,
|
|||
map->payload.hashmap.buckets[bucket_no] );
|
||||
} else {
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"interned?"),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"Unexpected store type: " ),
|
||||
c_type( store ) ), NIL );
|
||||
|
|
@ -316,7 +320,8 @@ struct cons_pointer interned( struct cons_pointer key,
|
|||
break;
|
||||
default:
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"interned?"),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"Unexpected store type: " ),
|
||||
c_type( store ) ), NIL );
|
||||
|
|
@ -324,12 +329,17 @@ struct cons_pointer interned( struct cons_pointer key,
|
|||
}
|
||||
} else {
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"interned?"),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"Unexpected key type: " ), c_type( key ) ),
|
||||
NIL );
|
||||
}
|
||||
|
||||
debug_print( L"interned: returning `", DEBUG_BIND );
|
||||
debug_print_object( result, DEBUG_BIND );
|
||||
debug_print( L"`\n", DEBUG_BIND );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
|
@ -382,7 +392,8 @@ struct cons_pointer c_assoc( struct cons_pointer key,
|
|||
result = hashmap_get( entry_ptr, key );
|
||||
break;
|
||||
default:
|
||||
throw_exception( c_append
|
||||
throw_exception( c_string_to_lisp_symbol( L"assoc"),
|
||||
c_append
|
||||
( c_string_to_lisp_string
|
||||
( L"Store entry is of unknown type: " ),
|
||||
c_type( entry_ptr ) ), NIL );
|
||||
|
|
@ -406,7 +417,8 @@ struct cons_pointer c_assoc( struct cons_pointer key,
|
|||
// debug_print( L"`\n", DEBUG_BIND );
|
||||
// #endif
|
||||
result =
|
||||
throw_exception( c_append
|
||||
throw_exception( c_string_to_lisp_symbol(L"assoc"),
|
||||
c_append
|
||||
( c_string_to_lisp_string
|
||||
( L"Store is of unknown type: " ),
|
||||
c_type( store ) ), NIL );
|
||||
|
|
@ -441,19 +453,23 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp,
|
|||
map->payload.hashmap.buckets[bucket_no] );
|
||||
}
|
||||
|
||||
debug_print( L"hashmap_put:\n", DEBUG_BIND );
|
||||
debug_dump_object( mapp, DEBUG_BIND );
|
||||
|
||||
return mapp;
|
||||
}
|
||||
|
||||
/**
|
||||
* Return a new key/value store containing all the key/value pairs in this
|
||||
* store with this key/value pair added to the front.
|
||||
*/
|
||||
/**
|
||||
* 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.
|
||||
*/
|
||||
struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
|
||||
struct cons_pointer store ) {
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
#ifdef DEBUG
|
||||
bool deep = eq( store, oblist);
|
||||
bool deep = eq( store, oblist );
|
||||
debug_print_binding( key, value, deep, DEBUG_BIND );
|
||||
|
||||
if ( deep ) {
|
||||
|
|
@ -461,9 +477,7 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
|
|||
pointer2cell( store ).payload.vectorp.tag.bytes );
|
||||
}
|
||||
#endif
|
||||
if ( nilp( value ) ) {
|
||||
result = store;
|
||||
} else if ( nilp( store ) || consp( store ) ) {
|
||||
if ( nilp( store ) || consp( store ) ) {
|
||||
result = make_cons( make_cons( key, value ), store );
|
||||
} else if ( hashmapp( store ) ) {
|
||||
result = hashmap_put( store, key, value );
|
||||
|
|
@ -479,16 +493,8 @@ struct cons_pointer
|
|||
deep_bind( struct cons_pointer key, struct cons_pointer value ) {
|
||||
debug_print( L"Entering deep_bind\n", DEBUG_BIND );
|
||||
|
||||
struct cons_pointer old = 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_object( key, 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 );
|
||||
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 );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -248,7 +248,7 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
* Evaluate a lambda or nlambda expression.
|
||||
*/
|
||||
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 result = NIL;
|
||||
#ifdef DEBUG
|
||||
|
|
@ -257,8 +257,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
|||
#endif
|
||||
|
||||
struct cons_pointer new_env = env;
|
||||
struct cons_pointer names = cell.payload.lambda.args;
|
||||
struct cons_pointer body = cell.payload.lambda.body;
|
||||
struct cons_pointer names = cell->payload.lambda.args;
|
||||
struct cons_pointer body = cell->payload.lambda.body;
|
||||
|
||||
if ( consp( names ) ) {
|
||||
/* 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;
|
||||
}
|
||||
|
||||
/**
|
||||
* 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.
|
||||
|
|
@ -348,10 +399,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
if ( exceptionp( fn_pointer ) ) {
|
||||
result = fn_pointer;
|
||||
} 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] );
|
||||
|
||||
switch ( fn_cell.tag.value ) {
|
||||
switch ( get_tag_value( fn_pointer ) ) {
|
||||
case EXCEPTIONTV:
|
||||
/* just pass exceptions straight back */
|
||||
result = fn_pointer;
|
||||
|
|
@ -369,10 +420,15 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
struct stack_frame *next =
|
||||
get_stack_frame( next_pointer );
|
||||
|
||||
result =
|
||||
( *fn_cell.payload.function.executable ) ( next,
|
||||
next_pointer,
|
||||
env );
|
||||
result = maybe_fixup_exception_location( ( *
|
||||
( fn_cell->
|
||||
payload.
|
||||
function.
|
||||
executable ) )
|
||||
( next,
|
||||
next_pointer,
|
||||
env ),
|
||||
fn_pointer );
|
||||
dec_ref( next_pointer );
|
||||
}
|
||||
}
|
||||
|
|
@ -406,18 +462,14 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
}
|
||||
break;
|
||||
|
||||
case VECTORPOINTTV:
|
||||
switch ( pointer_to_vso( fn_pointer )->header.tag.value ) {
|
||||
case HASHTV:
|
||||
/* \todo: if arg[0] is a CONS, treat it as a path */
|
||||
result = c_assoc( eval_form( frame,
|
||||
frame_pointer,
|
||||
c_car( c_cdr
|
||||
( frame->arg
|
||||
[0] ) ), env ),
|
||||
fn_pointer );
|
||||
break;
|
||||
}
|
||||
case HASHTV:
|
||||
/* \todo: if arg[0] is a CONS, treat it as a path */
|
||||
result = c_assoc( eval_form( frame,
|
||||
frame_pointer,
|
||||
c_car( c_cdr
|
||||
( frame->arg
|
||||
[0] ) ), env ),
|
||||
fn_pointer );
|
||||
break;
|
||||
|
||||
case NLAMBDATV:
|
||||
|
|
@ -441,15 +493,16 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
{
|
||||
struct cons_pointer next_pointer =
|
||||
make_special_frame( frame_pointer, args, env );
|
||||
inc_ref( next_pointer );
|
||||
// inc_ref( next_pointer );
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
result =
|
||||
( *fn_cell.payload.
|
||||
special.executable ) ( get_stack_frame
|
||||
( next_pointer ),
|
||||
next_pointer, env );
|
||||
result = maybe_fixup_exception_location( ( *
|
||||
( fn_cell->
|
||||
payload.
|
||||
special.
|
||||
executable ) )
|
||||
( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer );
|
||||
debug_print( L"Special form returning: ", DEBUG_EVAL );
|
||||
debug_print_object( result, DEBUG_EVAL );
|
||||
debug_println( DEBUG_EVAL );
|
||||
|
|
@ -465,13 +518,16 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
memset( buffer, '\0', bs );
|
||||
swprintf( buffer, bs,
|
||||
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 =
|
||||
c_string_to_lisp_string( 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 );
|
||||
|
|
@ -508,9 +564,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
debug_dump_object( frame_pointer, DEBUG_EVAL );
|
||||
|
||||
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:
|
||||
result = c_apply( frame, frame_pointer, env );
|
||||
break;
|
||||
|
|
@ -523,7 +579,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
make_cons( c_string_to_lisp_string
|
||||
( L"Attempt to take value of unbound symbol." ),
|
||||
frame->arg[0] );
|
||||
result = throw_exception( message, frame_pointer );
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_symbol( L"eval" ),
|
||||
message, frame_pointer );
|
||||
} else {
|
||||
result = c_assoc( canonical, env );
|
||||
inc_ref( result );
|
||||
|
|
@ -624,7 +682,8 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
result = frame->arg[1];
|
||||
} else {
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"set" ),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"The first argument to `set` is not a symbol: " ),
|
||||
make_cons( frame->arg[0], NIL ) ),
|
||||
|
|
@ -663,7 +722,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
result = val;
|
||||
} else {
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"set!" ),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"The first argument to `set!` is not a symbol: " ),
|
||||
make_cons( frame->arg[0], NIL ) ),
|
||||
|
|
@ -735,24 +795,25 @@ struct cons_pointer
|
|||
lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
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:
|
||||
result = cell.payload.cons.car;
|
||||
result = cell->payload.cons.car;
|
||||
break;
|
||||
case NILTV:
|
||||
break;
|
||||
case READTV:
|
||||
result =
|
||||
make_string( url_fgetwc( cell.payload.stream.stream ), NIL );
|
||||
make_string( url_fgetwc( cell->payload.stream.stream ), NIL );
|
||||
break;
|
||||
case STRINGTV:
|
||||
result = make_string( cell.payload.string.character, NIL );
|
||||
result = make_string( cell->payload.string.character, NIL );
|
||||
break;
|
||||
default:
|
||||
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" ),
|
||||
frame_pointer );
|
||||
}
|
||||
|
|
@ -779,24 +840,25 @@ struct cons_pointer
|
|||
lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
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:
|
||||
result = cell.payload.cons.cdr;
|
||||
result = cell->payload.cons.cdr;
|
||||
break;
|
||||
case NILTV:
|
||||
break;
|
||||
case READTV:
|
||||
url_fgetwc( cell.payload.stream.stream );
|
||||
url_fgetwc( cell->payload.stream.stream );
|
||||
result = frame->arg[0];
|
||||
break;
|
||||
case STRINGTV:
|
||||
result = cell.payload.string.cdr;
|
||||
result = cell->payload.string.cdr;
|
||||
break;
|
||||
default:
|
||||
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" ),
|
||||
frame_pointer );
|
||||
}
|
||||
|
|
@ -850,15 +912,15 @@ struct cons_pointer
|
|||
lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
struct cons_pointer result = internedp( frame->arg[0],
|
||||
nilp( frame->
|
||||
arg[1] ) ? oblist : frame->
|
||||
arg[1] );
|
||||
nilp( frame->arg[1] ) ? oblist :
|
||||
frame->arg[1] );
|
||||
|
||||
if ( exceptionp( result ) ) {
|
||||
struct cons_pointer old = result;
|
||||
struct cons_space_object *cell = &( pointer2cell( 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 );
|
||||
}
|
||||
|
||||
|
|
@ -1215,7 +1277,8 @@ struct cons_pointer eval_cond_clause( struct cons_pointer clause,
|
|||
#endif
|
||||
}
|
||||
} 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" ),
|
||||
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.
|
||||
*/
|
||||
struct cons_pointer
|
||||
throw_exception( struct cons_pointer message,
|
||||
throw_exception( struct cons_pointer location,
|
||||
struct cons_pointer message,
|
||||
struct cons_pointer frame_pointer ) {
|
||||
debug_print( L"\nERROR: ", DEBUG_EVAL );
|
||||
debug_dump_object( message, DEBUG_EVAL );
|
||||
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;
|
||||
} 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;
|
||||
|
|
@ -1297,7 +1367,7 @@ throw_exception( struct cons_pointer message,
|
|||
* normally return. A function which detects a problem it cannot resolve
|
||||
* *should* return an exception.
|
||||
*
|
||||
* * (exception message frame)
|
||||
* * (exception message location)
|
||||
*
|
||||
* @param frame 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,
|
||||
struct cons_pointer env ) {
|
||||
struct cons_pointer message = frame->arg[0];
|
||||
|
||||
return exceptionp( message ) ? message : throw_exception( message,
|
||||
frame->
|
||||
previous );
|
||||
frame->arg[1],
|
||||
frame->previous );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -1447,24 +1518,24 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
|
|||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
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" );
|
||||
switch ( cell.tag.value ) {
|
||||
switch ( cell->tag.value ) {
|
||||
case FUNCTIONTV:
|
||||
result = c_assoc( source_key, cell.payload.function.meta );
|
||||
result = c_assoc( source_key, cell->payload.function.meta );
|
||||
break;
|
||||
case SPECIALTV:
|
||||
result = c_assoc( source_key, cell.payload.special.meta );
|
||||
result = c_assoc( source_key, cell->payload.special.meta );
|
||||
break;
|
||||
case LAMBDATV:
|
||||
result = make_cons( c_string_to_lisp_symbol( L"lambda" ),
|
||||
make_cons( cell.payload.lambda.args,
|
||||
cell.payload.lambda.body ) );
|
||||
make_cons( cell->payload.lambda.args,
|
||||
cell->payload.lambda.body ) );
|
||||
break;
|
||||
case NLAMBDATV:
|
||||
result = make_cons( c_string_to_lisp_symbol( L"nlambda" ),
|
||||
make_cons( cell.payload.lambda.args,
|
||||
cell.payload.lambda.body ) );
|
||||
make_cons( cell->payload.lambda.args,
|
||||
cell->payload.lambda.body ) );
|
||||
break;
|
||||
}
|
||||
// \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 ) );
|
||||
}
|
||||
} 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 );
|
||||
}
|
||||
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 ( nilp( c_cdr( l1 ) ) ) {
|
||||
return
|
||||
make_string_like_thing( ( pointer2cell( l1 ).
|
||||
payload.string.character ),
|
||||
l2,
|
||||
make_string_like_thing( ( pointer2cell( l1 ).payload.
|
||||
string.character ), l2,
|
||||
pointer2cell( l1 ).tag.value );
|
||||
} else {
|
||||
return
|
||||
make_string_like_thing( ( pointer2cell( l1 ).
|
||||
payload.string.character ),
|
||||
make_string_like_thing( ( pointer2cell( l1 ).payload.
|
||||
string.character ),
|
||||
c_append( c_cdr( l1 ), l2 ),
|
||||
pointer2cell( l1 ).tag.value );
|
||||
}
|
||||
} 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 );
|
||||
}
|
||||
break;
|
||||
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 );
|
||||
break;
|
||||
}
|
||||
|
|
@ -1626,7 +1699,8 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
|
|||
bindings = make_cons( make_cons( symbol, val ), bindings );
|
||||
} else {
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
* 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 lisp_exception( struct stack_frame *frame,
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue