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

52
src/arith/ratio.c
View file

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

19
src/debug.c
View file

@ -8,6 +8,7 @@
*/
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
@ -35,11 +36,27 @@ int verbosity = 0;
void debug_print( wchar_t *message, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
fputws( message, stderr );
}
#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`
* 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 ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
print( stderr, pointer );
}
#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 ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
dump_object( stderr, pointer );
}
#endif

4
src/debug.h
View file

@ -20,9 +20,13 @@
#define DEBUG_LAMBDA 16
#define DEBUG_BOOTSTRAP 32
#define DEBUG_IO 64
#define DEBUG_REPL 128
extern int verbosity;
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_dump_object( struct cons_pointer pointer, int level );
#endif

88
src/init.c
View file

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

29
src/memory/conspage.c
View file

@ -18,6 +18,7 @@
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
/**
@ -65,7 +66,7 @@ void make_cons_page( ) {
cell->count = MAXREFERENCE;
cell->payload.free.car = 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;
case 1:
/*
@ -79,7 +80,7 @@ void make_cons_page( ) {
cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1
};
fwprintf( stderr, L"Allocated special cell T\n" );
debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" );
break;
}
} else {
@ -96,7 +97,7 @@ void make_cons_page( ) {
initialised_cons_pages++;
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages );
exit( 1 );
@ -128,10 +129,8 @@ void dump_pages( FILE * output ) {
void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
#ifdef DEBUG
fwprintf( stderr, L"Freeing cell " );
dump_object( stderr, pointer );
#endif
debug_printf( DEBUG_ALLOC, L"Freeing cell " );
debug_dump_object( pointer, DEBUG_ALLOC );
switch ( cell->tag.value ) {
/* 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:
/* for vector space pointers, free the actual vector-space
* object. Dangerous! */
#ifdef DEBUG
fwprintf( stderr, L"About to free vector-space object at %ld\n",
debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n",
cell->payload.vectorp.address );
#endif
//free( ( void * ) cell->payload.vectorp.address );
break;
@ -181,12 +178,12 @@ void free_cell( struct cons_pointer pointer ) {
cell->payload.free.cdr = freelist;
freelist = pointer;
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset );
}
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset );
}
@ -218,13 +215,11 @@ struct cons_pointer allocate_cell( char *tag ) {
cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL;
#ifdef DEBUG
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset );
#endif
} 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( );
conspageinitihasbeencalled = true;
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
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 "consspaceobject.h"
#include "debug.h"
#include "print.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.cdr.page = tail.page;
/* 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;
} else {
fwprintf( stderr,
L"Warning: only NIL and %s can be appended to %s\n",
// TODO: should throw an exception!
debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %s can be prepended to %s\n",
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;
for ( int i = strlen( string ); i > 0; i-- ) {
result = make_string( ( wint_t ) string[i - 1], result );
for ( int i = wcslen( string ); i > 0; i-- ) {
result = make_string( string[i - 1], 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;
for ( int i = strlen( symbol ); i > 0; i-- ) {
result = make_symbol( ( wint_t ) symbol[i - 1], result );
for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_symbol( symbol[i - 1], 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.
*/
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.
*/
struct cons_pointer c_string_to_lisp_symbol( char *symbol );
struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol );
#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 ) {
struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output,
L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
L"\t%4.4s (%d) at page %d, offset %d count %u\n",
cell.tag.bytes,
cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) {
@ -91,6 +88,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
break;
case NILTV:
break;
case RATIOTV:
fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n",
@ -101,6 +100,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
break;
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
@ -111,26 +111,28 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
case TRUETV:
break;
case VECTORPOINTTV:{
fwprintf( output,
L"\t\tPointer to vector-space object at %p\n",
cell.payload.vectorp.address );
struct vector_space_object *vso = cell.payload.vectorp.address;
fwprintf( output,
L"\t\tVector space object of type %4.4s, payload size %d bytes\n",
&vso->header.tag.bytes, vso->header.size );
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 );
if (stackframep(vso)) {
dump_frame(output, pointer);
}
switch ( vso->header.tag.value ) {
case STACKFRAMETV:
dump_frame( output, pointer );
break;
default:
fputws( L"(Unknown vector type)\n", output );
break;
}
}
break;
default:
fputws( L"(Unknown cons space type)\n", output );
case WRITETV:
fwprintf( output, L"\t\tOutput stream\n" );
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 *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 =
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 ) ) {
debug_print
( L"get_stack_frame: pointer is good, about to set the result\n",
DEBUG_ALLOC );
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 );
} 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;
@ -62,31 +53,31 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
debug_print( L"Entering make_empty_frame\n", DEBUG_STACK );
struct cons_pointer result =
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",
pointer_to_vso( result )->header.size,
&pointer_to_vso( result )->header.tag.bytes );
if ( !nilp( result ) ) {
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 );
/*
* 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",
&pointer2cell( previous ).tag.bytes );
frame->previous = previous;
debug_print( L"make_empty_frame: about to call inc_ref\n",
DEBUG_ALLOC );
DEBUG_STACK );
inc_ref( previous );
/*
@ -98,12 +89,12 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
frame->args = 0;
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++ ) {
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;
}
@ -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 args,
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 );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( "Memory exhausted." ),
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
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 ) ) {
result =
make_exception( c_string_to_lisp_string
( "Memory exhausted." ), previous );
( L"Memory exhausted." ), previous );
break;
} else {
struct stack_frame *arg_frame =
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 );
struct cons_pointer val =
@ -162,6 +155,8 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
result = val;
break;
} 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 );
}
@ -180,10 +175,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
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;
}
@ -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 args,
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 );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( "Memory exhausted." ),
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
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 );
}
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;
}
@ -263,6 +258,7 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
fwprintf( output, L"Stack frame with %d arguments:\n", frame->args);
for ( int arg = 0; arg < frame->args; 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] );
fputws( L"\n", output );
}
if (!nilp(frame->more))
{
fputws( L"More: \t", output );
print( output, frame->more );
fputws( L"\n", output );
}
}
}
void dump_stack_trace( FILE * output, struct cons_pointer pointer ) {
if ( exceptionp( pointer ) ) {
print( output, pointer2cell( pointer ).payload.exception.message );
fwprintf( output, L"\n" );
fputws( L"\n", output );
dump_stack_trace( output,
pointer2cell( pointer ).payload.exception.frame );
} else {

24
src/memory/vectorspace.c
View file

@ -21,7 +21,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "dump.h"
#include "debug.h"
#include "vectorspace.h"
@ -32,17 +32,17 @@
* vector-space object, NOT `VECTORPOINTTAG`.
*/
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_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",
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 );
dump_object( stderr, pointer );
debug_dump_object( pointer, DEBUG_ALLOC );
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.
*/
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;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
/* Pad size to 64 bit words. This is intended to promote access efficiancy
* on 64 bit machines but may just be voodoo coding */
uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
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 );
if ( vso != NULL ) {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"make_vso: about to write tag '%s' into vso at %p\n", tag,
vso );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
result = make_vec_pointer( vso );
dump_object( stderr, result );
debug_dump_object( result, DEBUG_ALLOC );
vso->header.vecp = result;
// memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));
vso->header.size = payload_size;
#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",
&vso->header.tag.bytes, total_size, vso->header.size, vso,
&vso->payload );
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 );
}
#endif
}
#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 );
#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,
struct cons_pointer frame_pointer, struct cons_pointer env ) {
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 names = cell.payload.lambda.args;
@ -355,13 +355,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
break;
default:
{
char *buffer = malloc( 1024 );
memset( buffer, '\0', 1024 );
sprintf( buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position",
fn_cell.tag.value, fn_cell.tag.bytes[0],
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
fn_cell.tag.bytes[3] );
int bs = sizeof(wchar_t) * 1024;
wchar_t *buffer = malloc( bs );
memset( buffer, '\0', bs );
swprintf( buffer, bs,
L"Unexpected cell with tag %d (%4.4s) in function position",
fn_cell.tag.value, &fn_cell.tag.bytes[0] );
struct cons_pointer message =
c_string_to_lisp_string( 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.
*/
struct cons_pointer c_type( struct cons_pointer pointer ) {
char *buffer = malloc( TAGLENGTH + 1 );
memset( buffer, 0, TAGLENGTH + 1 );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( pointer );
strncpy( buffer, cell.tag.bytes, TAGLENGTH );
struct cons_pointer result = c_string_to_lisp_string( buffer );
free( buffer );
for (int i = TAGLENGTH; i >= 0; i--)
{
result = make_string((wchar_t)cell.tag.bytes[i], result);
}
return result;
}
@ -408,14 +407,12 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
struct cons_pointer
lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
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_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 ) {
case CONSTV:
{
@ -430,7 +427,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( nilp( canonical ) ) {
struct cons_pointer message =
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] );
result = throw_exception( message, frame_pointer );
} else {
@ -522,7 +519,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
result =
make_exception( make_cons
( 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 ) ),
frame_pointer );
}
@ -556,7 +553,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
result =
make_exception( make_cons
( 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 ) ),
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 );
} else {
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 );
}
@ -635,7 +632,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = cell.payload.string.cdr;
} else {
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 );
}
@ -850,7 +847,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
done = true;
} else {
result = throw_exception( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ),
( L"Arguments to `cond` must be lists" ),
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 ) {
while ( stringp( pointer ) || symbolp( 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' ) {
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 );
break;
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,
cell.payload.lambda.
body ) ) );
@ -140,7 +140,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"nil" );
break;
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,
cell.payload.lambda.
body ) ) );
@ -190,6 +190,9 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case TRUETV:
fwprintf( output, L"t" );
break;
case WRITETV:
fwprintf( output, L"(Output stream)" );
break;
default:
fwprintf( stderr,
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 (!)
*/
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 ) );
}
@ -71,8 +71,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
if ( feof( input ) ) {
result =
make_exception( c_string_to_lisp_string
( "End of file while reading" ), frame_pointer );
throw_exception( c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer );
} else {
switch ( c ) {
case ';':
@ -81,7 +81,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
break;
case EOF:
result = throw_exception( c_string_to_lisp_string
( "End of input while reading" ),
( L"End of input while reading" ),
frame_pointer );
break;
case '\'':
@ -136,8 +136,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
result = read_symbol( input, c );
} else {
result =
make_exception( make_cons( c_string_to_lisp_string
( "Unrecognised start of input character" ),
throw_exception( make_cons( c_string_to_lisp_string
( L"Unrecognised start of input character" ),
make_string( c, NIL ) ),
frame_pointer );
}
@ -170,23 +170,23 @@ struct cons_pointer read_number( struct stack_frame *frame,
if ( negative ) {
initial = fgetwc( input );
}
#ifdef DEBUG
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
#endif
debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial );
for ( c = initial; iswdigit( c )
|| c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) {
if ( seen_period || dividend != 0 ) {
return make_exception( c_string_to_lisp_string
( "Malformed number: too many periods" ),
return throw_exception( c_string_to_lisp_string
( L"Malformed number: too many periods" ),
frame_pointer );
} else {
seen_period = true;
}
} else if ( c == btowc( '/' ) ) {
if ( seen_period || dividend > 0 ) {
return make_exception( c_string_to_lisp_string
( "Malformed number: dividend of rational must be integer" ),
return throw_exception( c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ),
frame_pointer );
} else {
dividend = negative ? 0 - accumulator : accumulator;
@ -195,11 +195,11 @@ struct cons_pointer read_number( struct stack_frame *frame,
}
} else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
#ifdef DEBUG
fwprintf( stderr,
debug_printf( DEBUG_IO,
L"Added character %c, accumulator now %ld\n",
c, accumulator );
#endif
if ( seen_period ) {
places_of_decimals++;
}
@ -243,10 +243,8 @@ struct cons_pointer read_list( struct stack_frame *frame,
FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
if ( initial != ')' ) {
#ifdef DEBUG
fwprintf( stderr,
debug_printf( DEBUG_IO,
L"read_list starting '%C' (%d)\n", initial, initial );
#endif
struct cons_pointer car =
read_continuation( frame, frame_pointer, input,
initial );

62
src/repl.c
View file

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