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

Whitespace only changes

Browse source
This commit is contained in:
Simon Brooke 2018-12-29 07:40:01 +00:00
parent 8231c74bae
commit 40e1f3ca64
17 changed files with 283 additions and 269 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/arith/peano.c
View file

@ -412,8 +412,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. to_long_int( cell.payload.ratio.
ratio.dividend ) ), dividend ) ),
cell.payload.ratio.divisor ); cell.payload.ratio.divisor );
break; break;
case REALTV: case REALTV:

20
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 ). pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload.
payload.integer.value, drrv = integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload.
payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); integer.value, gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) { if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) { if ( drrv / gcd == 1 ) {
@ -117,7 +117,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
lcm = least_common_multiple( dr1v, dr2v ), lcm = least_common_multiple( dr1v, dr2v ),
m1 = lcm / dr1v, m2 = lcm / dr2v; m1 = lcm / dr1v, m2 = lcm / dr2v;
debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm,
m1, m2 );
if ( dr1v == dr2v ) { if ( dr1v == dr2v ) {
r = make_ratio( frame_pointer, r = make_ratio( frame_pointer,
@ -201,11 +202,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. pointer2cell( arg2 ).payload.ratio.
ratio.divisor, divisor,
pointer2cell( arg2 ).payload. pointer2cell( arg2 ).payload.ratio.
ratio.dividend ), dividend ), result =
result =
multiply_ratio_ratio( frame_pointer, arg1, i ); multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i ); dec_ref( i );

20
src/debug.c
View file

@ -61,15 +61,15 @@ void debug_println( int level ) {
* `wprintf` adapted for the debug logging system. Print to stderr only * `wprintf` adapted for the debug logging system. Print to stderr only
* `verbosity` matches `level`. All other arguments as for `wprintf`. * `verbosity` matches `level`. All other arguments as for `wprintf`.
*/ */
void debug_printf( int level, wchar_t * format, ...) { void debug_printf( int level, wchar_t *format, ... ) {
#ifdef DEBUG #ifdef DEBUG
if ( level & verbosity ) { if ( level & verbosity ) {
fwide( stderr, 1 ); fwide( stderr, 1 );
va_list(args); va_list( args );
va_start(args, format); va_start( args, format );
vfwprintf(stderr, format, args); vfwprintf( stderr, format, args );
} }
#endif #endif
} }
/** /**
@ -92,7 +92,7 @@ void debug_print_object( struct cons_pointer pointer, int level ) {
void debug_dump_object( struct cons_pointer pointer, int level ) { void debug_dump_object( struct cons_pointer pointer, int level ) {
#ifdef DEBUG #ifdef DEBUG
if ( level & verbosity ) { if ( level & verbosity ) {
fwide( stderr, 1 ); fwide( stderr, 1 );
dump_object( stderr, pointer ); dump_object( stderr, pointer );
} }
#endif #endif

2
src/debug.h
View file

@ -27,7 +27,7 @@ extern int verbosity;
void debug_print( wchar_t *message, int level ); void debug_print( wchar_t *message, int level );
void debug_println( int level ); void debug_println( int level );
void debug_printf( int level, wchar_t * format, ...); void debug_printf( int level, wchar_t *format, ... );
void debug_print_object( struct cons_pointer pointer, int level ); void debug_print_object( struct cons_pointer pointer, int level );
void debug_dump_object( struct cons_pointer pointer, int level ); void debug_dump_object( struct cons_pointer pointer, int level );

68
src/init.c
View file

@ -93,45 +93,45 @@ int main( int argc, char *argv[] ) {
/* /*
* primitive function operations * primitive function operations
*/ */
bind_function( L"add", &lisp_add ); bind_function( L"add", &lisp_add );
bind_function( L"apply", &lisp_apply ); bind_function( L"apply", &lisp_apply );
bind_function( L"assoc", &lisp_assoc ); bind_function( L"assoc", &lisp_assoc );
bind_function( L"car", &lisp_car ); bind_function( L"car", &lisp_car );
bind_function( L"cdr", &lisp_cdr ); bind_function( L"cdr", &lisp_cdr );
bind_function( L"cons", &lisp_cons ); bind_function( L"cons", &lisp_cons );
bind_function( L"divide", &lisp_divide ); bind_function( L"divide", &lisp_divide );
bind_function( L"eq", &lisp_eq ); bind_function( L"eq", &lisp_eq );
bind_function( L"equal", &lisp_equal ); bind_function( L"equal", &lisp_equal );
bind_function( L"eval", &lisp_eval ); bind_function( L"eval", &lisp_eval );
bind_function( L"exception", &lisp_exception ); bind_function( L"exception", &lisp_exception );
bind_function( L"multiply", &lisp_multiply ); bind_function( L"multiply", &lisp_multiply );
bind_function( L"read", &lisp_read ); bind_function( L"read", &lisp_read );
bind_function( L"oblist", &lisp_oblist ); bind_function( L"oblist", &lisp_oblist );
bind_function( L"print", &lisp_print ); bind_function( L"print", &lisp_print );
bind_function( L"progn", &lisp_progn ); bind_function( L"progn", &lisp_progn );
bind_function( L"reverse", &lisp_reverse ); bind_function( L"reverse", &lisp_reverse );
bind_function( L"set", &lisp_set ); bind_function( L"set", &lisp_set );
bind_function( L"subtract", &lisp_subtract ); bind_function( L"subtract", &lisp_subtract );
bind_function( L"throw", &lisp_exception ); bind_function( L"throw", &lisp_exception );
bind_function( L"type", &lisp_type ); bind_function( L"type", &lisp_type );
bind_function( L"+", &lisp_add ); bind_function( L"+", &lisp_add );
bind_function( L"*", &lisp_multiply ); bind_function( L"*", &lisp_multiply );
bind_function( L"-", &lisp_subtract ); bind_function( L"-", &lisp_subtract );
bind_function( L"/", &lisp_divide ); bind_function( L"/", &lisp_divide );
bind_function( L"=", &lisp_equal ); bind_function( L"=", &lisp_equal );
/* /*
* primitive special forms * primitive special forms
*/ */
bind_special( L"cond", &lisp_cond ); bind_special( L"cond", &lisp_cond );
bind_special( L"lambda", &lisp_lambda ); bind_special( L"lambda", &lisp_lambda );
// bind_special( L"λ", &lisp_lambda ); // bind_special( L"λ", &lisp_lambda );
bind_special( L"nlambda", &lisp_nlambda ); bind_special( L"nlambda", &lisp_nlambda );
// bind_special( L"nλ", &lisp_nlambda ); // bind_special( L"nλ", &lisp_nlambda );
bind_special( L"progn", &lisp_progn ); bind_special( L"progn", &lisp_progn );
bind_special( L"quote", &lisp_quote ); bind_special( L"quote", &lisp_quote );
bind_special( L"set!", &lisp_set_shriek ); bind_special( L"set!", &lisp_set_shriek );
repl( stdin, stdout, stderr, show_prompt ); repl( stdin, stdout, stderr, show_prompt );

29
src/memory/conspage.c
View file

@ -66,7 +66,8 @@ void make_cons_page( ) {
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL; cell->payload.free.cdr = NIL;
debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" ); debug_printf( DEBUG_ALLOC,
L"Allocated special cell NIL\n" );
break; break;
case 1: case 1:
/* /*
@ -80,7 +81,8 @@ void make_cons_page( ) {
cell->payload.free.cdr = ( struct cons_pointer ) { cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1 0, 1
}; };
debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" ); debug_printf( DEBUG_ALLOC,
L"Allocated special cell T\n" );
break; break;
} }
} else { } else {
@ -98,8 +100,8 @@ void make_cons_page( ) {
initialised_cons_pages++; initialised_cons_pages++;
} else { } else {
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"FATAL: Failed to allocate memory for cons page %d\n", L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages ); initialised_cons_pages );
exit( 1 ); exit( 1 );
} }
@ -164,8 +166,9 @@ void free_cell( struct cons_pointer pointer ) {
case VECTORPOINTTV: case VECTORPOINTTV:
/* for vector space pointers, free the actual vector-space /* for vector space pointers, free the actual vector-space
* object. Dangerous! */ * object. Dangerous! */
debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n", debug_printf( DEBUG_ALLOC,
cell->payload.vectorp.address ); L"About to free vector-space object at %ld\n",
cell->payload.vectorp.address );
//free( ( void * ) cell->payload.vectorp.address ); //free( ( void * ) cell->payload.vectorp.address );
break; break;
@ -179,13 +182,13 @@ void free_cell( struct cons_pointer pointer ) {
freelist = pointer; freelist = pointer;
} else { } else {
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset ); cell->count, pointer.page, pointer.offset );
} }
} else { } else {
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset ); pointer.page, pointer.offset );
} }
} }
@ -216,8 +219,8 @@ struct cons_pointer allocate_cell( char *tag ) {
cell->payload.cons.cdr = NIL; cell->payload.cons.cdr = NIL;
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"Allocated cell of type '%s' at %d, %d \n", tag, L"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset ); result.page, result.offset );
} else { } else {
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
} }
@ -239,6 +242,6 @@ void initialise_cons_pages( ) {
conspageinitihasbeencalled = true; conspageinitihasbeencalled = true;
} else { } else {
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
} }
} }

6
src/memory/consspaceobject.c
View file

@ -183,10 +183,10 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
* cell->payload.string.cdr = tsil */ * cell->payload.string.cdr = tsil */
cell->payload.string.cdr.offset = tail.offset; cell->payload.string.cdr.offset = tail.offset;
} else { } else {
// TODO: should throw an exception! // TODO: should throw an exception!
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %s can be prepended to %s\n", L"Warning: only NIL and %s can be prepended to %s\n",
tag, tag ); tag, tag );
} }
return pointer; return pointer;

25
src/memory/dump.c
View file

@ -67,8 +67,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
cell.payload.cons.car.offset, cell.payload.cons.car.offset,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count ); cell.payload.cons.cdr.offset, cell.count );
print( output, pointer); print( output, pointer );
fputws( L"\n", output); fputws( L"\n", output );
break; break;
case EXCEPTIONTV: case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " ); fwprintf( output, L"\t\tException cell: " );
@ -89,7 +89,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
print( output, cell.payload.lambda.args ); print( output, cell.payload.lambda.args );
fwprintf( output, L";\n\t\t\tbody: " ); fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body ); print( output, cell.payload.lambda.body );
fputws( L"\n", output); fputws( L"\n", output );
break; break;
case NILTV: case NILTV:
break; break;
@ -98,15 +98,15 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
print( output, cell.payload.lambda.args ); print( output, cell.payload.lambda.args );
fwprintf( output, L";\n\t\t\tbody: " ); fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body ); print( output, cell.payload.lambda.body );
fputws( L"\n", output); fputws( L"\n", output );
break; break;
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 ). pointer2cell( cell.payload.ratio.dividend ).payload.
payload.integer.value, integer.value,
pointer2cell( cell.payload.ratio.divisor ). pointer2cell( cell.payload.ratio.divisor ).payload.
payload.integer.value, cell.count ); integer.value, cell.count );
break; break;
case READTV: case READTV:
fwprintf( output, L"\t\tInput stream\n" ); fwprintf( output, L"\t\tInput stream\n" );
@ -130,10 +130,11 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
struct vector_space_object *vso = cell.payload.vectorp.address; struct vector_space_object *vso = cell.payload.vectorp.address;
fwprintf( output, fwprintf( output,
L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n",
&vso->header.tag.bytes, vso->header.tag.value, vso->header.size ); &vso->header.tag.bytes, vso->header.tag.value,
if (stackframep(vso)) { vso->header.size );
dump_frame(output, pointer); if ( stackframep( vso ) ) {
} dump_frame( output, pointer );
}
switch ( vso->header.tag.value ) { switch ( vso->header.tag.value ) {
case STACKFRAMETV: case STACKFRAMETV:
dump_frame( output, pointer ); dump_frame( output, pointer );

65
src/memory/stack.c
View file

@ -26,15 +26,15 @@
#include "stack.h" #include "stack.h"
#include "vectorspace.h" #include "vectorspace.h"
void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) { void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) {
debug_printf(DEBUG_STACK, L"Setting register %d to ", reg); debug_printf( DEBUG_STACK, L"Setting register %d to ", reg );
debug_print_object(value, DEBUG_STACK); debug_print_object( value, DEBUG_STACK );
debug_println(DEBUG_STACK); debug_println( DEBUG_STACK );
frame->arg[reg++] = value; frame->arg[reg++] = value;
inc_ref(value); inc_ref( value );
if (reg > frame->args) { if ( reg > frame->args ) {
frame->args = reg; frame->args = reg;
} }
} }
@ -49,8 +49,8 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
if ( vectorpointp( pointer ) && stackframep( vso ) ) { if ( vectorpointp( pointer ) && stackframep( vso ) ) {
result = ( struct stack_frame * ) &( vso->payload ); result = ( struct stack_frame * ) &( vso->payload );
debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n", debug_printf( DEBUG_STACK,
result ); L"get_stack_frame: all good, returning %p\n", result );
} else { } else {
debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK ); debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK );
} }
@ -97,7 +97,7 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
} }
} }
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC); debug_dump_object( result, DEBUG_ALLOC );
return result; return result;
} }
@ -124,7 +124,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
} else { } else {
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && consp( args )) { while ( frame->args < args_in_frame && consp( 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 */
@ -136,19 +136,21 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
* processor to be evaled in parallel; but see notes here: * processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/ */
struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env); struct cons_pointer val =
if ( exceptionp( val ) ) { eval_form( frame, result, cell.payload.cons.car, env );
result = val; if ( exceptionp( val ) ) {
break; result = val;
} else { break;
debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args); } else {
debug_print_object(cell.payload.cons.car, DEBUG_STACK); debug_printf( DEBUG_STACK, L"Setting argument %d to ",
set_reg( frame, frame->args, val ); frame->args );
} debug_print_object( cell.payload.cons.car, DEBUG_STACK );
set_reg( frame, frame->args, val );
args = cell.payload.cons.cdr;
} }
args = cell.payload.cons.cdr;
}
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` */
@ -190,7 +192,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
} else { } else {
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && !nilp( args )) { while ( frame->args < args_in_frame && !nilp( 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 */
@ -240,7 +242,7 @@ 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 ) { if ( frame != NULL ) {
fwprintf( output, L"Stack frame with %d arguments:\n", frame->args); fwprintf( output, L"Stack frame with %d arguments:\n", frame->args );
for ( int arg = 0; arg < frame->args; arg++ ) { for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] ); struct cons_space_object cell = pointer2cell( frame->arg[arg] );
@ -252,12 +254,11 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
print( output, frame->arg[arg] ); print( output, frame->arg[arg] );
fputws( L"\n", output ); fputws( L"\n", output );
} }
if (!nilp(frame->more)) if ( !nilp( frame->more ) ) {
{ fputws( L"More: \t", output );
fputws( L"More: \t", output ); print( output, frame->more );
print( output, frame->more ); fputws( L"\n", output );
fputws( L"\n", output ); }
}
} }
} }

2
src/memory/stack.h
View file

@ -41,7 +41,7 @@
*/ */
//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);} //#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);}
void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value); void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value );
struct stack_frame *get_stack_frame( struct cons_pointer pointer ); struct stack_frame *get_stack_frame( struct cons_pointer pointer );

26
src/memory/vectorspace.c
View file

@ -36,11 +36,12 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
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 );
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: tag written, about to set pointer address to %p\n", L"make_vec_pointer: tag written, about to set pointer address to %p\n",
address ); address );
cell->payload.vectorp.address = address; cell->payload.vectorp.address = address;
debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", debug_printf( DEBUG_ALLOC,
cell->payload.vectorp.address ); L"make_vec_pointer: all good, returning pointer to %p\n",
cell->payload.vectorp.address );
debug_dump_object( pointer, DEBUG_ALLOC ); debug_dump_object( pointer, DEBUG_ALLOC );
@ -67,8 +68,8 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
if ( vso != NULL ) { if ( vso != NULL ) {
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"make_vso: about to write tag '%s' into vso at %p\n", tag, L"make_vso: about to write tag '%s' into vso at %p\n",
vso ); tag, vso );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
result = make_vec_pointer( vso ); result = make_vec_pointer( vso );
debug_dump_object( result, DEBUG_ALLOC ); debug_dump_object( result, DEBUG_ALLOC );
@ -79,18 +80,19 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n", L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n",
&vso->header.tag.bytes, total_size, vso->header.size, vso, &vso->header.tag.bytes, total_size, vso->header.size,
&vso->payload ); vso, &vso->payload );
if ( padded != total_size ) { if ( padded != total_size ) {
debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n", debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n",
total_size, padded ); total_size, padded );
} }
#endif #endif
} }
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n", debug_printf( DEBUG_ALLOC,
pointer2cell( result ).payload.vectorp.address ); L"make_vso: all good, returning pointer to %p\n",
pointer2cell( result ).payload.vectorp.address );
#endif #endif
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. && end_of_string( cell_b->payload.string.
string.cdr ) ) ); cdr ) ) );
break; break;
case INTEGERTV: case INTEGERTV:
result = result =

34
src/ops/intern.c
View file

@ -57,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
struct cons_space_object entry = struct cons_space_object entry =
pointer2cell( pointer2cell( next ).payload.cons.car ); pointer2cell( pointer2cell( next ).payload.cons.car );
debug_print( L"Internedp: checking whether `", DEBUG_BIND ); debug_print( L"Internedp: checking whether `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND ); debug_print_object( key, DEBUG_BIND );
debug_print( L"` equals `", DEBUG_BIND ); debug_print( L"` equals `", DEBUG_BIND );
debug_print_object( entry.payload.cons.car, DEBUG_BIND ); debug_print_object( entry.payload.cons.car, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND ); debug_print( L"`\n", DEBUG_BIND );
if ( equal( key, entry.payload.cons.car ) ) { if ( equal( key, entry.payload.cons.car ) ) {
result = entry.payload.cons.car; result = entry.payload.cons.car;
} }
} }
} else { } else {
debug_print( L"`", DEBUG_BIND ); debug_print( L"`", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND ); debug_print_object( key, DEBUG_BIND );
debug_print( L"` is a ", DEBUG_BIND ); debug_print( L"` is a ", DEBUG_BIND );
debug_print_object( c_type( key ), DEBUG_BIND ); debug_print_object( c_type( key ), DEBUG_BIND );
debug_print( L", not a SYMB", DEBUG_BIND ); debug_print( L", not a SYMB", DEBUG_BIND );
} }
return result; return result;
@ -111,11 +111,11 @@ struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer struct cons_pointer
bind( struct cons_pointer key, struct cons_pointer value, bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) { struct cons_pointer store ) {
debug_print(L"Binding ", DEBUG_BIND); debug_print( L"Binding ", DEBUG_BIND );
debug_print_object(key, DEBUG_BIND); debug_print_object( key, DEBUG_BIND );
debug_print(L" to ", DEBUG_BIND); debug_print( L" to ", DEBUG_BIND );
debug_print_object(value, DEBUG_BIND); debug_print_object( value, DEBUG_BIND );
debug_println( DEBUG_BIND); debug_println( DEBUG_BIND );
return make_cons( make_cons( key, value ), store ); return make_cons( make_cons( key, value ), store );
} }
@ -127,11 +127,11 @@ bind( struct cons_pointer key, struct cons_pointer value,
*/ */
struct cons_pointer struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) { deep_bind( struct cons_pointer key, struct cons_pointer value ) {
debug_print( L"Entering deep_bind\n", DEBUG_BIND ); debug_print( L"Entering deep_bind\n", DEBUG_BIND );
oblist = bind( key, value, oblist ); oblist = bind( key, value, oblist );
debug_print( L"Leaving deep_bind\n", DEBUG_BIND ); debug_print( L"Leaving deep_bind\n", DEBUG_BIND );
return oblist; return oblist;
} }

189
src/ops/lispops.c
View file

@ -212,7 +212,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
names = c_cdr( names ); names = c_cdr( names );
} }
/* TODO: if there's more than `args_in_frame` arguments, bind those too. */ /* TODO: if there's more than `args_in_frame` arguments, bind those too. */
} else if ( symbolp( names ) ) { } else if ( symbolp( names ) ) {
/* if `names` is a symbol, rather than a list of symbols, /* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */ * then bind a list of the values of args to that symbol. */
@ -255,8 +255,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
debug_print(L"Entering c_apply\n", DEBUG_EVAL); debug_print( L"Entering c_apply\n", DEBUG_EVAL );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer fn_pointer = struct cons_pointer fn_pointer =
eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env ); eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env );
@ -264,103 +264,107 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( exceptionp( fn_pointer ) ) { if ( exceptionp( fn_pointer ) ) {
result = fn_pointer; result = fn_pointer;
} else { } else {
struct cons_space_object fn_cell = pointer2cell( fn_pointer ); struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] ); struct cons_pointer args = c_cdr( frame->arg[0] );
switch ( fn_cell.tag.value ) { switch ( fn_cell.tag.value ) {
case EXCEPTIONTV: case EXCEPTIONTV:
/* just pass exceptions straight back */ /* just pass exceptions straight back */
result = fn_pointer; result = fn_pointer;
break; break;
case FUNCTIONTV: case FUNCTIONTV:
{ {
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env ); make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer ); inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
struct stack_frame *next = get_stack_frame( next_pointer ); struct stack_frame *next =
get_stack_frame( next_pointer );
result = result =
( *fn_cell.payload.function.executable ) ( next, ( *fn_cell.payload.function.executable ) ( next,
next_pointer, next_pointer,
env ); env );
dec_ref( next_pointer );
}
}
break;
case LAMBDATV:
{
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 ) ) {
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 ); dec_ref( next_pointer );
} }
} }
} break;
break; case LAMBDATV:
case NLAMBDATV: {
{ struct cons_pointer exep = NIL;
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env ); make_stack_frame( frame_pointer, args, env );
inc_ref( next_pointer ); inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
struct stack_frame *next = struct stack_frame *next =
get_stack_frame( next_pointer ); get_stack_frame( next_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env ); 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 ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
result =
eval_lambda( fn_cell, next, next_pointer, env );
dec_ref( next_pointer ); dec_ref( next_pointer );
}
} }
} break;
break; case SPECIALTV:
case SPECIALTV: {
{ struct cons_pointer next_pointer =
struct cons_pointer next_pointer = make_special_frame( frame_pointer, args, env );
make_special_frame( frame_pointer, args, env ); inc_ref( next_pointer );
inc_ref( next_pointer ); if ( exceptionp( next_pointer ) ) {
if ( exceptionp( next_pointer ) ) { result = next_pointer;
result = next_pointer; } else {
} else { result =
result = ( *fn_cell.payload.special.
( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ), executable ) ( get_stack_frame( next_pointer ),
next_pointer, next_pointer, env );
env ); debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print(L"Special form returning: ", DEBUG_EVAL); debug_print_object( result, DEBUG_EVAL );
debug_print_object(result, DEBUG_EVAL); debug_println( DEBUG_EVAL );
debug_println(DEBUG_EVAL); dec_ref( next_pointer );
dec_ref( next_pointer ); }
} }
} break;
break; default:
default: {
{ int bs = sizeof( wchar_t ) * 1024;
int bs = sizeof(wchar_t) * 1024; wchar_t *buffer = malloc( bs );
wchar_t *buffer = malloc( bs ); memset( buffer, '\0', bs );
memset( buffer, '\0', bs ); swprintf( buffer, bs,
swprintf( buffer, bs, L"Unexpected cell with tag %d (%4.4s) in function position",
L"Unexpected cell with tag %d (%4.4s) in function position", fn_cell.tag.value, &fn_cell.tag.bytes[0] );
fn_cell.tag.value, &fn_cell.tag.bytes[0] ); struct cons_pointer message =
struct cons_pointer message = c_string_to_lisp_string( buffer );
c_string_to_lisp_string( buffer ); free( buffer );
free( buffer ); result = throw_exception( message, frame_pointer );
result = throw_exception( message, frame_pointer ); }
} }
}
} }
debug_print(L"c_apply: returning: ", DEBUG_EVAL); debug_print( L"c_apply: returning: ", DEBUG_EVAL );
debug_print_object(result, DEBUG_EVAL); debug_print_object( result, DEBUG_EVAL );
debug_println(DEBUG_EVAL); debug_println( DEBUG_EVAL );
return result; return result;
} }
@ -375,9 +379,8 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
for (int i = TAGLENGTH -1; i >= 0; i--) for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
{ result = make_string( ( wchar_t ) cell.tag.bytes[i], result );
result = make_string((wchar_t)cell.tag.bytes[i], result);
} }
return result; return result;

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( L"lambda" ), print( output, make_cons( c_string_to_lisp_symbol( L"lambda" ),
make_cons( cell.payload.lambda.args, make_cons( cell.payload.lambda.args,
cell.payload.lambda. cell.payload.
body ) ) ); lambda.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( L"nlambda" ), print( output, make_cons( c_string_to_lisp_symbol( L"nlambda" ),
make_cons( cell.payload.lambda.args, make_cons( cell.payload.lambda.args,
cell.payload.lambda. cell.payload.
body ) ) ); lambda.body ) ) );
break; break;
case RATIOTV: case RATIOTV:
print( output, cell.payload.ratio.dividend ); print( output, cell.payload.ratio.dividend );

25
src/ops/read.c
View file

@ -72,7 +72,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
if ( feof( input ) ) { if ( feof( input ) ) {
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer ); ( L"End of file while reading" ), frame_pointer );
} else { } else {
switch ( c ) { switch ( c ) {
case ';': case ';':
@ -137,9 +137,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
} else { } else {
result = result =
throw_exception( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( L"Unrecognised start of input character" ), ( L"Unrecognised start of input character" ),
make_string( c, NIL ) ), make_string( c, NIL ) ),
frame_pointer ); frame_pointer );
} }
break; break;
} }
@ -171,23 +171,24 @@ struct cons_pointer read_number( struct stack_frame *frame,
initial = fgetwc( input ); initial = fgetwc( input );
} }
debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial ); debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial,
initial );
for ( c = initial; iswdigit( c ) for ( c = initial; iswdigit( c )
|| c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) { if ( c == btowc( '.' ) ) {
if ( seen_period || dividend != 0 ) { if ( seen_period || dividend != 0 ) {
return throw_exception( c_string_to_lisp_string return throw_exception( c_string_to_lisp_string
( L"Malformed number: too many periods" ), ( L"Malformed number: too many periods" ),
frame_pointer ); frame_pointer );
} else { } else {
seen_period = true; seen_period = true;
} }
} else if ( c == btowc( '/' ) ) { } else if ( c == btowc( '/' ) ) {
if ( seen_period || dividend > 0 ) { if ( seen_period || dividend > 0 ) {
return throw_exception( c_string_to_lisp_string return throw_exception( c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ), ( L"Malformed number: dividend of rational must be integer" ),
frame_pointer ); frame_pointer );
} else { } else {
dividend = negative ? 0 - accumulator : accumulator; dividend = negative ? 0 - accumulator : accumulator;
@ -197,8 +198,8 @@ struct cons_pointer read_number( struct stack_frame *frame,
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
debug_printf( DEBUG_IO, debug_printf( DEBUG_IO,
L"Added character %c, accumulator now %ld\n", L"Added character %c, accumulator now %ld\n",
c, accumulator ); c, accumulator );
if ( seen_period ) { if ( seen_period ) {
places_of_decimals++; places_of_decimals++;
@ -244,7 +245,7 @@ struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( initial != ')' ) { if ( initial != ')' ) {
debug_printf( DEBUG_IO, debug_printf( DEBUG_IO,
L"read_list starting '%C' (%d)\n", initial, initial ); L"read_list starting '%C' (%d)\n", initial, initial );
struct cons_pointer car = struct cons_pointer car =
read_continuation( frame, frame_pointer, input, read_continuation( frame, frame_pointer, input,
initial ); initial );

25
src/repl.c
View file

@ -34,15 +34,18 @@
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
debug_print( L"Entered repl_read\n", DEBUG_REPL ); debug_print( L"Entered repl_read\n", DEBUG_REPL );
struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist ); struct cons_pointer frame_pointer =
debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL ); make_stack_frame( NIL, make_cons( stream_pointer, NIL ), oblist );
debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL );
debug_dump_object( frame_pointer, DEBUG_REPL ); debug_dump_object( frame_pointer, DEBUG_REPL );
if ( !nilp( frame_pointer ) ) { if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer ); inc_ref( frame_pointer );
result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist ); result =
lisp_read( get_stack_frame( frame_pointer ), frame_pointer,
oblist );
dec_ref( frame_pointer ); dec_ref( frame_pointer );
} }
debug_print( L"repl_read: returning\n", DEBUG_REPL ); debug_print( L"repl_read: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL ); debug_dump_object( result, DEBUG_REPL );
return result; return result;
@ -52,12 +55,12 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
* Dummy up a Lisp eval call with its own stack frame. * Dummy up a Lisp eval call with its own stack frame.
*/ */
struct cons_pointer repl_eval( struct cons_pointer input ) { struct cons_pointer repl_eval( struct cons_pointer input ) {
debug_print( L"Entered repl_eval\n", DEBUG_REPL ); debug_print( L"Entered repl_eval\n", DEBUG_REPL );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
result = eval_form( NULL, NIL, input, oblist ); result = eval_form( NULL, NIL, input, oblist );
debug_print( L"repl_eval: returning\n", DEBUG_REPL ); debug_print( L"repl_eval: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL ); debug_dump_object( result, DEBUG_REPL );
return result; return result;
@ -68,11 +71,11 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
*/ */
struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) { struct cons_pointer value ) {
debug_print( L"Entered repl_print\n", DEBUG_REPL ); debug_print( L"Entered repl_print\n", DEBUG_REPL );
debug_dump_object( value, DEBUG_REPL ); debug_dump_object( value, DEBUG_REPL );
struct cons_pointer result = struct cons_pointer result =
print( pointer2cell( stream_pointer ).payload.stream.stream, value ); print( pointer2cell( stream_pointer ).payload.stream.stream, value );
debug_print( L"repl_print: returning\n", DEBUG_REPL ); debug_print( L"repl_print: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL ); debug_dump_object( result, DEBUG_REPL );
return result; return result;
@ -88,7 +91,7 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
void void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) { bool show_prompt ) {
debug_print( L"Entered repl\n", DEBUG_REPL ); debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer input_stream = make_read_stream( in_stream ); struct cons_pointer input_stream = make_read_stream( in_stream );
inc_ref( input_stream ); inc_ref( input_stream );
@ -113,5 +116,5 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
} }
dec_ref( input ); dec_ref( input );
} }
debug_print( L"Leaving repl\n", DEBUG_REPL ); debug_print( L"Leaving repl\n", DEBUG_REPL );
} }