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

104
src/arith/peano.c
View file

@ -28,7 +28,9 @@
long double to_long_double( 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 );
@ -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
* 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 result;
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 );
break;
case RATIOTV:
result = add_integer_ratio( frame_pointer, arg1, arg2 );
result =
add_integer_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
@ -162,8 +167,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ),
frame_pointer );
( "Cannot add: not a number" ),
frame_pointer );
break;
}
break;
@ -173,7 +178,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
result = arg2;
break;
case INTEGERTV:
result = add_integer_ratio( frame_pointer, arg2, arg1 );
result =
add_integer_ratio( frame_pointer, arg2, arg1 );
break;
case RATIOTV:
result = add_ratio_ratio( frame_pointer, arg1, arg2 );
@ -185,8 +191,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ),
frame_pointer );
( "Cannot add: not a number" ),
frame_pointer );
break;
}
break;
@ -198,7 +204,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
default:
result = exceptionp( arg2 ) ? arg2 :
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
* 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 arg2 ) {
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 );
break;
case RATIOTV:
result = multiply_integer_ratio( frame_pointer, arg1, arg2 );
result =
multiply_integer_ratio( frame_pointer, arg1,
arg2 );
break;
case REALTV:
result =
@ -295,8 +305,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ),
frame_pointer );
( "Cannot multiply: not a number" ),
frame_pointer );
break;
}
break;
@ -306,10 +316,13 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
result = arg2;
break;
case INTEGERTV:
result = multiply_integer_ratio( frame_pointer, arg2, arg1 );
result =
multiply_integer_ratio( frame_pointer, arg2,
arg1 );
break;
case RATIOTV:
result = multiply_ratio_ratio( frame_pointer, arg1, arg2 );
result =
multiply_ratio_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
@ -318,8 +331,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ),
frame_pointer );
( "Cannot multiply: not a number" ),
frame_pointer );
}
break;
case REALTV:
@ -329,8 +342,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ),
frame_pointer );
( "Cannot multiply: not a number" ),
frame_pointer );
break;
}
}
@ -406,8 +419,8 @@ struct cons_pointer inverse( struct cons_pointer frame,
case RATIOTV:
result = make_ratio( frame,
make_integer( 0 -
to_long_int( cell.payload.ratio.
dividend ) ),
to_long_int( cell.payload.
ratio.dividend ) ),
cell.payload.ratio.divisor );
break;
case REALTV:
@ -453,9 +466,10 @@ struct cons_pointer lisp_subtract( struct
struct cons_pointer tmp =
make_ratio( frame_pointer, frame->arg[0],
make_integer( 1 ) );
inc_ref(tmp);
inc_ref( tmp );
result =
subtract_ratio_ratio( frame_pointer, tmp, frame->arg[1] );
subtract_ratio_ratio( frame_pointer, tmp,
frame->arg[1] );
dec_ref( tmp );
}
break;
@ -466,8 +480,8 @@ struct cons_pointer lisp_subtract( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot subtract: not a number" ),
frame_pointer );
( "Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
@ -480,9 +494,10 @@ struct cons_pointer lisp_subtract( struct
struct cons_pointer tmp =
make_ratio( frame_pointer, frame->arg[1],
make_integer( 1 ) );
inc_ref(tmp);
inc_ref( tmp );
result =
subtract_ratio_ratio( frame_pointer, frame->arg[0], tmp );
subtract_ratio_ratio( frame_pointer, frame->arg[0],
tmp );
dec_ref( tmp );
}
break;
@ -498,8 +513,8 @@ struct cons_pointer lisp_subtract( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot subtract: not a number" ),
frame_pointer );
( "Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
@ -510,7 +525,8 @@ struct cons_pointer lisp_subtract( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot subtract: not a number" ), frame_pointer );
( "Cannot subtract: not a number" ),
frame_pointer );
break;
}
@ -527,7 +543,7 @@ struct cons_pointer lisp_subtract( struct
*/
struct cons_pointer lisp_divide( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
@ -544,7 +560,8 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
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
* - but if not, we should dec_ref it. */
result = simplify_ratio( frame_pointer, unsimplified );
@ -558,7 +575,8 @@ struct cons_pointer lisp_divide( struct
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[0], one );
result =
divide_ratio_ratio( frame_pointer, ratio, frame->arg[1] );
divide_ratio_ratio( frame_pointer, ratio,
frame->arg[1] );
dec_ref( ratio );
}
break;
@ -569,8 +587,8 @@ struct cons_pointer lisp_divide( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ),
frame_pointer );
( "Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
@ -581,14 +599,15 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
struct cons_pointer one = make_integer( 1 );
inc_ref( one);
inc_ref( one );
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[1], one );
inc_ref(ratio);
inc_ref( ratio );
result =
divide_ratio_ratio( frame_pointer, frame->arg[0], ratio );
divide_ratio_ratio( frame_pointer, frame->arg[0],
ratio );
dec_ref( ratio );
dec_ref(one);
dec_ref( one );
}
break;
case RATIOTV:
@ -603,8 +622,8 @@ struct cons_pointer lisp_divide( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ),
frame_pointer );
( "Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
@ -615,7 +634,8 @@ struct cons_pointer lisp_divide( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), frame_pointer );
( "Cannot divide: not a number" ),
frame_pointer );
break;
}

14
src/arith/peano.h
View file

@ -23,7 +23,8 @@ extern "C" {
* @return a pointer to an integer or real.
*/
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
@ -32,7 +33,9 @@ extern "C" {
* @return a pointer to an integer or real.
*/
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.
@ -41,7 +44,9 @@ extern "C" {
* @return a pointer to an integer or real.
*/
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.
@ -50,7 +55,8 @@ extern "C" {
* @return a pointer to an integer or real.
*/
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
}

69
src/arith/ratio.c
View file

@ -61,10 +61,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
if ( ratiop( arg ) ) {
int64_t ddrv =
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload.
integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload.
integer.value, gcd = greatest_common_divisor( ddrv, drrv );
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
payload.integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) {
@ -78,8 +78,8 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame_pointer );
( "Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame_pointer );
}
return result;
@ -124,7 +124,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
#endif
if ( dr1v == dr2v ) {
r = make_ratio( frame_pointer,
r = make_ratio( frame_pointer,
make_integer( dd1v + dd2v ),
cell1.payload.ratio.divisor );
} else {
@ -132,8 +132,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
dr1vm = make_integer( dr1v * m1 ),
dd2vm = make_integer( dd2v * m2 ),
dr2vm = make_integer( dr2v * m2 ),
r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
r = add_ratio_ratio( frame_pointer, r1, r2 );
@ -144,17 +144,17 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
dec_ref( r2 );
}
result = simplify_ratio( frame_pointer, r );
result = simplify_ratio( frame_pointer, r );
if ( !eq( r, result ) ) {
dec_ref( r );
}
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
frame_pointer );
( "Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
frame_pointer );
}
#ifdef DEBUG
@ -181,17 +181,18 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame_pointer, intarg, one );
result = add_ratio_ratio( frame_pointer, ratio, ratarg );
result = add_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg,
make_cons( ratarg, NIL ) ) ),
frame_pointer );
( "Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg,
make_cons( ratarg,
NIL ) ) ),
frame_pointer );
}
return result;
@ -205,12 +206,12 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.ratio.
divisor,
pointer2cell( arg2 ).payload.ratio.
dividend ), result =
multiply_ratio_ratio( frame_pointer, arg1, i );
struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.
ratio.divisor,
pointer2cell( arg2 ).payload.
ratio.dividend ), result =
multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );
@ -248,7 +249,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer unsimplified =
make_ratio( frame_pointer, make_integer( ddrv ),
make_ratio( frame_pointer, make_integer( ddrv ),
make_integer( drrv ) );
result = simplify_ratio( frame_pointer, unsimplified );
@ -258,8 +259,8 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
} else {
result =
throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame_pointer );
( "Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame_pointer );
}
return result;
@ -278,15 +279,15 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame_pointer, intarg, one );
result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
} else {
result =
throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_integer_ratio" ),
frame_pointer );
( "Shouldn't happen: bad arg to multiply_integer_ratio" ),
frame_pointer );
}
return result;
@ -302,7 +303,7 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = inverse( frame_pointer, arg2 ),
result = add_ratio_ratio( frame_pointer, arg1, i );
result = add_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );
@ -328,8 +329,8 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
} else {
result =
throw_exception( c_string_to_lisp_string
( "Dividend and divisor of a ratio must be integers" ),
frame_pointer );
( "Dividend and divisor of a ratio must be integers" ),
frame_pointer );
}
#ifdef DEBUG
dump_object( stderr, result );

10
src/arith/ratio.h
View file

@ -14,15 +14,15 @@
struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg );
struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg );
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
@ -30,11 +30,11 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
cons_pointer arg1, struct
cons_pointer arg2 );
struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg );
struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );

1
src/arith/real.c
View file

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

26
src/memory/consspaceobject.c
View file

@ -89,21 +89,21 @@ struct cons_pointer make_cons( struct cons_pointer car,
* @param frame_pointer should be the pointer to the frame in which the exception occurred.
*/
struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ) {
struct cons_pointer result = NIL;
struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_pointer frame_pointer ) {
struct cons_pointer result = NIL;
struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
inc_ref( message );
inc_ref( frame_pointer);
cell->payload.exception.message = message;
cell->payload.exception.frame = frame_pointer;
inc_ref( message );
inc_ref( frame_pointer );
cell->payload.exception.message = message;
cell->payload.exception.frame = frame_pointer;
result = pointer;
result = pointer;
return result;
return result;
}
@ -113,7 +113,7 @@ struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer
make_function( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
@ -212,7 +212,7 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
struct cons_pointer
make_special( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame * frame,
struct cons_pointer, struct cons_pointer env ) ) {
struct cons_pointer, struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_space_object *cell = &pointer2cell( pointer );

8
src/memory/consspaceobject.h
View file

@ -421,10 +421,10 @@ struct vectorp_payload {
* tag. */
uint32_t value; /* the tag considered as a number */
} tag;
struct vector_space_object * address;
/* the address of the actual vector space
* object (TODO: will change when I actually
* implement vector space) */
struct vector_space_object *address;
/* the address of the actual vector space
* object (TODO: will change when I actually
* implement vector space) */
};
/**

23
src/memory/dump.c
View file

@ -72,7 +72,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
dump_stack_trace( output, pointer);
dump_stack_trace( output, pointer );
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
@ -93,10 +93,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case RATIOTV:
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:
fwprintf( output, L"\t\tInput stream\n" );
@ -110,11 +110,12 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
case VECTORPOINTTV: {
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",
vso->header.tag, vso->header.size);
}
break;
case VECTORPOINTTV:{
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",
vso->header.tag, vso->header.size );
}
break;
}
}

282
src/memory/stack.c
View file

@ -28,17 +28,26 @@
* get the actual stackframe object from this `pointer`, or NULL if
* `pointer` is not a stackframe pointer.
*/
struct stack_frame * get_stack_frame(struct cons_pointer pointer) {
struct stack_frame * result = NULL;
struct vector_space_object * vso =
pointer2cell(pointer).payload.vectorp.address;
struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
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 =
pointer2cell( pointer ).payload.vectorp.address;
fputws( L"get_stack_frame: got a pointer, about to test it\n", stderr );
if (vectorpointp(pointer) && stackframep(vso))
{
result = (struct stack_frame *) &(vso->payload);
}
if ( vectorpointp( pointer ) ) { // && stackframep(vso)){
fputws( L"get_stack_frame: pointer is good, about to set the result\n",
stderr );
return result;
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;
}
/**
@ -48,28 +57,38 @@ struct stack_frame * get_stack_frame(struct cons_pointer pointer) {
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer result = make_vso(STACKFRAMETAG, sizeof(struct stack_frame));
if (!nilp(result)) {
struct stack_frame *frame = get_stack_frame(result);
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
fputws( L"Entering make_empty_frame\n", stderr );
struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
if ( !nilp( result ) ) {
fputws( L"make_empty_frame: about to call get_stack_frame\n", stderr );
struct stack_frame *frame = get_stack_frame( result );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
frame->previous = previous;
inc_ref(previous);
fwprintf( stderr,
L"make_empty_frame: about to set previous to %4.4s\n",
pointer2cell( previous ).tag );
frame->previous = previous;
fputws( L"make_empty_frame: about to call inc_ref\n", stderr );
inc_ref( previous );
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
frame->more = NIL;
frame->function = NIL;
frame->args = 0;
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
frame->more = NIL;
frame->function = NIL;
frame->args = 0;
for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( frame, i, NIL );
fputws( L"make_empty_frame: about to initialise arg registers\n",
stderr );
for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( frame, i, NIL );
}
}
}
fputws( L"Leaving make_empty_frame\n", stderr );
return result;
}
@ -83,67 +102,76 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
* @return the new frame, or an exception if one occurred while building it.
*/
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
struct cons_pointer result = make_empty_frame( previous );
struct cons_pointer args,
struct cons_pointer env ) {
fputws( L"Entering make_stack_frame\n", stderr );
struct cons_pointer result = make_empty_frame( previous );
if (nilp(result))
{
/* i.e. out of memory */
result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous);
} else {
struct stack_frame * frame = get_stack_frame(result);
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( "Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
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
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( 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
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
/*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct cons_pointer arg_frame_pointer = make_empty_frame( result);
inc_ref(arg_frame_pointer);
/*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct cons_pointer arg_frame_pointer = make_empty_frame( result );
inc_ref( arg_frame_pointer );
if(nilp(arg_frame_pointer)) {
result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous);
break;
} else {
struct stack_frame *arg_frame = get_stack_frame( arg_frame_pointer );
set_reg( arg_frame, 0, cell.payload.cons.car );
if ( nilp( arg_frame_pointer ) ) {
result =
make_exception( c_string_to_lisp_string
( "Memory exhausted." ), previous );
break;
} else {
struct stack_frame *arg_frame =
get_stack_frame( arg_frame_pointer );
set_reg( arg_frame, 0, cell.payload.cons.car );
struct cons_pointer val = lisp_eval( arg_frame, arg_frame_pointer, env );
if ( exceptionp( val ) ) {
result = val;
break;
} else {
set_reg( frame, frame->args, val );
struct cons_pointer val =
lisp_eval( arg_frame, arg_frame_pointer, env );
if ( exceptionp( val ) ) {
result = val;
break;
} else {
set_reg( frame, frame->args, val );
}
dec_ref( arg_frame_pointer );
args = cell.payload.cons.cdr;
}
}
dec_ref(arg_frame_pointer);
args = cell.payload.cons.cdr;
}
}
if (!exceptionp(result)) {
if ( consp( args ) ) {
/* 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 );
frame->more = more;
inc_ref( more );
}
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
/* 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 );
frame->more = more;
inc_ref( more );
}
#ifdef DEBUG
dump_frame( stderr, result );
dump_frame( stderr, result );
#endif
}
}
}
fputws( L"Leaving make_stack_frame\n", stderr );
return result;
return result;
}
/**
@ -157,36 +185,40 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
struct cons_pointer result = make_empty_frame( previous );
fputws( L"Entering make_special_frame\n", stderr );
if (nilp(result))
{
/* i.e. out of memory */
result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous);
} else {
struct stack_frame * frame = get_stack_frame(result);
struct cons_pointer result = make_empty_frame( previous );
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
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( "Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
set_reg( frame, frame->args, cell.payload.cons.car );
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
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
args = cell.payload.cons.cdr;
}
if (!exceptionp(result)) {
if ( consp( args ) ) {
frame->more = args;
inc_ref( args );
}
set_reg( frame, frame->args, cell.payload.cons.car );
args = cell.payload.cons.cdr;
}
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
frame->more = args;
inc_ref( args );
}
#ifdef DEBUG
dump_frame( stderr, result );
dump_frame( stderr, result );
#endif
}
}
}
fputws( L"Leaving make_special_frame\n", stderr );
return result;
}
@ -215,37 +247,39 @@ void free_stack_frame( struct stack_frame *frame ) {
* @param frame_pointer the pointer to the frame
*/
void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame(frame_pointer);
struct stack_frame *frame = get_stack_frame( frame_pointer );
if (frame != NULL) {
for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
if ( frame != NULL ) {
for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
cell.tag.bytes[0],
cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
cell.count );
fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
cell.tag.bytes[0],
cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
cell.count );
print( output, frame->arg[arg] );
fputws( L"\n", output );
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
fputws( L"More: \t", output );
print( output, frame->more );
fputws( L"\n", output );
}
fputws( L"More: \t", output );
print( output, frame->more );
fputws( L"\n", output );
}
}
void dump_stack_trace(FILE * output, struct cons_pointer pointer) {
if (exceptionp(pointer)) {
print( output, pointer2cell(pointer).payload.exception.message );
fwprintf( output, L"\n" );
dump_stack_trace(output, pointer2cell(pointer).payload.exception.frame);
} else {
while (vectorpointp(pointer) && stackframep(pointer_to_vso(pointer))) {
dump_frame( output, pointer);
pointer = get_stack_frame(pointer)->previous;
void dump_stack_trace( FILE * output, struct cons_pointer pointer ) {
if ( exceptionp( pointer ) ) {
print( output, pointer2cell( pointer ).payload.exception.message );
fwprintf( output, L"\n" );
dump_stack_trace( output,
pointer2cell( pointer ).payload.exception.frame );
} else {
while ( vectorpointp( pointer )
&& stackframep( pointer_to_vso( pointer ) ) ) {
dump_frame( output, pointer );
pointer = get_stack_frame( pointer )->previous;
}
}
}
}
/**

8
src/memory/stack.h
View file

@ -41,19 +41,19 @@
*/
#define set_reg(frame,register,value)frame->arg[register]=value; inc_ref(value)
struct stack_frame * get_stack_frame(struct cons_pointer pointer);
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
struct cons_pointer make_empty_frame( struct cons_pointer previous );
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env );
struct cons_pointer args,
struct cons_pointer env );
void free_stack_frame( struct stack_frame *frame );
void dump_frame( FILE * output, struct cons_pointer pointer );
void dump_stack_trace(FILE * output, struct cons_pointer frame_pointer);
void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer );
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );

26
src/memory/vectorspace.c
View file

@ -30,12 +30,19 @@
* NOTE that `tag` should be the vector-space tag of the particular type of
* 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_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 );
fputws( L"make_vec_pointer: tag written, about to set pointer address\n",
stderr );
cell.payload.vectorp.address = address;
fputws( L"make_vec_pointer: all good, returning\n", stderr );
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.
*/
struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
fputws( L"Entered make_vso\n", stderr );
struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
/* Pad size to 64 bit words. This is intended to promote access efficiancy
* 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 );
if ( vso != NULL ) {
fwprintf( stderr, L"make_vso: about to write tag '%s'\n", tag );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
vso->header.vecp = make_vec_pointer( tag, vso );
vso->header.size = payload_size;
@ -65,13 +75,15 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
fwprintf( stderr,
L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld\n",
tag, total_size, payload_size );
if (padded != total_size){
fwprintf(stderr, L"\t\tPadded from %d to %d\n",
total_size, padded);
}
if ( padded != total_size ) {
fwprintf( stderr, L"\t\tPadded from %d to %d\n",
total_size, padded );
}
#endif
result = vso->header.vecp;
}
fputws( L"make_vso: all good, returning\n", stderr );
return result;
}

2
src/memory/vectorspace.h
View file

@ -61,7 +61,7 @@ struct vector_space_header {
};
struct vector_space_object {
struct vector_space_header header;
struct vector_space_header header;
char payload; /* we'll malloc `size` bytes for payload,
* `payload` is just the first of these.
* TODO: this is almost certainly not

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,
cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.
cdr ) ) );
&& end_of_string( cell_b->payload.
string.cdr ) ) );
break;
case INTEGERTV:
result =

194
src/ops/lispops.c
View file

@ -89,9 +89,9 @@ struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer result = NIL;
struct cons_pointer next_pointer = make_empty_frame( parent_pointer );
inc_ref( next_pointer);
inc_ref( next_pointer );
struct stack_frame * next = get_stack_frame(next_pointer);
struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form );
result = lisp_eval( next, next_pointer, env );
@ -100,7 +100,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
dec_ref(next_pointer);
dec_ref( next_pointer );
}
return result;
@ -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
* `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 env ) {
/* TODO: refactor. This runs up the C stack. */
/* TODO: refactor. This runs up the C stack. */
return consp( list ) ?
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)
*/
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;
}
@ -159,7 +162,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
* @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 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 ) );
}
@ -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.
*/
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 ) );
}
@ -188,8 +193,8 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
* Evaluate a lambda or nlambda expression.
*/
struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
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;
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;
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 */
} else {
@ -248,23 +254,25 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct co
* @return the result of evaluating the function with its arguments.
*/
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;
/* construct a child frame and within it evaluate the first argument - the
* argument in the function position. */
/* construct a child frame and within it evaluate the first argument - the
* argument in the function position. */
struct cons_pointer fn_frame_pointer = make_empty_frame( frame_pointer );
inc_ref( fn_frame_pointer);
struct stack_frame *fn_frame = get_stack_frame(fn_frame_pointer);
inc_ref( fn_frame_pointer );
struct stack_frame *fn_frame = get_stack_frame( fn_frame_pointer );
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 we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
dec_ref(fn_frame_pointer);
dec_ref( fn_frame_pointer );
}
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
@ -280,14 +288,17 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref(next_pointer);
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} 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 );
dec_ref(next_pointer);
result =
( *fn_cell.payload.function.executable ) ( next,
next_pointer,
env );
dec_ref( next_pointer );
}
}
break;
@ -296,48 +307,53 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
inc_ref(next_pointer);
if ( exceptionp( next_pointer ) ) {
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next = get_stack_frame(next_pointer);
result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref(next_pointer);
struct stack_frame *next = get_stack_frame( next_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
}
}
}
break;
case NLAMBDATV:
{
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
inc_ref(next_pointer);
if ( exceptionp( next_pointer ) ) {
make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next = get_stack_frame(frame_pointer);
result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref(next_pointer);
struct stack_frame *next =
get_stack_frame( frame_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
}
}
}
break;
case SPECIALTV:
{
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
inc_ref(next_pointer);
if ( exceptionp( next_pointer ) ) {
make_special_frame( frame_pointer, args, env );
inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next = get_stack_frame(frame_pointer);
result = ( *fn_cell.payload.special.executable ) ( next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref(next_pointer);
struct stack_frame *next =
get_stack_frame( frame_pointer );
result =
( *fn_cell.payload.special.executable ) ( next,
next_pointer,
env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
}
}
}
break;
default:
@ -355,7 +371,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
result = throw_exception( message, frame_pointer );
}
}
dec_ref(fn_frame_pointer);
dec_ref( fn_frame_pointer );
return result;
}
@ -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.
*/
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_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
*/
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
fputws( L"Apply: ", stderr );
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.
*/
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];
}
@ -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`.
*/
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 namespace =
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
( c_string_to_lisp_string
( "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;
@ -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`.
*/
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 namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
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 );
result = val;
} else {
@ -543,7 +566,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s
make_exception( make_cons
( c_string_to_lisp_string
( "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;
@ -558,7 +582,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s
* otherwise returns a new cons cell.
*/
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 cdr = frame->arg[1];
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.
*/
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;
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.
*/
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;
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.
*/
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] );
}
@ -637,7 +665,8 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* (eq a b)
* 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 ) {
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
*/
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;
}
@ -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.
*/
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;
if ( readp( frame->arg[0] ) ) {
@ -698,7 +729,8 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) {
* (reverse sequence)
* 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 ) {
return c_reverse( frame->arg[0] );
}
@ -711,9 +743,10 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer
* is a write stream, then print to that stream, else stdout.
*/
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
fputws(L"Entering print\n", stderr);
fputws( L"Entering print\n", stderr );
#endif
struct cons_pointer result = NIL;
FILE *output = stdout;
@ -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.
*/
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] );
}
@ -759,7 +793,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* argument.
*/
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 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.
*/
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;
bool done = false;
@ -797,11 +833,14 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
if ( consp( 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 ) ) {
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 ) ) {
result = c_car( vals );
@ -814,8 +853,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
done = true;
} else {
result = throw_exception( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ),
frame_pointer);
( "Arguments to `cond` must be lists" ),
frame_pointer );
}
}
/* TODO: if there are more than 8 clauses we need to continue into the
@ -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.
*/
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: " );
print( stderr, message );
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.
*/
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 : make_exception(message, frame->previous);
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 : make_exception( message,
frame->previous );
}

68
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
* `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 env );
@ -68,19 +69,24 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer f
/*
* 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 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
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
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
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.
@ -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 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 );
/**
@ -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.
*/
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 );
/*
* 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 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 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 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 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 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 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 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 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 );
/**
* 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.
*/
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.
*/
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
@ -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.
*/
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.
@ -167,7 +188,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* real `throw_exception`, which does, will be needed.
*/
struct cons_pointer throw_exception( struct cons_pointer message,
struct cons_pointer frame_pointer );
struct cons_pointer frame_pointer );
struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );

10
src/ops/print.c
View file

@ -119,7 +119,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
dump_stack_trace(output, pointer);
dump_stack_trace( output, pointer );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
@ -133,8 +133,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case LAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.
lambda.body ) ) );
cell.payload.lambda.
body ) ) );
break;
case NILTV:
fwprintf( output, L"nil" );
@ -142,8 +142,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case NLAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.
lambda.body ) ) );
cell.payload.lambda.
body ) ) );
break;
case RATIOTV:
print( output, cell.payload.ratio.dividend );

56
src/ops/read.c
View file

@ -34,10 +34,11 @@
*/
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer, FILE * input,
wint_t initial, bool seen_period );
struct cons_pointer frame_pointer,
FILE * input, wint_t initial,
bool seen_period );
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 );
struct cons_pointer read_string( FILE * input, wint_t initial );
struct cons_pointer read_symbol( FILE * input, 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
* representation.
*/
struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, FILE * input,
wint_t initial ) {
struct cons_pointer read_continuation( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
wint_t c;
@ -76,15 +78,18 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
break;
case EOF:
result = throw_exception( c_string_to_lisp_string
( "End of input while reading" ), frame_pointer );
( "End of input while reading" ),
frame_pointer );
break;
case '\'':
result =
c_quote( read_continuation
( frame, frame_pointer, input, fgetwc( input ) ) );
( frame, frame_pointer, input,
fgetwc( input ) ) );
break;
case '(':
result = read_list( frame, frame_pointer, input, fgetwc( input ) );
result =
read_list( frame, frame_pointer, input, fgetwc( input ) );
break;
case '"':
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 );
ungetwc( next, input );
if ( iswdigit( next ) ) {
result = read_number( frame, frame_pointer, input, c, false );
result =
read_number( frame, frame_pointer, input, c,
false );
} else {
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 );
if ( iswdigit( next ) ) {
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 ) ) {
/* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */
result =
read_continuation( frame, frame_pointer, input, fgetwc( input ) );
read_continuation( frame, frame_pointer, input,
fgetwc( input ) );
} else {
read_symbol( input, c );
}
@ -117,7 +127,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
break;
default:
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 ) ) {
result = read_symbol( input, c );
} else {
@ -140,8 +151,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
* input stream into a Lisp string, and then convert it to a number.
*/
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input,
struct cons_pointer frame_pointer,
FILE * input,
wint_t initial, bool seen_period ) {
struct cons_pointer result = NIL;
int64_t accumulator = 0;
@ -222,17 +233,21 @@ struct cons_pointer read_number( struct stack_frame *frame,
* left parenthesis.
*/
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input, wint_t initial ) {
struct cons_pointer frame_pointer,
FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
if ( initial != ')' ) {
#ifdef DEBUG
fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial );
#endif
struct cons_pointer car = read_continuation( frame, frame_pointer, input,
initial );
result = make_cons( car, read_list( frame, frame_pointer, input, fgetwc( input ) ) );
struct cons_pointer car =
read_continuation( frame, frame_pointer, input,
initial );
result =
make_cons( car,
read_list( frame, frame_pointer, input,
fgetwc( input ) ) );
}
#ifdef DEBUG
else {
@ -323,6 +338,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
*/
struct cons_pointer read( struct
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 ) );
}

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.
*/
struct cons_pointer read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input );
struct cons_pointer frame_pointer, FILE * input );
#endif

73
src/repl.c
View file

@ -31,64 +31,65 @@
* Dummy up a Lisp read call with its own stack frame.
*/
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if (!nilp(frame_pointer)) {
inc_ref(frame_pointer);
struct stack_frame *frame = get_stack_frame(frame_pointer);
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer );
struct stack_frame *frame = get_stack_frame( frame_pointer );
if (frame != NULL){
if ( frame != NULL ) {
set_reg( frame, 0, stream_pointer );
struct cons_pointer result = lisp_read( frame, frame_pointer, oblist );
set_reg( frame, 0, stream_pointer );
struct cons_pointer result =
lisp_read( frame, frame_pointer, oblist );
}
dec_ref( frame_pointer );
}
dec_ref(frame_pointer);
}
return result;
return result;
}
/**
* Dummy up a Lisp eval call with its own stack frame.
*/
struct cons_pointer repl_eval( struct cons_pointer input ) {
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if (!nilp(frame_pointer)) {
inc_ref(frame_pointer);
struct stack_frame *frame = get_stack_frame(frame_pointer);
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer );
struct stack_frame *frame = get_stack_frame( frame_pointer );
if (frame != NULL){
set_reg( frame, 0, input );
result = lisp_eval( frame, frame_pointer, oblist );
if ( frame != NULL ) {
set_reg( frame, 0, input );
result = lisp_eval( frame, frame_pointer, oblist );
}
dec_ref( frame_pointer );
}
dec_ref(frame_pointer);
}
return result;
return result;
}
/**
* Dummy up a Lisp print call with its own stack frame.
*/
struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) {
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if (!nilp(frame_pointer)) {
struct stack_frame *frame = get_stack_frame(frame_pointer);
struct cons_pointer value ) {
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if ( !nilp( frame_pointer ) ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if (frame != NULL){
set_reg( frame, 0, value );
set_reg( frame, 1, stream_pointer );
result = lisp_print( frame, frame_pointer, oblist );
free_stack_frame( frame );
if ( frame != NULL ) {
set_reg( frame, 0, value );
set_reg( frame, 1, stream_pointer );
result = lisp_print( frame, frame_pointer, oblist );
free_stack_frame( frame );
}
dec_ref( frame_pointer );
}
dec_ref(frame_pointer);
}
return result;
return result;
}
/**