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

Horribly broken, may have to rethink.

Browse source
This commit is contained in:
Simon Brooke 2018-12-26 21:10:24 +00:00
parent 9937f344dc
commit 3d5c27cb10
19 changed files with 568 additions and 413 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

56
src/arith/peano.c
View file

@ -28,7 +28,9 @@
long double to_long_double( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg ); int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ); struct cons_pointer arg2 );
@ -119,7 +121,9 @@ int64_t to_long_int( struct cons_pointer arg ) {
* return a cons_pointer indicating a number which is the sum of * return a cons_pointer indicating a number which is the sum of
* the numbers indicated by `arg1` and `arg2`. * the numbers indicated by `arg1` and `arg2`.
*/ */
struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer result; struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
@ -153,7 +157,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
cell2.payload.integer.value ); cell2.payload.integer.value );
break; break;
case RATIOTV: case RATIOTV:
result = add_integer_ratio( frame_pointer, arg1, arg2 ); result =
add_integer_ratio( frame_pointer, arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -173,7 +178,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
result = arg2; result = arg2;
break; break;
case INTEGERTV: case INTEGERTV:
result = add_integer_ratio( frame_pointer, arg2, arg1 ); result =
add_integer_ratio( frame_pointer, arg2, arg1 );
break; break;
case RATIOTV: case RATIOTV:
result = add_ratio_ratio( frame_pointer, arg1, arg2 ); result = add_ratio_ratio( frame_pointer, arg1, arg2 );
@ -198,7 +204,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
default: default:
result = exceptionp( arg2 ) ? arg2 : result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), frame_pointer ); ( "Cannot add: not a number" ),
frame_pointer );
} }
} }
@ -252,7 +259,8 @@ struct cons_pointer lisp_add( struct stack_frame
* return a cons_pointer indicating a number which is the product of * return a cons_pointer indicating a number which is the product of
* the numbers indicated by `arg1` and `arg2`. * the numbers indicated by `arg1` and `arg2`.
*/ */
struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer multiply_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer result; struct cons_pointer result;
@ -286,7 +294,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
cell2.payload.integer.value ); cell2.payload.integer.value );
break; break;
case RATIOTV: case RATIOTV:
result = multiply_integer_ratio( frame_pointer, arg1, arg2 ); result =
multiply_integer_ratio( frame_pointer, arg1,
arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -306,10 +316,13 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
result = arg2; result = arg2;
break; break;
case INTEGERTV: case INTEGERTV:
result = multiply_integer_ratio( frame_pointer, arg2, arg1 ); result =
multiply_integer_ratio( frame_pointer, arg2,
arg1 );
break; break;
case RATIOTV: case RATIOTV:
result = multiply_ratio_ratio( frame_pointer, arg1, arg2 ); result =
multiply_ratio_ratio( frame_pointer, arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -406,8 +419,8 @@ struct cons_pointer inverse( struct cons_pointer frame,
case RATIOTV: case RATIOTV:
result = make_ratio( frame, result = make_ratio( frame,
make_integer( 0 - make_integer( 0 -
to_long_int( cell.payload.ratio. to_long_int( cell.payload.
dividend ) ), ratio.dividend ) ),
cell.payload.ratio.divisor ); cell.payload.ratio.divisor );
break; break;
case REALTV: case REALTV:
@ -455,7 +468,8 @@ struct cons_pointer lisp_subtract( struct
make_integer( 1 ) ); make_integer( 1 ) );
inc_ref( tmp ); inc_ref( tmp );
result = result =
subtract_ratio_ratio( frame_pointer, tmp, frame->arg[1] ); subtract_ratio_ratio( frame_pointer, tmp,
frame->arg[1] );
dec_ref( tmp ); dec_ref( tmp );
} }
break; break;
@ -482,7 +496,8 @@ struct cons_pointer lisp_subtract( struct
make_integer( 1 ) ); make_integer( 1 ) );
inc_ref( tmp ); inc_ref( tmp );
result = result =
subtract_ratio_ratio( frame_pointer, frame->arg[0], tmp ); subtract_ratio_ratio( frame_pointer, frame->arg[0],
tmp );
dec_ref( tmp ); dec_ref( tmp );
} }
break; break;
@ -510,7 +525,8 @@ struct cons_pointer lisp_subtract( struct
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot subtract: not a number" ), frame_pointer ); ( "Cannot subtract: not a number" ),
frame_pointer );
break; break;
} }
@ -544,7 +560,8 @@ struct cons_pointer lisp_divide( struct
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer unsimplified = struct cons_pointer unsimplified =
make_ratio( frame_pointer, frame->arg[0], frame->arg[1] ); make_ratio( frame_pointer, frame->arg[0],
frame->arg[1] );
/* OK, if result may be unsimplified, we should not inc_ref it /* OK, if result may be unsimplified, we should not inc_ref it
* - but if not, we should dec_ref it. */ * - but if not, we should dec_ref it. */
result = simplify_ratio( frame_pointer, unsimplified ); result = simplify_ratio( frame_pointer, unsimplified );
@ -558,7 +575,8 @@ struct cons_pointer lisp_divide( struct
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[0], one ); make_ratio( frame_pointer, frame->arg[0], one );
result = result =
divide_ratio_ratio( frame_pointer, ratio, frame->arg[1] ); divide_ratio_ratio( frame_pointer, ratio,
frame->arg[1] );
dec_ref( ratio ); dec_ref( ratio );
} }
break; break;
@ -586,7 +604,8 @@ struct cons_pointer lisp_divide( struct
make_ratio( frame_pointer, frame->arg[1], one ); make_ratio( frame_pointer, frame->arg[1], one );
inc_ref( ratio ); inc_ref( ratio );
result = result =
divide_ratio_ratio( frame_pointer, frame->arg[0], ratio ); divide_ratio_ratio( frame_pointer, frame->arg[0],
ratio );
dec_ref( ratio ); dec_ref( ratio );
dec_ref( one ); dec_ref( one );
} }
@ -615,7 +634,8 @@ struct cons_pointer lisp_divide( struct
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), frame_pointer ); ( "Cannot divide: not a number" ),
frame_pointer );
break; break;
} }

14
src/arith/peano.h
View file

@ -23,7 +23,8 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Multiply an indefinite number of numbers together * Multiply an indefinite number of numbers together
@ -32,7 +33,9 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer struct cons_pointer
lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_multiply( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Subtract one number from another. * Subtract one number from another.
@ -41,7 +44,9 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer struct cons_pointer
lisp_subtract( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_subtract( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Divide one number by another. * Divide one number by another.
@ -50,7 +55,8 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
#ifdef __cplusplus #ifdef __cplusplus
} }

19
src/arith/ratio.c
View file

@ -61,10 +61,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
if ( ratiop( arg ) ) { if ( ratiop( arg ) ) {
int64_t ddrv = int64_t ddrv =
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload. pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
integer.value, drrv = payload.integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload. pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
integer.value, gcd = greatest_common_divisor( ddrv, drrv ); payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) { if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) { if ( drrv / gcd == 1 ) {
@ -190,7 +190,8 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
throw_exception( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to add_integer_ratio" ), ( "Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg, make_cons( intarg,
make_cons( ratarg, NIL ) ) ), make_cons( ratarg,
NIL ) ) ),
frame_pointer ); frame_pointer );
} }
@ -206,10 +207,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer i = make_ratio( frame_pointer, struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.ratio. pointer2cell( arg2 ).payload.
divisor, ratio.divisor,
pointer2cell( arg2 ).payload.ratio. pointer2cell( arg2 ).payload.
dividend ), result = ratio.dividend ), result =
multiply_ratio_ratio( frame_pointer, arg1, i ); multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i ); dec_ref( i );

1
src/arith/real.c
View file

@ -9,6 +9,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "dump.h"
#include "read.h" #include "read.h"
/** /**

11
src/memory/dump.c
View file

@ -93,10 +93,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case RATIOTV: case RATIOTV:
fwprintf( output, 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:
fwprintf( output, L"\t\tInput stream\n" ); fwprintf( output, L"\t\tInput stream\n" );
@ -112,7 +112,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
break; break;
case VECTORPOINTTV:{ case VECTORPOINTTV:{
struct vector_space_object *vso = cell.payload.vectorp.address; struct vector_space_object *vso = cell.payload.vectorp.address;
fwprintf( output, L"\t\tVector space object of type %4.4s, payload size %d bytes\n", fwprintf( output,
L"\t\tVector space object of type %4.4s, payload size %d bytes\n",
vso->header.tag, vso->header.size ); vso->header.tag, vso->header.size );
} }
break; break;

72
src/memory/stack.c
View file

@ -30,12 +30,21 @@
*/ */
struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
struct stack_frame *result = NULL; struct stack_frame *result = NULL;
fputws
( L"get_stack_frame: about to get a pointer to the vector space object\n",
stderr );
struct vector_space_object *vso = struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address; pointer2cell( pointer ).payload.vectorp.address;
fputws( L"get_stack_frame: got a pointer, about to test it\n", stderr );
if ( vectorpointp( pointer ) ) { // && stackframep(vso)){
fputws( L"get_stack_frame: pointer is good, about to set the result\n",
stderr );
if (vectorpointp(pointer) && stackframep(vso))
{
result = ( struct stack_frame * ) &( vso->payload ); result = ( struct stack_frame * ) &( vso->payload );
fputws( L"get_stack_frame: all good, returning\n", stderr );
} else {
fputws( L"get_stack_frame: fail, returning NULL\n", stderr );
} }
return result; return result;
@ -48,14 +57,21 @@ struct stack_frame * get_stack_frame(struct cons_pointer pointer) {
* @return the new frame, or NULL if memory is exhausted. * @return the new frame, or NULL if memory is exhausted.
*/ */
struct cons_pointer make_empty_frame( struct cons_pointer previous ) { struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer result = make_vso(STACKFRAMETAG, sizeof(struct stack_frame)); fputws( L"Entering make_empty_frame\n", stderr );
struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
if ( !nilp( result ) ) { if ( !nilp( result ) ) {
fputws( L"make_empty_frame: about to call get_stack_frame\n", stderr );
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
/* /*
* TODO: later, pop a frame off a free-list of stack frames * TODO: later, pop a frame off a free-list of stack frames
*/ */
fwprintf( stderr,
L"make_empty_frame: about to set previous to %4.4s\n",
pointer2cell( previous ).tag );
frame->previous = previous; frame->previous = previous;
fputws( L"make_empty_frame: about to call inc_ref\n", stderr );
inc_ref( previous ); inc_ref( previous );
/* /*
@ -66,10 +82,13 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
frame->function = NIL; frame->function = NIL;
frame->args = 0; frame->args = 0;
fputws( L"make_empty_frame: about to initialise arg registers\n",
stderr );
for ( int i = 0; i < args_in_frame; i++ ) { for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( frame, i, NIL ); set_reg( frame, i, NIL );
} }
} }
fputws( L"Leaving make_empty_frame\n", stderr );
return result; return result;
} }
@ -85,16 +104,19 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env ) { struct cons_pointer env ) {
fputws( L"Entering make_stack_frame\n", stderr );
struct cons_pointer result = make_empty_frame( previous ); struct cons_pointer result = make_empty_frame( previous );
if (nilp(result)) if ( nilp( result ) ) {
{
/* i.e. out of memory */ /* i.e. out of memory */
result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous); result =
make_exception( c_string_to_lisp_string( "Memory exhausted." ),
previous );
} else { } else {
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
for ( frame->args = 0; frame->args < args_in_frame && consp( args ); frame->args++ ) { for ( frame->args = 0; frame->args < args_in_frame && consp( args );
frame->args++ ) {
/* iterate down the arg list filling in the arg slots in the /* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args, * frame. When there are no more slots, if there are still args,
* stash them on more */ * stash them on more */
@ -110,13 +132,17 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
inc_ref( arg_frame_pointer ); inc_ref( arg_frame_pointer );
if ( nilp( arg_frame_pointer ) ) { if ( nilp( arg_frame_pointer ) ) {
result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous); result =
make_exception( c_string_to_lisp_string
( "Memory exhausted." ), previous );
break; break;
} else { } else {
struct stack_frame *arg_frame = get_stack_frame( arg_frame_pointer ); struct stack_frame *arg_frame =
get_stack_frame( arg_frame_pointer );
set_reg( arg_frame, 0, cell.payload.cons.car ); set_reg( arg_frame, 0, cell.payload.cons.car );
struct cons_pointer val = lisp_eval( arg_frame, arg_frame_pointer, env ); struct cons_pointer val =
lisp_eval( arg_frame, arg_frame_pointer, env );
if ( exceptionp( val ) ) { if ( exceptionp( val ) ) {
result = val; result = val;
break; break;
@ -132,16 +158,18 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
if ( consp( args ) ) { if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */ /* if we still have args, eval them and stick the values on `more` */
struct cons_pointer more = eval_forms( get_stack_frame(previous), previous, args, env ); struct cons_pointer more =
eval_forms( get_stack_frame( previous ), previous, args,
env );
frame->more = more; frame->more = more;
inc_ref( more ); inc_ref( more );
} }
#ifdef DEBUG #ifdef DEBUG
dump_frame( stderr, result ); dump_frame( stderr, result );
#endif #endif
} }
} }
fputws( L"Leaving make_stack_frame\n", stderr );
return result; return result;
} }
@ -157,16 +185,20 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer make_special_frame( struct cons_pointer previous, struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env ) { struct cons_pointer env ) {
fputws( L"Entering make_special_frame\n", stderr );
struct cons_pointer result = make_empty_frame( previous ); struct cons_pointer result = make_empty_frame( previous );
if (nilp(result)) if ( nilp( result ) ) {
{
/* i.e. out of memory */ /* i.e. out of memory */
result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous); result =
make_exception( c_string_to_lisp_string( "Memory exhausted." ),
previous );
} else { } else {
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
for ( frame->args = 0; frame->args < args_in_frame && !nilp( args ); frame->args++ ) { for ( frame->args = 0; frame->args < args_in_frame && !nilp( args );
frame->args++ ) {
/* iterate down the arg list filling in the arg slots in the /* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args, * frame. When there are no more slots, if there are still args,
* stash them on more */ * stash them on more */
@ -181,12 +213,12 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
frame->more = args; frame->more = args;
inc_ref( args ); inc_ref( args );
} }
#ifdef DEBUG #ifdef DEBUG
dump_frame( stderr, result ); dump_frame( stderr, result );
#endif #endif
} }
} }
fputws( L"Leaving make_special_frame\n", stderr );
return result; return result;
} }
@ -239,9 +271,11 @@ void dump_stack_trace(FILE * output, struct cons_pointer pointer) {
if ( exceptionp( pointer ) ) { if ( exceptionp( pointer ) ) {
print( output, pointer2cell( pointer ).payload.exception.message ); print( output, pointer2cell( pointer ).payload.exception.message );
fwprintf( output, L"\n" ); fwprintf( output, L"\n" );
dump_stack_trace(output, pointer2cell(pointer).payload.exception.frame); dump_stack_trace( output,
pointer2cell( pointer ).payload.exception.frame );
} else { } else {
while (vectorpointp(pointer) && stackframep(pointer_to_vso(pointer))) { while ( vectorpointp( pointer )
&& stackframep( pointer_to_vso( pointer ) ) ) {
dump_frame( output, pointer ); dump_frame( output, pointer );
pointer = get_stack_frame( pointer )->previous; pointer = get_stack_frame( pointer )->previous;
} }

16
src/memory/vectorspace.c
View file

@ -30,12 +30,19 @@
* NOTE that `tag` should be the vector-space tag of the particular type of * NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`. * vector-space object, NOT `VECTORPOINTTAG`.
*/ */
struct cons_pointer make_vec_pointer( char * tag, struct vector_space_object * address ) { struct cons_pointer make_vec_pointer( char *tag,
struct vector_space_object *address ) {
fputws( L"Entered make_vec_pointer\n", stderr );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
fwprintf( stderr,
L"make_vec_pointer: allocated cell, about to write tag '%s'\n",
tag );
strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 ); strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 );
fputws( L"make_vec_pointer: tag written, about to set pointer address\n",
stderr );
cell.payload.vectorp.address = address; cell.payload.vectorp.address = address;
fputws( L"make_vec_pointer: all good, returning\n", stderr );
return pointer; return pointer;
} }
@ -48,15 +55,18 @@ struct cons_pointer make_vec_pointer( char * tag, struct vector_space_object * a
* Returns NIL if the vector could not be allocated due to memory exhaustion. * Returns NIL if the vector could not be allocated due to memory exhaustion.
*/ */
struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
fputws( L"Entered make_vso\n", stderr );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size; int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
/* Pad size to 64 bit words. This is intended to promote access efficiancy /* Pad size to 64 bit words. This is intended to promote access efficiancy
* on 64 bit machines but may just be voodoo coding */ * on 64 bit machines but may just be voodoo coding */
uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 ); uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
fputws( L"make_vso: about to malloc\n", stderr );
struct vector_space_object *vso = malloc( padded ); struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) { if ( vso != NULL ) {
fwprintf( stderr, L"make_vso: about to write tag '%s'\n", tag );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
vso->header.vecp = make_vec_pointer( tag, vso ); vso->header.vecp = make_vec_pointer( tag, vso );
vso->header.size = payload_size; vso->header.size = payload_size;
@ -73,5 +83,7 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
result = vso->header.vecp; result = vso->header.vecp;
} }
fputws( L"make_vso: all good, returning\n", stderr );
return result; return result;
} }

4
src/ops/equal.c
View file

@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
&& ( equal( cell_a->payload.string.cdr, && ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr ) cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string. && end_of_string( cell_b->payload.
cdr ) ) ); string.cdr ) ) );
break; break;
case INTEGERTV: case INTEGERTV:
result = result =

120
src/ops/lispops.c
View file

@ -111,13 +111,15 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* and this `env`, and return a list of their values. If the arg passed as * and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil. * `list` is not in fact a list, return nil.
*/ */
struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ) { struct cons_pointer env ) {
/* TODO: refactor. This runs up the C stack. */ /* TODO: refactor. This runs up the C stack. */
return consp( list ) ? return consp( list ) ?
make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
eval_forms( frame, frame_pointer, c_cdr( list ), env ) ) : NIL; eval_forms( frame, frame_pointer, c_cdr( list ),
env ) ) : NIL;
} }
/** /**
@ -126,7 +128,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer f
* (oblist) * (oblist)
*/ */
struct cons_pointer struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return oblist; return oblist;
} }
@ -159,7 +162,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer
lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return make_lambda( frame->arg[0], compose_body( frame ) ); return make_lambda( frame->arg[0], compose_body( frame ) );
} }
@ -170,7 +174,8 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struc
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return make_nlambda( frame->arg[0], compose_body( frame ) ); return make_nlambda( frame->arg[0], compose_body( frame ) );
} }
@ -188,8 +193,8 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
* 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, struct cons_pointer frame_pointer, eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer env ) { struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
fwprintf( stderr, L"eval_lambda called\n" ); fwprintf( stderr, L"eval_lambda called\n" );
@ -216,7 +221,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct co
struct cons_pointer vals = frame->more; struct cons_pointer vals = frame->more;
for ( int i = args_in_frame - 1; i >= 0; i-- ) { for ( int i = args_in_frame - 1; i >= 0; i-- ) {
struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[i], env ); struct cons_pointer val =
eval_form( frame, frame_pointer, frame->arg[i], env );
if ( nilp( val ) && nilp( vals ) ) { /* nothing */ if ( nilp( val ) && nilp( vals ) ) { /* nothing */
} else { } else {
@ -248,7 +254,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct co
* @return the result of evaluating the function with its arguments. * @return the result of evaluating the function with its arguments.
*/ */
struct cons_pointer struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
/* construct a child frame and within it evaluate the first argument - the /* construct a child frame and within it evaluate the first argument - the
@ -258,7 +265,8 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
struct stack_frame *fn_frame = get_stack_frame( fn_frame_pointer ); struct stack_frame *fn_frame = get_stack_frame( fn_frame_pointer );
set_reg( fn_frame, 0, c_car( frame->arg[0] ) ); set_reg( fn_frame, 0, c_car( frame->arg[0] ) );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, fn_frame_pointer, env ); struct cons_pointer fn_pointer =
lisp_eval( fn_frame, fn_frame_pointer, env );
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the /* if we're returning an exception, we should NOT free the
@ -286,7 +294,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
} else { } else {
struct stack_frame *next = get_stack_frame( next_pointer ); struct stack_frame *next = get_stack_frame( next_pointer );
result = ( *fn_cell.payload.function.executable ) ( next, next_pointer, env ); result =
( *fn_cell.payload.function.executable ) ( next,
next_pointer,
env );
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
} }
@ -316,7 +327,8 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
struct stack_frame *next = get_stack_frame(frame_pointer); struct stack_frame *next =
get_stack_frame( frame_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env ); result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
dec_ref( next_pointer ); dec_ref( next_pointer );
@ -332,8 +344,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
struct stack_frame *next = get_stack_frame(frame_pointer); struct stack_frame *next =
result = ( *fn_cell.payload.special.executable ) ( next, next_pointer, env ); get_stack_frame( frame_pointer );
result =
( *fn_cell.payload.special.executable ) ( next,
next_pointer,
env );
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
@ -393,7 +409,8 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
* If a special form, passes the cdr of s_expr to the special form as argument. * If a special form, passes the cdr of s_expr to the special form as argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
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] );
@ -456,7 +473,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* the second argument * the second argument
*/ */
struct cons_pointer struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
#ifdef DEBUG #ifdef DEBUG
fputws( L"Apply: ", stderr ); fputws( L"Apply: ", stderr );
dump_frame( stderr, frame_pointer ); dump_frame( stderr, frame_pointer );
@ -484,7 +502,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* this isn't at this stage checked) unevaluated. * this isn't at this stage checked) unevaluated.
*/ */
struct cons_pointer struct cons_pointer
lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return frame->arg[0]; return frame->arg[0];
} }
@ -499,7 +518,8 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* the namespace in so doing. `namespace` defaults to the value of `oblist`. * the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/ */
struct cons_pointer struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer namespace = struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2]; nilp( frame->arg[2] ) ? oblist : frame->arg[2];
@ -512,7 +532,8 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( "The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame_pointer ); make_cons( frame->arg[0], NIL ) ),
frame_pointer );
} }
return result; return result;
@ -529,13 +550,15 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c
* the namespace in so doing. `namespace` defaults to the value of `oblist`. * the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/ */
struct cons_pointer struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer namespace = struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2]; nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) { if ( symbolp( frame->arg[0] ) ) {
struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[1], env ); struct cons_pointer val =
eval_form( frame, frame_pointer, frame->arg[1], env );
deep_bind( frame->arg[0], val ); deep_bind( frame->arg[0], val );
result = val; result = val;
} else { } else {
@ -543,7 +566,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( "The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame_pointer ); make_cons( frame->arg[0], NIL ) ),
frame_pointer );
} }
return result; return result;
@ -558,7 +582,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s
* otherwise returns a new cons cell. * otherwise returns a new cons cell.
*/ */
struct cons_pointer struct cons_pointer
lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer car = frame->arg[0]; struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1]; struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result; struct cons_pointer result;
@ -582,7 +607,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) { if ( consp( frame->arg[0] ) ) {
@ -606,7 +632,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) { if ( consp( frame->arg[0] ) ) {
@ -629,7 +656,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c
* Returns the value associated with key in store, or NIL if not found. * Returns the value associated with key in store, or NIL if not found.
*/ */
struct cons_pointer struct cons_pointer
lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_assoc( frame->arg[0], frame->arg[1] ); return c_assoc( frame->arg[0], frame->arg[1] );
} }
@ -637,7 +665,8 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* (eq a b) * (eq a b)
* Returns T if a and b are pointers to the same object, else NIL * Returns T if a and b are pointers to the same object, else NIL
*/ */
struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} }
@ -647,7 +676,8 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer fram
* Returns T if a and b are pointers to structurally identical objects, else NIL * Returns T if a and b are pointers to structurally identical objects, else NIL
*/ */
struct cons_pointer struct cons_pointer
lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} }
@ -658,7 +688,8 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* is a read stream, then read from that stream, else stdin. * is a read stream, then read from that stream, else stdin.
*/ */
struct cons_pointer struct cons_pointer
lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
FILE *input = stdin; FILE *input = stdin;
if ( readp( frame->arg[0] ) ) { if ( readp( frame->arg[0] ) ) {
@ -698,7 +729,8 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) {
* (reverse sequence) * (reverse sequence)
* Return a sequence like this sequence but with the members in the reverse order. * Return a sequence like this sequence but with the members in the reverse order.
*/ */
struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return c_reverse( frame->arg[0] ); return c_reverse( frame->arg[0] );
} }
@ -711,7 +743,8 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer
* is a write stream, then print to that stream, else stdout. * is a write stream, then print to that stream, else stdout.
*/ */
struct cons_pointer struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
#ifdef DEBUG #ifdef DEBUG
fputws( L"Entering print\n", stderr ); fputws( L"Entering print\n", stderr );
#endif #endif
@ -741,7 +774,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* @return As a Lisp string, the tag of the object which is the argument. * @return As a Lisp string, the tag of the object which is the argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_type( frame->arg[0] ); return c_type( frame->arg[0] );
} }
@ -759,7 +793,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* argument. * argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer remaining = frame->more; struct cons_pointer remaining = frame->more;
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -786,7 +821,8 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* @return the value of the last form of the first successful clause. * @return the value of the last form of the first successful clause.
*/ */
struct cons_pointer struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
bool done = false; bool done = false;
@ -797,11 +833,14 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
if ( consp( clause_pointer ) ) { if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( clause_pointer ); struct cons_space_object cell = pointer2cell( clause_pointer );
result = eval_form( frame, frame_pointer, c_car( clause_pointer ), env ); result =
eval_form( frame, frame_pointer, c_car( clause_pointer ),
env );
if ( !nilp( result ) ) { if ( !nilp( result ) ) {
struct cons_pointer vals = struct cons_pointer vals =
eval_forms( frame, frame_pointer,c_cdr( clause_pointer ), env ); eval_forms( frame, frame_pointer, c_cdr( clause_pointer ),
env );
while ( consp( vals ) ) { while ( consp( vals ) ) {
result = c_car( vals ); result = c_car( vals );
@ -835,7 +874,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* 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, struct cons_pointer frame_pointer ) { throw_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ) {
fwprintf( stderr, L"\nERROR: " ); fwprintf( stderr, L"\nERROR: " );
print( stderr, message ); print( stderr, message );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -861,7 +901,9 @@ throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer
* If `message` is itself an exception, returns that instead. * If `message` is itself an exception, returns that instead.
*/ */
struct cons_pointer struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0]; struct cons_pointer message = frame->arg[0];
return exceptionp(message) ? message : make_exception(message, frame->previous); return exceptionp( message ) ? message : make_exception( message,
frame->previous );
} }

66
src/ops/lispops.h
View file

@ -60,7 +60,8 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* and this `env`, and return a list of their values. If the arg passed as * and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil. * `list` is not in fact a list, return nil.
*/ */
struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ); struct cons_pointer env );
@ -68,19 +69,24 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer f
/* /*
* special forms * special forms
*/ */
struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_eval( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Construct an interpretable function. * Construct an interpretable function.
@ -89,7 +95,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s
* @param lexpr the lambda expression to be interpreted; * @param lexpr the lambda expression to be interpreted;
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_lambda( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
@ -99,31 +106,42 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/* /*
* functions * functions
*/ */
struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_car( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_assoc( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
* Function: Get the Lisp type of the single argument. * Function: Get the Lisp type of the single argument.
@ -132,7 +150,8 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer
* @return As a Lisp string, the tag of the object which is the argument. * @return As a Lisp string, the tag of the object which is the argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
@ -146,7 +165,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* argument. * argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Special form: conditional. Each arg is expected to be a list; if the first * Special form: conditional. Each arg is expected to be a list; if the first
@ -158,7 +178,8 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* @return the value of the last form of the first successful clause. * @return the value of the last form of the first successful clause.
*/ */
struct cons_pointer struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Throw an exception. * Throw an exception.
@ -170,4 +191,5 @@ struct cons_pointer throw_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ); struct cons_pointer frame_pointer );
struct cons_pointer struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );

8
src/ops/print.c
View file

@ -133,8 +133,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case LAMBDATV: case LAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
make_cons( cell.payload.lambda.args, make_cons( cell.payload.lambda.args,
cell.payload. cell.payload.lambda.
lambda.body ) ) ); body ) ) );
break; break;
case NILTV: case NILTV:
fwprintf( output, L"nil" ); fwprintf( output, L"nil" );
@ -142,8 +142,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case NLAMBDATV: case NLAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ), print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
make_cons( cell.payload.lambda.args, make_cons( cell.payload.lambda.args,
cell.payload. cell.payload.lambda.
lambda.body ) ) ); body ) ) );
break; break;
case RATIOTV: case RATIOTV:
print( output, cell.payload.ratio.dividend ); print( output, cell.payload.ratio.dividend );

44
src/ops/read.c
View file

@ -34,8 +34,9 @@
*/ */
struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer, FILE * input, struct cons_pointer frame_pointer,
wint_t initial, bool seen_period ); FILE * input, wint_t initial,
bool seen_period );
struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer, FILE * input, struct cons_pointer frame_pointer, FILE * input,
wint_t initial ); wint_t initial );
@ -55,8 +56,9 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
* treating this initial character as the first character of the object * treating this initial character as the first character of the object
* representation. * representation.
*/ */
struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, FILE * input, struct cons_pointer read_continuation( struct stack_frame *frame,
wint_t initial ) { struct cons_pointer frame_pointer,
FILE * input, wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
wint_t c; wint_t c;
@ -76,15 +78,18 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
break; break;
case EOF: case EOF:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "End of input while reading" ), frame_pointer ); ( "End of input while reading" ),
frame_pointer );
break; break;
case '\'': case '\'':
result = result =
c_quote( read_continuation c_quote( read_continuation
( frame, frame_pointer, input, fgetwc( input ) ) ); ( frame, frame_pointer, input,
fgetwc( input ) ) );
break; break;
case '(': case '(':
result = read_list( frame, frame_pointer, input, fgetwc( input ) ); result =
read_list( frame, frame_pointer, input, fgetwc( input ) );
break; break;
case '"': case '"':
result = read_string( input, fgetwc( input ) ); result = read_string( input, fgetwc( input ) );
@ -93,7 +98,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
wint_t next = fgetwc( input ); wint_t next = fgetwc( input );
ungetwc( next, input ); ungetwc( next, input );
if ( iswdigit( next ) ) { if ( iswdigit( next ) ) {
result = read_number( frame, frame_pointer, input, c, false ); result =
read_number( frame, frame_pointer, input, c,
false );
} else { } else {
result = read_symbol( input, c ); result = read_symbol( input, c );
} }
@ -104,12 +111,15 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
wint_t next = fgetwc( input ); wint_t next = fgetwc( input );
if ( iswdigit( next ) ) { if ( iswdigit( next ) ) {
ungetwc( next, input ); ungetwc( next, input );
result = read_number( frame, frame_pointer, input, c, true ); result =
read_number( frame, frame_pointer, input, c,
true );
} else if ( iswblank( next ) ) { } else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we /* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */ * really need to backtrack up a level. */
result = result =
read_continuation( frame, frame_pointer, input, fgetwc( input ) ); read_continuation( frame, frame_pointer, input,
fgetwc( input ) );
} else { } else {
read_symbol( input, c ); read_symbol( input, c );
} }
@ -117,7 +127,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
break; break;
default: default:
if ( iswdigit( c ) ) { if ( iswdigit( c ) ) {
result = read_number( frame, frame_pointer, input, c, false ); result =
read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) { } else if ( iswprint( c ) ) {
result = read_symbol( input, c ); result = read_symbol( input, c );
} else { } else {
@ -230,9 +241,13 @@ struct cons_pointer read_list( struct stack_frame *frame,
fwprintf( stderr, fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial ); L"read_list starting '%C' (%d)\n", initial, initial );
#endif #endif
struct cons_pointer car = read_continuation( frame, frame_pointer, input, struct cons_pointer car =
read_continuation( frame, frame_pointer, input,
initial ); initial );
result = make_cons( car, read_list( frame, frame_pointer, input, fgetwc( input ) ) ); result =
make_cons( car,
read_list( frame, frame_pointer, input,
fgetwc( input ) ) );
} }
#ifdef DEBUG #ifdef DEBUG
else { else {
@ -323,6 +338,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
*/ */
struct cons_pointer read( struct struct cons_pointer read( struct
stack_frame stack_frame
*frame, struct cons_pointer frame_pointer, FILE * input ) { *frame, struct cons_pointer frame_pointer,
FILE * input ) {
return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
} }

3
src/ops/read.h
View file

@ -15,7 +15,6 @@
* read the next object on this input stream and return a cons_pointer to it. * read the next object on this input stream and return a cons_pointer to it.
*/ */
struct cons_pointer read( struct stack_frame *frame, struct cons_pointer read( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer, FILE * input );
FILE * input );
#endif #endif

3
src/repl.c
View file

@ -40,7 +40,8 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
if ( frame != NULL ) { if ( frame != NULL ) {
set_reg( frame, 0, stream_pointer ); set_reg( frame, 0, stream_pointer );
struct cons_pointer result = lisp_read( frame, frame_pointer, oblist ); struct cons_pointer result =
lisp_read( frame, frame_pointer, oblist );
} }
dec_ref( frame_pointer ); dec_ref( frame_pointer );
} }