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

Much progress! Half the unit tests pass.

Browse source
This commit is contained in:
Simon Brooke 2018-12-28 15:50:37 +00:00
parent 75abfb4050
commit e52ccce0eb
17 changed files with 296 additions and 253 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
src/arith/peano.c
View file

@ -89,7 +89,7 @@ long double to_long_double( struct cons_pointer arg ) {
debug_print( L"to_long_double( ", DEBUG_ARITH ); debug_print( L"to_long_double( ", DEBUG_ARITH );
debug_print_object( arg, DEBUG_ARITH ); debug_print_object( arg, DEBUG_ARITH );
fwprintf( stderr, L") => %lf\n", result ); debug_printf( DEBUG_ARITH, L") => %lf\n", result );
return result; return result;
} }
@ -166,7 +166,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -190,7 +190,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -203,7 +203,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
default: default:
result = exceptionp( arg2 ) ? arg2 : result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
} }
} }
@ -300,7 +300,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( L"Cannot multiply: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -326,7 +326,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( L"Cannot multiply: not a number" ),
frame_pointer ); frame_pointer );
} }
break; break;
@ -337,7 +337,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( L"Cannot multiply: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -473,7 +473,7 @@ struct cons_pointer lisp_subtract( struct
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -506,7 +506,7 @@ struct cons_pointer lisp_subtract( struct
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -518,7 +518,7 @@ struct cons_pointer lisp_subtract( struct
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -580,7 +580,7 @@ struct cons_pointer lisp_divide( struct
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -615,7 +615,7 @@ struct cons_pointer lisp_divide( struct
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -627,7 +627,7 @@ struct cons_pointer lisp_divide( struct
break; break;
default: default:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
} }

52
src/arith/ratio.c
View file

@ -78,7 +78,7 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
} else { } else {
result = result =
throw_exception( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to simplify_ratio" ), ( L"Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame_pointer ); arg ), frame_pointer );
} }
@ -97,13 +97,11 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer r, result; struct cons_pointer r, result;
#ifdef DEBUG debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH );
fputws( L"add_ratio_ratio( arg1 = ", stderr ); debug_print_object( arg1, DEBUG_ARITH );
print( stderr, arg1 ); debug_print( L"; arg2 = ", DEBUG_ARITH );
fputws( L"; arg2 = ", stderr ); debug_print_object( arg2, DEBUG_ARITH );
print( stderr, arg2 ); debug_print( L")\n", DEBUG_ARITH );
fputws( L")\n", stderr );
#endif
if ( ratiop( arg1 ) && ratiop( arg2 ) ) { if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
@ -119,9 +117,7 @@ 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;
#ifdef DEBUG debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
#endif
if ( dr1v == dr2v ) { if ( dr1v == dr2v ) {
r = make_ratio( frame_pointer, r = make_ratio( frame_pointer,
@ -151,17 +147,15 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
} else { } else {
result = result =
throw_exception( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to add_ratio_ratio" ), ( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1, make_cons( arg1,
make_cons( arg2, NIL ) ) ), make_cons( arg2, NIL ) ) ),
frame_pointer ); frame_pointer );
} }
#ifdef DEBUG debug_print( L" => ", DEBUG_ARITH );
fputws( L" => ", stderr ); debug_print_object( result, DEBUG_ARITH );
print( stderr, result ); debug_print( L"\n", DEBUG_ARITH );
fputws( L"\n", stderr );
#endif
return result; return result;
} }
@ -188,7 +182,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
} else { } else {
result = result =
throw_exception( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to add_integer_ratio" ), ( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg, make_cons( intarg,
make_cons( ratarg, make_cons( ratarg,
NIL ) ) ), NIL ) ) ),
@ -210,7 +204,8 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
pointer2cell( arg2 ).payload. pointer2cell( arg2 ).payload.
ratio.divisor, ratio.divisor,
pointer2cell( arg2 ).payload. pointer2cell( arg2 ).payload.
ratio.dividend ), result = ratio.dividend ),
result =
multiply_ratio_ratio( frame_pointer, arg1, i ); multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i ); dec_ref( i );
@ -228,13 +223,12 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
cons_pointer arg2 ) { cons_pointer arg2 ) {
struct cons_pointer result; struct cons_pointer result;
#ifdef DEBUG debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH );
fputws( L"multiply_ratio_ratio( arg1 = ", stderr ); debug_print_object( arg1, DEBUG_ARITH );
print( stderr, arg1 ); debug_print( L"; arg2 = ", DEBUG_ARITH );
fputws( L"; arg2 = ", stderr ); debug_print_object( arg2, DEBUG_ARITH );
print( stderr, arg2 ); debug_print( L")\n", DEBUG_ARITH );
fputws( L")\n", stderr );
#endif
if ( ratiop( arg1 ) && ratiop( arg2 ) ) { if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 ); struct cons_space_object cell2 = pointer2cell( arg2 );
@ -259,7 +253,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
} else { } else {
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame_pointer ); frame_pointer );
} }
@ -286,7 +280,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
} else { } else {
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_integer_ratio" ), ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
frame_pointer ); frame_pointer );
} }
@ -329,7 +323,7 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
} else { } else {
result = result =
throw_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Dividend and divisor of a ratio must be integers" ), ( L"Dividend and divisor of a ratio must be integers" ),
frame_pointer ); frame_pointer );
} }
debug_dump_object( result, DEBUG_ARITH ); debug_dump_object( result, DEBUG_ARITH );

19
src/debug.c
View file

@ -8,6 +8,7 @@
*/ */
#include <ctype.h> #include <ctype.h>
#include <stdarg.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
@ -35,11 +36,27 @@ int verbosity = 0;
void debug_print( wchar_t *message, int level ) { void debug_print( wchar_t *message, int level ) {
#ifdef DEBUG #ifdef DEBUG
if ( level & verbosity ) { if ( level & verbosity ) {
fwide( stderr, 1 );
fputws( message, stderr ); fputws( message, stderr );
} }
#endif #endif
} }
/**
* `wprintf` adapted for the debug logging system. Print to stderr only
* `verbosity` matches `level`. All other arguments as for `wprintf`.
*/
void debug_printf( int level, wchar_t * format, ...) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
va_list(args);
va_start(args, format);
vfwprintf(stderr, format, args);
}
#endif
}
/** /**
* print the object indicated by this `pointer` to stderr, if `verbosity` * print the object indicated by this `pointer` to stderr, if `verbosity`
* matches `level`.`verbosity is a set of flags, see debug_print.h; so you can * matches `level`.`verbosity is a set of flags, see debug_print.h; so you can
@ -48,6 +65,7 @@ void debug_print( wchar_t *message, int level ) {
void debug_print_object( struct cons_pointer pointer, int level ) { void debug_print_object( struct cons_pointer pointer, int level ) {
#ifdef DEBUG #ifdef DEBUG
if ( level & verbosity ) { if ( level & verbosity ) {
fwide( stderr, 1 );
print( stderr, pointer ); print( stderr, pointer );
} }
#endif #endif
@ -59,6 +77,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 );
dump_object( stderr, pointer ); dump_object( stderr, pointer );
} }
#endif #endif

4
src/debug.h
View file

@ -20,9 +20,13 @@
#define DEBUG_LAMBDA 16 #define DEBUG_LAMBDA 16
#define DEBUG_BOOTSTRAP 32 #define DEBUG_BOOTSTRAP 32
#define DEBUG_IO 64 #define DEBUG_IO 64
#define DEBUG_REPL 128
extern int verbosity; extern int verbosity;
void debug_print( wchar_t *message, int level ); void debug_print( wchar_t *message, int level );
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 );
#endif #endif

88
src/init.c
View file

@ -27,14 +27,14 @@
// extern char *optarg; /* defined in unistd.h */ // extern char *optarg; /* defined in unistd.h */
void bind_function( char *name, struct cons_pointer ( *executable ) void bind_function( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ), deep_bind( c_string_to_lisp_symbol( name ),
make_function( NIL, executable ) ); make_function( NIL, executable ) );
} }
void bind_special( char *name, struct cons_pointer ( *executable ) void bind_special( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ), deep_bind( c_string_to_lisp_symbol( name ),
@ -52,7 +52,7 @@ int main( int argc, char *argv[] ) {
bool dump_at_end = false; bool dump_at_end = false;
bool show_prompt = false; bool show_prompt = false;
while ( ( option = getopt( argc, argv, "pdcv:" ) ) != -1 ) { while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) {
switch ( option ) { switch ( option ) {
case 'c': case 'c':
print_use_colours = true; print_use_colours = true;
@ -65,6 +65,7 @@ int main( int argc, char *argv[] ) {
break; break;
case 'v': case 'v':
verbosity = atoi( optarg ); verbosity = atoi( optarg );
break;
default: default:
fwprintf( stderr, L"Unexpected option %c\n", option ); fwprintf( stderr, L"Unexpected option %c\n", option );
break; break;
@ -76,62 +77,61 @@ int main( int argc, char *argv[] ) {
L"Post scarcity software environment version %s\n\n", L"Post scarcity software environment version %s\n\n",
VERSION ); VERSION );
} }
#ifdef DEBUG
fputws( L"About to initialise cons pages\n", stderr ); debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP );
#endif
initialise_cons_pages( ); initialise_cons_pages( );
#ifdef DEBUG debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP );
fputws( L"Initialised cons pages, about to bind\n", stderr );
#endif
/* /*
* privileged variables (keywords) * privileged variables (keywords)
*/ */
deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL );
deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE );
/* /*
* primitive function operations * primitive function operations
*/ */
bind_function( "add", &lisp_add ); bind_function( L"add", &lisp_add );
bind_function( "apply", &lisp_apply ); bind_function( L"apply", &lisp_apply );
bind_function( "assoc", &lisp_assoc ); bind_function( L"assoc", &lisp_assoc );
bind_function( "car", &lisp_car ); bind_function( L"car", &lisp_car );
bind_function( "cdr", &lisp_cdr ); bind_function( L"cdr", &lisp_cdr );
bind_function( "cons", &lisp_cons ); bind_function( L"cons", &lisp_cons );
bind_function( "divide", &lisp_divide ); bind_function( L"divide", &lisp_divide );
bind_function( "eq", &lisp_eq ); bind_function( L"eq", &lisp_eq );
bind_function( "equal", &lisp_equal ); bind_function( L"equal", &lisp_equal );
bind_function( "eval", &lisp_eval ); bind_function( L"eval", &lisp_eval );
bind_function( "exception", &lisp_exception ); bind_function( L"exception", &lisp_exception );
bind_function( "multiply", &lisp_multiply ); bind_function( L"multiply", &lisp_multiply );
bind_function( "read", &lisp_read ); bind_function( L"read", &lisp_read );
bind_function( "oblist", &lisp_oblist ); bind_function( L"oblist", &lisp_oblist );
bind_function( "print", &lisp_print ); bind_function( L"print", &lisp_print );
bind_function( "progn", &lisp_progn ); bind_function( L"progn", &lisp_progn );
bind_function( "reverse", &lisp_reverse ); bind_function( L"reverse", &lisp_reverse );
bind_function( "set", &lisp_set ); bind_function( L"set", &lisp_set );
bind_function( "subtract", &lisp_subtract ); bind_function( L"subtract", &lisp_subtract );
bind_function( "throw", &lisp_exception ); bind_function( L"throw", &lisp_exception );
bind_function( "type", &lisp_type ); bind_function( L"type", &lisp_type );
bind_function( "+", &lisp_add ); bind_function( L"+", &lisp_add );
bind_function( "*", &lisp_multiply ); bind_function( L"*", &lisp_multiply );
bind_function( "-", &lisp_subtract ); bind_function( L"-", &lisp_subtract );
bind_function( "/", &lisp_divide ); bind_function( L"/", &lisp_divide );
bind_function( "=", &lisp_equal ); bind_function( L"=", &lisp_equal );
/* /*
* primitive special forms * primitive special forms
*/ */
bind_special( "cond", &lisp_cond ); bind_special( L"cond", &lisp_cond );
bind_special( "lambda", &lisp_lambda ); bind_special( L"lambda", &lisp_lambda );
/* bind_special( "λ", &lisp_lambda ); */ // bind_special( L"λ", &lisp_lambda );
bind_special( "nlambda", &lisp_nlambda ); bind_special( L"nlambda", &lisp_nlambda );
bind_special( "progn", &lisp_progn ); // bind_special( L"nλ", &lisp_nlambda );
bind_special( "quote", &lisp_quote ); bind_special( L"progn", &lisp_progn );
bind_special( "set!", &lisp_set_shriek ); bind_special( L"quote", &lisp_quote );
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

@ -18,6 +18,7 @@
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
#include "debug.h"
#include "dump.h" #include "dump.h"
/** /**
@ -65,7 +66,7 @@ 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;
fwprintf( stderr, L"Allocated special cell NIL\n" ); debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" );
break; break;
case 1: case 1:
/* /*
@ -79,7 +80,7 @@ void make_cons_page( ) {
cell->payload.free.cdr = ( struct cons_pointer ) { cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1 0, 1
}; };
fwprintf( stderr, L"Allocated special cell T\n" ); debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" );
break; break;
} }
} else { } else {
@ -96,7 +97,7 @@ void make_cons_page( ) {
initialised_cons_pages++; initialised_cons_pages++;
} else { } else {
fwprintf( stderr, 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 );
@ -128,10 +129,8 @@ void dump_pages( FILE * output ) {
void free_cell( struct cons_pointer pointer ) { void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
#ifdef DEBUG debug_printf( DEBUG_ALLOC, L"Freeing cell " );
fwprintf( stderr, L"Freeing cell " ); debug_dump_object( pointer, DEBUG_ALLOC );
dump_object( stderr, pointer );
#endif
switch ( cell->tag.value ) { switch ( cell->tag.value ) {
/* for all the types of cons-space object which point to other /* for all the types of cons-space object which point to other
@ -165,10 +164,8 @@ 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! */
#ifdef DEBUG debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n",
fwprintf( stderr, L"About to free vector-space object at %ld\n",
cell->payload.vectorp.address ); cell->payload.vectorp.address );
#endif
//free( ( void * ) cell->payload.vectorp.address ); //free( ( void * ) cell->payload.vectorp.address );
break; break;
@ -181,12 +178,12 @@ void free_cell( struct cons_pointer pointer ) {
cell->payload.free.cdr = freelist; cell->payload.free.cdr = freelist;
freelist = pointer; freelist = pointer;
} else { } else {
fwprintf( stderr, 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 {
fwprintf( stderr, 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 );
} }
@ -218,13 +215,11 @@ struct cons_pointer allocate_cell( char *tag ) {
cell->payload.cons.car = NIL; cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL; cell->payload.cons.cdr = NIL;
#ifdef DEBUG debug_printf( DEBUG_ALLOC,
fwprintf( stderr,
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 );
#endif
} else { } else {
fwprintf( stderr, L"WARNING: Allocating non-free cell!" ); debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
} }
} }
@ -243,7 +238,7 @@ void initialise_cons_pages( ) {
make_cons_page( ); make_cons_page( );
conspageinitihasbeencalled = true; conspageinitihasbeencalled = true;
} else { } else {
fwprintf( stderr, 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" );
} }
} }

25
src/memory/consspaceobject.c
View file

@ -20,6 +20,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "print.h" #include "print.h"
#include "stack.h" #include "stack.h"
@ -178,11 +179,13 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
cell->payload.string.character = c; cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.page = tail.page;
/* TODO: There's a problem here. Sometimes the offsets on /* TODO: There's a problem here. Sometimes the offsets on
* strings are quite massively off. */ * strings are quite massively off. Fix is probably
* cell->payload.string.cdr = tsil */
cell->payload.string.cdr.offset = tail.offset; cell->payload.string.cdr.offset = tail.offset;
} else { } else {
fwprintf( stderr, // TODO: should throw an exception!
L"Warning: only NIL and %s can be appended to %s\n", debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %s can be prepended to %s\n",
tag, tag ); tag, tag );
} }
@ -249,26 +252,26 @@ struct cons_pointer make_write_stream( FILE * output ) {
} }
/** /**
* Return a lisp string representation of this old skool ASCII string. * Return a lisp string representation of this wide character string.
*/ */
struct cons_pointer c_string_to_lisp_string( char *string ) { struct cons_pointer c_string_to_lisp_string( wchar_t *string ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
for ( int i = strlen( string ); i > 0; i-- ) { for ( int i = wcslen( string ); i > 0; i-- ) {
result = make_string( ( wint_t ) string[i - 1], result ); result = make_string( string[i - 1], result );
} }
return result; return result;
} }
/** /**
* Return a lisp symbol representation of this old skool ASCII string. * Return a lisp symbol representation of this wide character string.
*/ */
struct cons_pointer c_string_to_lisp_symbol( char *symbol ) { struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
for ( int i = strlen( symbol ); i > 0; i-- ) { for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_symbol( ( wint_t ) symbol[i - 1], result ); result = make_symbol( symbol[i - 1], result );
} }
return result; return result;

4
src/memory/consspaceobject.h
View file

@ -582,11 +582,11 @@ struct cons_pointer make_write_stream( FILE * output );
/** /**
* Return a lisp string representation of this old skool ASCII string. * Return a lisp string representation of this old skool ASCII string.
*/ */
struct cons_pointer c_string_to_lisp_string( char *string ); struct cons_pointer c_string_to_lisp_string( wchar_t *string );
/** /**
* Return a lisp symbol representation of this old skool ASCII string. * Return a lisp symbol representation of this old skool ASCII string.
*/ */
struct cons_pointer c_string_to_lisp_symbol( char *symbol ); struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol );
#endif #endif

26
src/memory/dump.c
View file

@ -55,11 +55,8 @@ void dump_string_cell( FILE * output, wchar_t *prefix,
void dump_object( FILE * output, struct cons_pointer pointer ) { void dump_object( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output, fwprintf( output,
L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n", L"\t%4.4s (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0], cell.tag.bytes,
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
cell.tag.value, pointer.page, pointer.offset, cell.count ); cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
@ -91,6 +88,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
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 );
break; break;
case NILTV:
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",
@ -101,6 +100,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
break; break;
case READTV: case READTV:
fwprintf( output, L"\t\tInput stream\n" ); fwprintf( output, L"\t\tInput stream\n" );
break;
case REALTV: case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count ); cell.payload.real.value, cell.count );
@ -111,26 +111,28 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case SYMBOLTV: case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer ); dump_string_cell( output, L"Symbol", pointer );
break; break;
case TRUETV:
break;
case VECTORPOINTTV:{ case VECTORPOINTTV:{
fwprintf( output, fwprintf( output,
L"\t\tPointer to vector-space object at %p\n", L"\t\tPointer to vector-space object at %p\n",
cell.payload.vectorp.address ); cell.payload.vectorp.address );
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, 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.size ); &vso->header.tag.bytes, vso->header.tag.value, vso->header.size );
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 );
break; break;
default:
fputws( L"(Unknown vector type)\n", output );
break;
} }
} }
break; break;
default: case WRITETV:
fputws( L"(Unknown cons space type)\n", output ); fwprintf( output, L"\t\tOutput stream\n" );
break; break;
} }
} }

57
src/memory/stack.c
View file

@ -32,24 +32,15 @@
*/ */
struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
struct stack_frame *result = NULL; struct stack_frame *result = NULL;
debug_print
( L"get_stack_frame: about to get a pointer to the vector space object\n",
DEBUG_ALLOC );
struct vector_space_object *vso = struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address; pointer2cell( pointer ).payload.vectorp.address;
debug_print( L"get_stack_frame: got a pointer, about to test it\n",
DEBUG_ALLOC );
if ( vectorpointp( pointer ) && stackframep( vso ) ) { if ( vectorpointp( pointer ) && stackframep( vso ) ) {
debug_print
( L"get_stack_frame: pointer is good, about to set the result\n",
DEBUG_ALLOC );
result = ( struct stack_frame * ) &( vso->payload ); result = ( struct stack_frame * ) &( vso->payload );
fwprintf( stderr, L"get_stack_frame: all good, returning %p\n", debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n",
result ); result );
} else { } else {
debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_ALLOC ); debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK );
} }
return result; return result;
@ -62,31 +53,31 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
* @return the new frame, or NULL if memory is exhausted. * @return the new frame, or NULL if memory is exhausted.
*/ */
struct cons_pointer make_empty_frame( struct cons_pointer previous ) { struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC ); debug_print( L"Entering make_empty_frame\n", DEBUG_STACK );
struct cons_pointer result = struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) ); make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
debug_dump_object( result, DEBUG_ALLOC ); debug_dump_object( result, DEBUG_STACK );
fwprintf( stderr, debug_printf( DEBUG_STACK,
L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n", L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
pointer_to_vso( result )->header.size, pointer_to_vso( result )->header.size,
&pointer_to_vso( result )->header.tag.bytes ); &pointer_to_vso( result )->header.tag.bytes );
if ( !nilp( result ) ) { if ( !nilp( result ) ) {
debug_print( L"make_empty_frame: about to call get_stack_frame\n", debug_print( L"make_empty_frame: about to call get_stack_frame\n",
DEBUG_ALLOC ); DEBUG_STACK );
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
/* /*
* TODO: later, pop a frame off a free-list of stack frames * TODO: later, pop a frame off a free-list of stack frames
*/ */
fwprintf( stderr, debug_printf( DEBUG_STACK,
L"make_empty_frame: about to set previous to %4.4s\n", L"make_empty_frame: about to set previous to %4.4s\n",
&pointer2cell( previous ).tag.bytes ); &pointer2cell( previous ).tag.bytes );
frame->previous = previous; frame->previous = previous;
debug_print( L"make_empty_frame: about to call inc_ref\n", debug_print( L"make_empty_frame: about to call inc_ref\n",
DEBUG_ALLOC ); DEBUG_STACK );
inc_ref( previous ); inc_ref( previous );
/* /*
@ -98,12 +89,12 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
frame->args = 0; frame->args = 0;
debug_print( L"make_empty_frame: about to initialise arg registers\n", debug_print( L"make_empty_frame: about to initialise arg registers\n",
DEBUG_ALLOC ); DEBUG_STACK );
for ( int i = 0; i < args_in_frame; i++ ) { for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( frame, i, NIL ); set_reg( frame, i, NIL );
} }
} }
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); debug_print( L"Leaving make_empty_frame\n", DEBUG_STACK );
return result; return result;
} }
@ -119,13 +110,13 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env ) { struct cons_pointer env ) {
debug_print( L"Entering make_stack_frame\n", DEBUG_ALLOC ); debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous ); struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) { if ( nilp( result ) ) {
/* i.e. out of memory */ /* i.e. out of memory */
result = result =
make_exception( c_string_to_lisp_string( "Memory exhausted." ), make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous ); previous );
} else { } else {
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
@ -149,11 +140,13 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
if ( nilp( arg_frame_pointer ) ) { if ( nilp( arg_frame_pointer ) ) {
result = result =
make_exception( c_string_to_lisp_string make_exception( c_string_to_lisp_string
( "Memory exhausted." ), previous ); ( L"Memory exhausted." ), previous );
break; break;
} else { } else {
struct stack_frame *arg_frame = struct stack_frame *arg_frame =
get_stack_frame( arg_frame_pointer ); get_stack_frame( arg_frame_pointer );
debug_print( L"Setting argument 0 of arg_frame to ", DEBUG_STACK);
debug_print_object(cell.payload.cons.car, DEBUG_STACK);
set_reg( arg_frame, 0, cell.payload.cons.car ); set_reg( arg_frame, 0, cell.payload.cons.car );
struct cons_pointer val = struct cons_pointer val =
@ -162,6 +155,8 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
result = val; result = val;
break; break;
} else { } else {
debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args);
debug_print_object(cell.payload.cons.car, DEBUG_STACK);
set_reg( frame, frame->args, val ); set_reg( frame, frame->args, val );
} }
@ -180,10 +175,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
inc_ref( more ); inc_ref( more );
} }
debug_dump_object( result, DEBUG_ALLOC ); debug_dump_object( result, DEBUG_STACK );
} }
} }
debug_print( L"Leaving make_stack_frame\n", DEBUG_ALLOC ); debug_print( L"Leaving make_stack_frame\n", DEBUG_STACK );
return result; return result;
} }
@ -199,14 +194,14 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer make_special_frame( struct cons_pointer previous, struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env ) { struct cons_pointer env ) {
debug_print( L"Entering make_special_frame\n", DEBUG_ALLOC ); debug_print( L"Entering make_special_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous ); struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) { if ( nilp( result ) ) {
/* i.e. out of memory */ /* i.e. out of memory */
result = result =
make_exception( c_string_to_lisp_string( "Memory exhausted." ), make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous ); previous );
} else { } else {
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
@ -228,10 +223,10 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
inc_ref( args ); inc_ref( args );
} }
debug_dump_object( result, DEBUG_ALLOC ); debug_dump_object( result, DEBUG_STACK );
} }
} }
debug_print( L"Leaving make_special_frame\n", DEBUG_ALLOC ); debug_print( L"Leaving make_special_frame\n", DEBUG_STACK );
return result; return result;
} }
@ -263,6 +258,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);
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] );
@ -274,16 +270,19 @@ 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))
{
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 );
} }
} }
}
void dump_stack_trace( FILE * output, struct cons_pointer pointer ) { void dump_stack_trace( FILE * output, struct cons_pointer pointer ) {
if ( exceptionp( pointer ) ) { if ( exceptionp( pointer ) ) {
print( output, pointer2cell( pointer ).payload.exception.message ); print( output, pointer2cell( pointer ).payload.exception.message );
fwprintf( output, L"\n" ); fputws( L"\n", output );
dump_stack_trace( output, dump_stack_trace( output,
pointer2cell( pointer ).payload.exception.frame ); pointer2cell( pointer ).payload.exception.frame );
} else { } else {

24
src/memory/vectorspace.c
View file

@ -21,7 +21,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "dump.h" #include "debug.h"
#include "vectorspace.h" #include "vectorspace.h"
@ -32,17 +32,17 @@
* vector-space object, NOT `VECTORPOINTTAG`. * vector-space object, NOT `VECTORPOINTTAG`.
*/ */
struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
fputws( L"Entered make_vec_pointer\n", stderr ); debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
fwprintf( stderr, 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;
fwprintf( stderr, L"make_vec_pointer: all good, returning pointer to %p\n", debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n",
cell->payload.vectorp.address ); cell->payload.vectorp.address );
dump_object( stderr, pointer ); debug_dump_object( pointer, DEBUG_ALLOC );
return pointer; return pointer;
} }
@ -55,41 +55,41 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
* Returns NIL if the vector could not be allocated due to memory exhaustion. * Returns NIL if the vector could not be allocated due to memory exhaustion.
*/ */
struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
fputws( L"Entered make_vso\n", stderr ); debug_print( L"Entered make_vso\n", DEBUG_ALLOC );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size; int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
/* Pad size to 64 bit words. This is intended to promote access efficiancy /* Pad size to 64 bit words. This is intended to promote access efficiancy
* on 64 bit machines but may just be voodoo coding */ * on 64 bit machines but may just be voodoo coding */
uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 ); uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
fputws( L"make_vso: about to malloc\n", stderr ); debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC );
struct vector_space_object *vso = malloc( padded ); struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) { if ( vso != NULL ) {
fwprintf( stderr, 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", tag,
vso ); 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 );
dump_object( stderr, result ); debug_dump_object( result, DEBUG_ALLOC );
vso->header.vecp = result; vso->header.vecp = result;
// memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));
vso->header.size = payload_size; vso->header.size = payload_size;
#ifdef DEBUG #ifdef DEBUG
fwprintf( stderr, 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,
&vso->payload ); &vso->payload );
if ( padded != total_size ) { if ( padded != total_size ) {
fwprintf( stderr, 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
fwprintf( stderr, L"make_vso: all good, returning pointer to %p\n", debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n",
pointer2cell( result ).payload.vectorp.address ); pointer2cell( result ).payload.vectorp.address );
#endif #endif

45
src/ops/lispops.c
View file

@ -193,7 +193,7 @@ struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame, eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
fwprintf( stderr, L"eval_lambda called\n" ); debug_print( L"eval_lambda called\n", DEBUG_EVAL );
struct cons_pointer new_env = env; struct cons_pointer new_env = env;
struct cons_pointer names = cell.payload.lambda.args; struct cons_pointer names = cell.payload.lambda.args;
@ -355,13 +355,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
break; break;
default: default:
{ {
char *buffer = malloc( 1024 ); int bs = sizeof(wchar_t) * 1024;
memset( buffer, '\0', 1024 ); wchar_t *buffer = malloc( bs );
sprintf( buffer, memset( buffer, '\0', bs );
"Unexpected cell with tag %d (%c%c%c%c) in function position", swprintf( buffer, bs,
fn_cell.tag.value, fn_cell.tag.bytes[0], L"Unexpected cell with tag %d (%4.4s) in function position",
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], fn_cell.tag.value, &fn_cell.tag.bytes[0] );
fn_cell.tag.bytes[3] );
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( buffer ); c_string_to_lisp_string( buffer );
free( buffer ); free( buffer );
@ -380,13 +379,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
* @return As a Lisp string, the tag of the object which is at that pointer. * @return As a Lisp string, the tag of the object which is at that pointer.
*/ */
struct cons_pointer c_type( struct cons_pointer pointer ) { struct cons_pointer c_type( struct cons_pointer pointer ) {
char *buffer = malloc( TAGLENGTH + 1 ); struct cons_pointer result = NIL;
memset( buffer, 0, TAGLENGTH + 1 );
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
strncpy( buffer, cell.tag.bytes, TAGLENGTH );
struct cons_pointer result = c_string_to_lisp_string( buffer ); for (int i = TAGLENGTH; i >= 0; i--)
free( buffer ); {
result = make_string((wchar_t)cell.tag.bytes[i], result);
}
return result; return result;
} }
@ -408,14 +407,12 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
struct cons_pointer struct cons_pointer
lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
debug_print( L"Eval: ", DEBUG_EVAL );
debug_dump_object( frame_pointer, DEBUG_EVAL );
struct cons_pointer result = frame->arg[0]; struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_space_object cell = pointer2cell( frame->arg[0] );
debug_print( L"Eval: ", DEBUG_EVAL );
#ifdef DEBUG
dump_frame( stderr, frame_pointer );
#endif
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
{ {
@ -430,7 +427,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( nilp( canonical ) ) { if ( nilp( canonical ) ) {
struct cons_pointer message = struct cons_pointer message =
make_cons( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( "Attempt to take value of unbound symbol." ), ( L"Attempt to take value of unbound symbol." ),
frame->arg[0] ); frame->arg[0] );
result = throw_exception( message, frame_pointer ); result = throw_exception( message, frame_pointer );
} else { } else {
@ -522,7 +519,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = result =
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( L"The first argument to `set` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), make_cons( frame->arg[0], NIL ) ),
frame_pointer ); frame_pointer );
} }
@ -556,7 +553,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = result =
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( L"The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), make_cons( frame->arg[0], NIL ) ),
frame_pointer ); frame_pointer );
} }
@ -610,7 +607,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = make_string( cell.payload.string.character, NIL ); result = make_string( cell.payload.string.character, NIL );
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR of non sequence" ); c_string_to_lisp_string( L"Attempt to take CAR of non sequence" );
result = throw_exception( message, frame_pointer ); result = throw_exception( message, frame_pointer );
} }
@ -635,7 +632,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = cell.payload.string.cdr; result = cell.payload.string.cdr;
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CDR of non sequence" ); c_string_to_lisp_string( L"Attempt to take CDR of non sequence" );
result = throw_exception( message, frame_pointer ); result = throw_exception( message, frame_pointer );
} }
@ -850,7 +847,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
done = true; done = true;
} else { } else {
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ), ( L"Arguments to `cond` must be lists" ),
frame_pointer ); frame_pointer );
} }
} }

9
src/ops/print.c
View file

@ -37,7 +37,7 @@ int print_use_colours = 0;
void print_string_contents( FILE * output, struct cons_pointer pointer ) { void print_string_contents( FILE * output, struct cons_pointer pointer ) {
while ( stringp( pointer ) || symbolp( pointer ) ) { while ( stringp( pointer ) || symbolp( pointer ) ) {
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
wint_t c = cell->payload.string.character; wchar_t c = cell->payload.string.character;
if ( c != '\0' ) { if ( c != '\0' ) {
fputwc( c, output ); fputwc( c, output );
@ -131,7 +131,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"%ld%", cell.payload.integer.value ); fwprintf( output, L"%ld%", cell.payload.integer.value );
break; break;
case LAMBDATV: case LAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "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.lambda.
body ) ) ); body ) ) );
@ -140,7 +140,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"nil" ); fwprintf( output, L"nil" );
break; break;
case NLAMBDATV: case NLAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "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.lambda.
body ) ) ); body ) ) );
@ -190,6 +190,9 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case TRUETV: case TRUETV:
fwprintf( output, L"t" ); fwprintf( output, L"t" );
break; break;
case WRITETV:
fwprintf( output, L"(Output stream)" );
break;
default: default:
fwprintf( stderr, fwprintf( stderr,
L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",

36
src/ops/read.c
View file

@ -49,7 +49,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial );
* quote reader macro in C (!) * quote reader macro in C (!)
*/ */
struct cons_pointer c_quote( struct cons_pointer arg ) { struct cons_pointer c_quote( struct cons_pointer arg ) {
return make_cons( c_string_to_lisp_symbol( "quote" ), return make_cons( c_string_to_lisp_symbol( L"quote" ),
make_cons( arg, NIL ) ); make_cons( arg, NIL ) );
} }
@ -71,8 +71,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
if ( feof( input ) ) { if ( feof( input ) ) {
result = result =
make_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "End of file while reading" ), frame_pointer ); ( L"End of file while reading" ), frame_pointer );
} else { } else {
switch ( c ) { switch ( c ) {
case ';': case ';':
@ -81,7 +81,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
break; break;
case EOF: case EOF:
result = throw_exception( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "End of input while reading" ), ( L"End of input while reading" ),
frame_pointer ); frame_pointer );
break; break;
case '\'': case '\'':
@ -136,8 +136,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
result = read_symbol( input, c ); result = read_symbol( input, c );
} else { } else {
result = result =
make_exception( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Unrecognised start of input character" ), ( L"Unrecognised start of input character" ),
make_string( c, NIL ) ), make_string( c, NIL ) ),
frame_pointer ); frame_pointer );
} }
@ -170,23 +170,23 @@ struct cons_pointer read_number( struct stack_frame *frame,
if ( negative ) { if ( negative ) {
initial = fgetwc( input ); initial = fgetwc( input );
} }
#ifdef DEBUG
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial );
#endif
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 make_exception( c_string_to_lisp_string return throw_exception( c_string_to_lisp_string
( "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 make_exception( c_string_to_lisp_string return throw_exception( c_string_to_lisp_string
( "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;
@ -195,11 +195,11 @@ struct cons_pointer read_number( struct stack_frame *frame,
} }
} else { } else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
#ifdef DEBUG
fwprintf( stderr, debug_printf( DEBUG_IO,
L"Added character %c, accumulator now %ld\n", L"Added character %c, accumulator now %ld\n",
c, accumulator ); c, accumulator );
#endif
if ( seen_period ) { if ( seen_period ) {
places_of_decimals++; places_of_decimals++;
} }
@ -243,10 +243,8 @@ struct cons_pointer read_list( struct stack_frame *frame,
FILE * input, wint_t initial ) { FILE * input, wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( initial != ')' ) { if ( initial != ')' ) {
#ifdef DEBUG debug_printf( DEBUG_IO,
fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial ); L"read_list starting '%C' (%d)\n", initial, initial );
#endif
struct cons_pointer car = struct cons_pointer car =
read_continuation( frame, frame_pointer, input, read_continuation( frame, frame_pointer, input,
initial ); initial );

60
src/repl.c
View file

@ -13,7 +13,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "dump.h" #include "debug.h"
#include "intern.h" #include "intern.h"
#include "lispops.h" #include "lispops.h"
#include "read.h" #include "read.h"
@ -33,25 +33,17 @@
*/ */
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;
fputws( L"Entered repl_read\n", stderr ); debug_print( L"Entered repl_read\n", DEBUG_REPL );
struct cons_pointer frame_pointer = make_empty_frame( NIL ); struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist );
fputws( L"repl_read: got stack_frame pointer\n", stderr ); debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL );
dump_object( stderr, frame_pointer ); debug_dump_object( frame_pointer, DEBUG_REPL );
if ( !nilp( frame_pointer ) ) { if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer ); inc_ref( frame_pointer );
struct stack_frame *frame = get_stack_frame( frame_pointer ); result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist );
if ( frame != NULL ) {
fputws( L"repl_read: about to set register\n", stderr );
set_reg( frame, 0, stream_pointer );
fputws( L"repl_read: about to read\n", stderr );
struct cons_pointer result =
lisp_read( frame, frame_pointer, oblist );
}
dec_ref( frame_pointer ); dec_ref( frame_pointer );
} }
fputws( L"repl_read: returning\n", stderr ); debug_print( L"repl_read: returning\n", DEBUG_REPL );
dump_object( stderr, result ); debug_dump_object( result, DEBUG_REPL );
return result; return result;
} }
@ -60,22 +52,18 @@ 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 ) {
fputws( L"Entered repl_eval\n", stderr ); debug_print( L"Entered repl_eval\n", DEBUG_REPL );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL ); struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( input, NIL ), oblist);
if ( !nilp( frame_pointer ) ) { if ( !nilp( frame_pointer ) ) {
inc_ref(frame_pointer); inc_ref(frame_pointer);
struct stack_frame *frame = get_stack_frame( frame_pointer ); result = lisp_eval( get_stack_frame( frame_pointer ), 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 );
} }
fputws( L"repl_eval: returning\n", stderr ); debug_print( L"repl_eval: returning\n", DEBUG_REPL );
dump_object( stderr, result ); debug_dump_object( result, DEBUG_REPL );
return result; return result;
} }
@ -85,20 +73,17 @@ 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_dump_object( value, DEBUG_REPL );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL ); struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( value, NIL ), oblist);
if ( !nilp( frame_pointer ) ) { if ( !nilp( frame_pointer ) ) {
struct stack_frame *frame = get_stack_frame( frame_pointer ); inc_ref(frame_pointer);
result = lisp_print( get_stack_frame( frame_pointer ), frame_pointer, oblist );
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 );
} }
debug_print( L"repl_print: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
return result; return result;
} }
@ -113,7 +98,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 ) {
fputws( L"Entered repl\n", stderr ); 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 );
@ -138,4 +123,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 );
} }

BIN
utils_src/debugflags/debugflags Executable file
View file

Binary file not shown.

43
utils_src/debugflags/debugflags.c Normal file
View file

@ -0,0 +1,43 @@
#include <inttypes.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#define DEBUG_ALLOC 1
#define DEBUG_STACK 2
#define DEBUG_ARITH 4
#define DEBUG_EVAL 8
#define DEBUG_LAMBDA 16
#define DEBUG_BOOTSTRAP 32
#define DEBUG_IO 64
#define DEBUG_REPL 128
int check_level( int v, int level, char * name) {
int result = 0;
if (v & level) {
printf("\t\t%s (%d) matches;\n", name, level);
result = 1;
}
return result;
}
int main( int argc, char *argv[] ) {
for (int i = 1; i < argc; i++) {
int v = atoi(argv[i]);
printf("Level %d:\n", v);
int matches = check_level(v, DEBUG_ALLOC, "DEBUG_ALLOC") +
check_level(v, DEBUG_STACK, "DEBUG_STACK") +
check_level(v, DEBUG_ARITH, "DEBUG_ARITH") +
check_level(v, DEBUG_EVAL, "DEBUG_EVAL") +
check_level(v, DEBUG_LAMBDA, "DEBUG_LAMBDA") +
check_level(v, DEBUG_BOOTSTRAP, "DEBUG_BOOTSTRAP") +
check_level(v, DEBUG_IO, "DEBUG_IO") +
check_level(v, DEBUG_REPL, "DEBUG_REPL");
printf("\t%d matches\n", matches);
}
}