From 8231c74baea4ce656730ff7a40e39636b009af02 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 28 Dec 2018 22:41:00 +0000 Subject: [PATCH 001/101] Various fixes while trying to make `defun!` work It still doesn't, but I think it's VERY close! --- README.md | 6 +++++ src/debug.h | 1 + src/memory/dump.c | 10 +++++++- src/ops/intern.c | 39 ++++++++++++++----------------- src/ops/lispops.c | 2 +- utils_src/debugflags/debugflags.c | 4 +++- 6 files changed, 37 insertions(+), 25 deletions(-) diff --git a/README.md b/README.md index caa6375..953a83c 100644 --- a/README.md +++ b/README.md @@ -4,6 +4,12 @@ Very Nearly a Big Lisp Environment tl,dr: look at the [[wiki]]. +## State of play + +### Version 0.0.4 + +Has working rational number arithmetic, as well as integer and real number arithmetic. The stack is now in vector space, but vector space is not yet properly garbage collected. `defun` does not yet work, so although Lisp functions can be defined the syntax is pretty clunky. So you *can* start to do things with this, but you should probably wait for at least a 0.1.0 release! + ## Introduction Long ago when the world was young, I worked on Xerox Dandelion and Daybreak machines which ran Interlisp-D, and Acorn Cambridge Workstation and Archimedes machines which ran Cambridge Lisp (derived from Portable Standard Lisp). At the same time, Lisp Machines Inc, Symbolics, Thinking Machines, Texas Instruments and probably various other companies I've either forgotten or didn't know about built other varieties of dedicated Lisp machines which ran Lisp right down to the metal, with no operating system under them. Those machines were not only far superior to any other contemporary machines; they were also far superior to any machines we've built since. But they were expensive, and UNIX machines with the same raw compute power became very much cheaper; and so they died. diff --git a/src/debug.h b/src/debug.h index 22f5591..acd67fe 100644 --- a/src/debug.h +++ b/src/debug.h @@ -21,6 +21,7 @@ #define DEBUG_BOOTSTRAP 32 #define DEBUG_IO 64 #define DEBUG_REPL 128 +#define DEBUG_BIND 256 extern int verbosity; diff --git a/src/memory/dump.c b/src/memory/dump.c index e88332a..cf26bb5 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -85,13 +85,21 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { cell.payload.integer.value, cell.count ); break; case LAMBDATV: - fwprintf( output, L"\t\tLambda cell; args: " ); + fwprintf( output, L"\t\tLambda cell;\n\t\t args: " ); print( output, cell.payload.lambda.args ); fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); + fputws( L"\n", output); break; case NILTV: break; + case NLAMBDATV: + fwprintf( output, L"\t\tNlambda cell; \n\t\targs: " ); + print( output, cell.payload.lambda.args ); + fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + fputws( L"\n", output); + break; case RATIOTV: fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", diff --git a/src/ops/intern.c b/src/ops/intern.c index 27c745d..03da271 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -57,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_space_object entry = pointer2cell( pointer2cell( next ).payload.cons.car ); - debug_print( L"Internedp: checking whether `", DEBUG_ALLOC ); - debug_print_object( key, DEBUG_ALLOC ); - debug_print( L"` equals `", DEBUG_ALLOC ); - debug_print_object( entry.payload.cons.car, DEBUG_ALLOC ); - debug_print( L"`\n", DEBUG_ALLOC ); + debug_print( L"Internedp: checking whether `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` equals `", DEBUG_BIND ); + debug_print_object( entry.payload.cons.car, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); if ( equal( key, entry.payload.cons.car ) ) { result = entry.payload.cons.car; } } } else { - debug_print( L"`", DEBUG_ALLOC ); - debug_print_object( key, DEBUG_ALLOC ); - debug_print( L"` is a ", DEBUG_ALLOC ); - debug_print_object( c_type( key ), DEBUG_ALLOC ); - debug_print( L", not a SYMB", DEBUG_ALLOC ); + debug_print( L"`", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` is a ", DEBUG_BIND ); + debug_print_object( c_type( key ), DEBUG_BIND ); + debug_print( L", not a SYMB", DEBUG_BIND ); } return result; @@ -111,11 +111,11 @@ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer store ) { - debug_print(L"Binding ", DEBUG_ALLOC); - debug_print_object(key, DEBUG_ALLOC); - debug_print(L" to ", DEBUG_ALLOC); - debug_print_object(value, DEBUG_ALLOC); - debug_println(DEBUG_ALLOC); + debug_print(L"Binding ", DEBUG_BIND); + debug_print_object(key, DEBUG_BIND); + debug_print(L" to ", DEBUG_BIND); + debug_print_object(value, DEBUG_BIND); + debug_println( DEBUG_BIND); return make_cons( make_cons( key, value ), store ); } @@ -127,16 +127,11 @@ bind( struct cons_pointer key, struct cons_pointer value, */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ) { - debug_print( L"Entering deep_bind\n", DEBUG_ALLOC ); - debug_print( L"\tSetting ", DEBUG_ALLOC ); - debug_print_object( key, DEBUG_ALLOC ); - debug_print( L" to ", DEBUG_ALLOC ); - debug_print_object( value, DEBUG_ALLOC ); - debug_print( L"\n", DEBUG_ALLOC ); + debug_print( L"Entering deep_bind\n", DEBUG_BIND ); oblist = bind( key, value, oblist ); - debug_print( L"Leaving deep_bind\n", DEBUG_ALLOC ); + debug_print( L"Leaving deep_bind\n", DEBUG_BIND ); return oblist; } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 82746e0..2be19b6 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -375,7 +375,7 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( pointer ); - for (int i = TAGLENGTH; i >= 0; i--) + for (int i = TAGLENGTH -1; i >= 0; i--) { result = make_string((wchar_t)cell.tag.bytes[i], result); } diff --git a/utils_src/debugflags/debugflags.c b/utils_src/debugflags/debugflags.c index a9850d1..2ad04ce 100644 --- a/utils_src/debugflags/debugflags.c +++ b/utils_src/debugflags/debugflags.c @@ -13,6 +13,7 @@ #define DEBUG_BOOTSTRAP 32 #define DEBUG_IO 64 #define DEBUG_REPL 128 +#define DEBUG_BIND 256 int check_level( int v, int level, char * name) { int result = 0; @@ -37,7 +38,8 @@ int main( int argc, char *argv[] ) { 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"); + check_level(v, DEBUG_REPL, "DEBUG_REPL") + + check_level(v, DEBUG_BIND, "DEBUG_BIND"); printf("\t%d matches\n", matches); } } From 40e1f3ca64d1fcbfe7371c1708f2c80188789e9f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 29 Dec 2018 07:40:01 +0000 Subject: [PATCH 002/101] Whitespace only changes --- src/arith/peano.c | 4 +- src/arith/ratio.c | 20 ++-- src/debug.c | 20 ++-- src/debug.h | 2 +- src/init.c | 68 ++++++------- src/memory/conspage.c | 29 +++--- src/memory/consspaceobject.c | 6 +- src/memory/dump.c | 25 ++--- src/memory/stack.c | 65 ++++++------ src/memory/stack.h | 2 +- src/memory/vectorspace.c | 26 ++--- src/ops/equal.c | 4 +- src/ops/intern.c | 34 +++---- src/ops/lispops.c | 189 ++++++++++++++++++----------------- src/ops/print.c | 8 +- src/ops/read.c | 25 ++--- src/repl.c | 25 +++-- 17 files changed, 283 insertions(+), 269 deletions(-) diff --git a/src/arith/peano.c b/src/arith/peano.c index 9f5e0fb..d040e28 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -412,8 +412,8 @@ struct cons_pointer inverse( struct cons_pointer frame, case RATIOTV: result = make_ratio( frame, make_integer( 0 - - to_long_int( cell.payload. - ratio.dividend ) ), + to_long_int( cell.payload.ratio. + dividend ) ), cell.payload.ratio.divisor ); break; case REALTV: diff --git a/src/arith/ratio.c b/src/arith/ratio.c index ca83335..31dd0a2 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -61,10 +61,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg ) ) { int64_t ddrv = - pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). - payload.integer.value, drrv = - pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). - payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); + pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload. + integer.value, drrv = + pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload. + integer.value, gcd = greatest_common_divisor( ddrv, drrv ); if ( gcd > 1 ) { if ( drrv / gcd == 1 ) { @@ -117,7 +117,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, lcm = least_common_multiple( dr1v, dr2v ), m1 = lcm / dr1v, m2 = lcm / dr2v; - debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); + debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, + m1, m2 ); if ( dr1v == dr2v ) { r = make_ratio( frame_pointer, @@ -201,11 +202,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload. - ratio.divisor, - pointer2cell( arg2 ).payload. - ratio.dividend ), - result = + pointer2cell( arg2 ).payload.ratio. + divisor, + pointer2cell( arg2 ).payload.ratio. + dividend ), result = multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); diff --git a/src/debug.c b/src/debug.c index b21f4af..eba31e8 100644 --- a/src/debug.c +++ b/src/debug.c @@ -61,15 +61,15 @@ void debug_println( int level ) { * `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 +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 } /** @@ -92,7 +92,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 ); + fwide( stderr, 1 ); dump_object( stderr, pointer ); } #endif diff --git a/src/debug.h b/src/debug.h index acd67fe..72fa020 100644 --- a/src/debug.h +++ b/src/debug.h @@ -27,7 +27,7 @@ extern int verbosity; void debug_print( wchar_t *message, int level ); void debug_println( int level ); -void debug_printf( int level, wchar_t * format, ...); +void debug_printf( int level, wchar_t *format, ... ); void debug_print_object( struct cons_pointer pointer, int level ); void debug_dump_object( struct cons_pointer pointer, int level ); diff --git a/src/init.c b/src/init.c index d81aa00..4a2032d 100644 --- a/src/init.c +++ b/src/init.c @@ -93,45 +93,45 @@ int main( int argc, char *argv[] ) { /* * primitive function operations */ - 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( 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( L"+", &lisp_add ); - bind_function( L"*", &lisp_multiply ); - bind_function( L"-", &lisp_subtract ); - bind_function( L"/", &lisp_divide ); - bind_function( L"=", &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( 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 ); + 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 ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index cf87028..bf3819c 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -66,7 +66,8 @@ void make_cons_page( ) { cell->count = MAXREFERENCE; cell->payload.free.car = NIL; cell->payload.free.cdr = NIL; - debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" ); + debug_printf( DEBUG_ALLOC, + L"Allocated special cell NIL\n" ); break; case 1: /* @@ -80,7 +81,8 @@ void make_cons_page( ) { cell->payload.free.cdr = ( struct cons_pointer ) { 0, 1 }; - debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" ); + debug_printf( DEBUG_ALLOC, + L"Allocated special cell T\n" ); break; } } else { @@ -98,8 +100,8 @@ void make_cons_page( ) { initialised_cons_pages++; } else { debug_printf( DEBUG_ALLOC, - L"FATAL: Failed to allocate memory for cons page %d\n", - initialised_cons_pages ); + L"FATAL: Failed to allocate memory for cons page %d\n", + initialised_cons_pages ); exit( 1 ); } @@ -164,8 +166,9 @@ void free_cell( struct cons_pointer pointer ) { case VECTORPOINTTV: /* for vector space pointers, free the actual vector-space * object. Dangerous! */ - debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n", - cell->payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, + L"About to free vector-space object at %ld\n", + cell->payload.vectorp.address ); //free( ( void * ) cell->payload.vectorp.address ); break; @@ -179,13 +182,13 @@ void free_cell( struct cons_pointer pointer ) { freelist = pointer; } else { 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 ); + L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", + cell->count, pointer.page, pointer.offset ); } } else { debug_printf( DEBUG_ALLOC, - L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", - pointer.page, pointer.offset ); + L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", + pointer.page, pointer.offset ); } } @@ -216,8 +219,8 @@ struct cons_pointer allocate_cell( char *tag ) { cell->payload.cons.cdr = NIL; debug_printf( DEBUG_ALLOC, - L"Allocated cell of type '%s' at %d, %d \n", tag, - result.page, result.offset ); + L"Allocated cell of type '%s' at %d, %d \n", tag, + result.page, result.offset ); } else { debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); } @@ -239,6 +242,6 @@ void initialise_cons_pages( ) { conspageinitihasbeencalled = true; } else { 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" ); } } diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index f5cc8b8..31927d8 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -183,10 +183,10 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { * cell->payload.string.cdr = tsil */ cell->payload.string.cdr.offset = tail.offset; } else { - // TODO: should throw an exception! + // TODO: should throw an exception! debug_printf( DEBUG_ALLOC, - L"Warning: only NIL and %s can be prepended to %s\n", - tag, tag ); + L"Warning: only NIL and %s can be prepended to %s\n", + tag, tag ); } return pointer; diff --git a/src/memory/dump.c b/src/memory/dump.c index cf26bb5..d3a53d3 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -67,8 +67,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { cell.payload.cons.car.offset, cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset, cell.count ); - print( output, pointer); - fputws( L"\n", output); + print( output, pointer ); + fputws( L"\n", output ); break; case EXCEPTIONTV: fwprintf( output, L"\t\tException cell: " ); @@ -89,7 +89,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { print( output, cell.payload.lambda.args ); fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); - fputws( L"\n", output); + fputws( L"\n", output ); break; case NILTV: break; @@ -98,15 +98,15 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { print( output, cell.payload.lambda.args ); fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); - fputws( L"\n", output); + fputws( L"\n", output ); break; case RATIOTV: fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); break; case READTV: fwprintf( output, L"\t\tInput stream\n" ); @@ -130,10 +130,11 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { struct vector_space_object *vso = cell.payload.vectorp.address; fwprintf( output, 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); - } + &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 ); diff --git a/src/memory/stack.c b/src/memory/stack.c index f91d896..f036402 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -26,15 +26,15 @@ #include "stack.h" #include "vectorspace.h" -void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) { - debug_printf(DEBUG_STACK, L"Setting register %d to ", reg); - debug_print_object(value, DEBUG_STACK); - debug_println(DEBUG_STACK); - frame->arg[reg++] = value; - inc_ref(value); - if (reg > frame->args) { - frame->args = reg; - } +void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) { + debug_printf( DEBUG_STACK, L"Setting register %d to ", reg ); + debug_print_object( value, DEBUG_STACK ); + debug_println( DEBUG_STACK ); + frame->arg[reg++] = value; + inc_ref( value ); + if ( reg > frame->args ) { + frame->args = reg; + } } @@ -49,8 +49,8 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { if ( vectorpointp( pointer ) && stackframep( vso ) ) { result = ( struct stack_frame * ) &( vso->payload ); - debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n", - result ); + 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_STACK ); } @@ -97,7 +97,7 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { } } debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); - debug_dump_object( result, DEBUG_ALLOC); + debug_dump_object( result, DEBUG_ALLOC ); return result; } @@ -124,7 +124,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, } else { struct stack_frame *frame = get_stack_frame( result ); - while ( frame->args < args_in_frame && consp( args )) { + while ( frame->args < args_in_frame && consp( args ) ) { /* iterate down the arg list filling in the arg slots in the * frame. When there are no more slots, if there are still args, * stash them on more */ @@ -136,19 +136,21 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, * processor to be evaled in parallel; but see notes here: * https://github.com/simon-brooke/post-scarcity/wiki/parallelism */ - struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env); - if ( exceptionp( val ) ) { - 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 ); - } - - args = cell.payload.cons.cdr; + struct cons_pointer val = + eval_form( frame, result, cell.payload.cons.car, env ); + if ( exceptionp( val ) ) { + 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 ); } + args = cell.payload.cons.cdr; + } + if ( !exceptionp( result ) ) { if ( consp( args ) ) { /* if we still have args, eval them and stick the values on `more` */ @@ -190,7 +192,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, } else { struct stack_frame *frame = get_stack_frame( result ); - while ( frame->args < args_in_frame && !nilp( args )) { + while ( frame->args < args_in_frame && !nilp( args ) ) { /* iterate down the arg list filling in the arg slots in the * frame. When there are no more slots, if there are still args, * stash them on more */ @@ -240,7 +242,7 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { struct stack_frame *frame = get_stack_frame( frame_pointer ); if ( frame != NULL ) { - fwprintf( output, L"Stack frame with %d arguments:\n", frame->args); + fwprintf( output, L"Stack frame with %d arguments:\n", frame->args ); for ( int arg = 0; arg < frame->args; arg++ ) { struct cons_space_object cell = pointer2cell( frame->arg[arg] ); @@ -252,12 +254,11 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { print( output, frame->arg[arg] ); fputws( L"\n", output ); } - if (!nilp(frame->more)) - { - fputws( L"More: \t", output ); - print( output, frame->more ); - fputws( L"\n", output ); - } + if ( !nilp( frame->more ) ) { + fputws( L"More: \t", output ); + print( output, frame->more ); + fputws( L"\n", output ); + } } } diff --git a/src/memory/stack.h b/src/memory/stack.h index 79cd1e2..189ff6b 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -41,7 +41,7 @@ */ //#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);} -void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value); +void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ); struct stack_frame *get_stack_frame( struct cons_pointer pointer ); diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index c30f120..3aef0f1 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -36,11 +36,12 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); debug_printf( DEBUG_ALLOC, - L"make_vec_pointer: tag written, about to set pointer address to %p\n", - address ); + L"make_vec_pointer: tag written, about to set pointer address to %p\n", + address ); cell->payload.vectorp.address = address; - debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", - cell->payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, + L"make_vec_pointer: all good, returning pointer to %p\n", + cell->payload.vectorp.address ); debug_dump_object( pointer, DEBUG_ALLOC ); @@ -67,8 +68,8 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { if ( vso != NULL ) { debug_printf( DEBUG_ALLOC, - L"make_vso: about to write tag '%s' into vso at %p\n", tag, - vso ); + 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 ); debug_dump_object( result, DEBUG_ALLOC ); @@ -79,18 +80,19 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { #ifdef DEBUG 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 ); + 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 ) { debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n", - total_size, padded ); + total_size, padded ); } #endif } #ifdef DEBUG - debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n", - pointer2cell( result ).payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, + L"make_vso: all good, returning pointer to %p\n", + pointer2cell( result ).payload.vectorp.address ); #endif return result; diff --git a/src/ops/equal.c b/src/ops/equal.c index 0f0597c..ebb085e 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload. - string.cdr ) ) ); + && end_of_string( cell_b->payload.string. + cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/ops/intern.c b/src/ops/intern.c index 03da271..e36437d 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -57,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_space_object entry = pointer2cell( pointer2cell( next ).payload.cons.car ); - debug_print( L"Internedp: checking whether `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"` equals `", DEBUG_BIND ); - debug_print_object( entry.payload.cons.car, DEBUG_BIND ); - debug_print( L"`\n", DEBUG_BIND ); + debug_print( L"Internedp: checking whether `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` equals `", DEBUG_BIND ); + debug_print_object( entry.payload.cons.car, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); if ( equal( key, entry.payload.cons.car ) ) { result = entry.payload.cons.car; } } } else { - debug_print( L"`", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"` is a ", DEBUG_BIND ); - debug_print_object( c_type( key ), DEBUG_BIND ); - debug_print( L", not a SYMB", DEBUG_BIND ); + debug_print( L"`", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` is a ", DEBUG_BIND ); + debug_print_object( c_type( key ), DEBUG_BIND ); + debug_print( L", not a SYMB", DEBUG_BIND ); } return result; @@ -111,11 +111,11 @@ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer store ) { - debug_print(L"Binding ", DEBUG_BIND); - debug_print_object(key, DEBUG_BIND); - debug_print(L" to ", DEBUG_BIND); - debug_print_object(value, DEBUG_BIND); - debug_println( DEBUG_BIND); + debug_print( L"Binding ", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L" to ", DEBUG_BIND ); + debug_print_object( value, DEBUG_BIND ); + debug_println( DEBUG_BIND ); return make_cons( make_cons( key, value ), store ); } @@ -127,11 +127,11 @@ bind( struct cons_pointer key, struct cons_pointer value, */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ) { - debug_print( L"Entering deep_bind\n", DEBUG_BIND ); + debug_print( L"Entering deep_bind\n", DEBUG_BIND ); oblist = bind( key, value, oblist ); - debug_print( L"Leaving deep_bind\n", DEBUG_BIND ); + debug_print( L"Leaving deep_bind\n", DEBUG_BIND ); return oblist; } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 2be19b6..b0a1a7e 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -212,7 +212,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, names = c_cdr( names ); } - /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ + /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ } else if ( symbolp( names ) ) { /* if `names` is a symbol, rather than a list of symbols, * then bind a list of the values of args to that symbol. */ @@ -255,8 +255,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - debug_print(L"Entering c_apply\n", DEBUG_EVAL); - struct cons_pointer result = NIL; + debug_print( L"Entering c_apply\n", DEBUG_EVAL ); + struct cons_pointer result = NIL; struct cons_pointer fn_pointer = eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env ); @@ -264,103 +264,107 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( exceptionp( fn_pointer ) ) { result = fn_pointer; } else { - struct cons_space_object fn_cell = pointer2cell( fn_pointer ); - struct cons_pointer args = c_cdr( frame->arg[0] ); + struct cons_space_object fn_cell = pointer2cell( fn_pointer ); + struct cons_pointer args = c_cdr( frame->arg[0] ); - switch ( fn_cell.tag.value ) { - case EXCEPTIONTV: - /* just pass exceptions straight back */ - result = fn_pointer; - break; - case FUNCTIONTV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = get_stack_frame( next_pointer ); + switch ( fn_cell.tag.value ) { + case EXCEPTIONTV: + /* just pass exceptions straight back */ + result = fn_pointer; + break; + case FUNCTIONTV: + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); - result = - ( *fn_cell.payload.function.executable ) ( next, - next_pointer, - env ); - dec_ref( next_pointer ); - } - } - break; - case LAMBDATV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = get_stack_frame( next_pointer ); - result = eval_lambda( fn_cell, next, next_pointer, env ); - if ( !exceptionp( result ) ) { + result = + ( *fn_cell.payload.function.executable ) ( next, + next_pointer, + env ); dec_ref( next_pointer ); } } - } - break; - case NLAMBDATV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = eval_lambda( fn_cell, next, next_pointer, env ); + break; + case LAMBDATV: + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); + } + } + } + break; + case NLAMBDATV: + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); dec_ref( next_pointer ); + } } - } - break; - case SPECIALTV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - result = - ( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ), - next_pointer, - env ); - debug_print(L"Special form returning: ", DEBUG_EVAL); - debug_print_object(result, DEBUG_EVAL); - debug_println(DEBUG_EVAL); - dec_ref( next_pointer ); + break; + case SPECIALTV: + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); + debug_print( L"Special form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + dec_ref( next_pointer ); + } } - } - break; - default: - { - 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 ); - result = throw_exception( message, frame_pointer ); - } - } + break; + default: + { + 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 ); + result = throw_exception( message, frame_pointer ); + } + } } - debug_print(L"c_apply: returning: ", DEBUG_EVAL); - debug_print_object(result, DEBUG_EVAL); - debug_println(DEBUG_EVAL); + debug_print( L"c_apply: returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); return result; } @@ -375,9 +379,8 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( pointer ); - for (int i = TAGLENGTH -1; i >= 0; i--) - { - result = make_string((wchar_t)cell.tag.bytes[i], result); + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = make_string( ( wchar_t ) cell.tag.bytes[i], result ); } return result; diff --git a/src/ops/print.c b/src/ops/print.c index 49adca7..6b971ef 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -133,8 +133,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case LAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); + cell.payload. + lambda.body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); @@ -142,8 +142,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case NLAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( L"nlambda" ), make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); + cell.payload. + lambda.body ) ) ); break; case RATIOTV: print( output, cell.payload.ratio.dividend ); diff --git a/src/ops/read.c b/src/ops/read.c index a9b1ffe..69de893 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -72,7 +72,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, if ( feof( input ) ) { result = throw_exception( c_string_to_lisp_string - ( L"End of file while reading" ), frame_pointer ); + ( L"End of file while reading" ), frame_pointer ); } else { switch ( c ) { case ';': @@ -137,9 +137,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, } else { result = throw_exception( make_cons( c_string_to_lisp_string - ( L"Unrecognised start of input character" ), - make_string( c, NIL ) ), - frame_pointer ); + ( L"Unrecognised start of input character" ), + make_string( c, NIL ) ), + frame_pointer ); } break; } @@ -171,23 +171,24 @@ struct cons_pointer read_number( struct stack_frame *frame, initial = fgetwc( input ); } - debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial ); + debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, + initial ); for ( c = initial; iswdigit( c ) || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { if ( seen_period || dividend != 0 ) { return throw_exception( c_string_to_lisp_string - ( L"Malformed number: too many periods" ), - frame_pointer ); + ( L"Malformed number: too many periods" ), + frame_pointer ); } else { seen_period = true; } } else if ( c == btowc( '/' ) ) { if ( seen_period || dividend > 0 ) { return throw_exception( c_string_to_lisp_string - ( L"Malformed number: dividend of rational must be integer" ), - frame_pointer ); + ( L"Malformed number: dividend of rational must be integer" ), + frame_pointer ); } else { dividend = negative ? 0 - accumulator : accumulator; @@ -197,8 +198,8 @@ struct cons_pointer read_number( struct stack_frame *frame, accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); debug_printf( DEBUG_IO, - L"Added character %c, accumulator now %ld\n", - c, accumulator ); + L"Added character %c, accumulator now %ld\n", + c, accumulator ); if ( seen_period ) { places_of_decimals++; @@ -244,7 +245,7 @@ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer result = NIL; if ( initial != ')' ) { debug_printf( DEBUG_IO, - L"read_list starting '%C' (%d)\n", initial, initial ); + L"read_list starting '%C' (%d)\n", initial, initial ); struct cons_pointer car = read_continuation( frame, frame_pointer, input, initial ); diff --git a/src/repl.c b/src/repl.c index e0170b6..7914fd4 100644 --- a/src/repl.c +++ b/src/repl.c @@ -34,15 +34,18 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { struct cons_pointer result = NIL; 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 ); + 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 ); - result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist ); + result = + lisp_read( get_stack_frame( frame_pointer ), frame_pointer, + oblist ); dec_ref( frame_pointer ); } - debug_print( L"repl_read: returning\n", DEBUG_REPL ); + debug_print( L"repl_read: returning\n", DEBUG_REPL ); debug_dump_object( result, DEBUG_REPL ); return result; @@ -52,12 +55,12 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { * Dummy up a Lisp eval call with its own stack frame. */ struct cons_pointer repl_eval( struct cons_pointer input ) { - debug_print( L"Entered repl_eval\n", DEBUG_REPL ); + debug_print( L"Entered repl_eval\n", DEBUG_REPL ); struct cons_pointer result = NIL; result = eval_form( NULL, NIL, input, oblist ); - debug_print( L"repl_eval: returning\n", DEBUG_REPL ); + debug_print( L"repl_eval: returning\n", DEBUG_REPL ); debug_dump_object( result, DEBUG_REPL ); return result; @@ -68,11 +71,11 @@ struct cons_pointer repl_eval( struct cons_pointer input ) { */ struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer value ) { - debug_print( L"Entered repl_print\n", DEBUG_REPL ); + debug_print( L"Entered repl_print\n", DEBUG_REPL ); debug_dump_object( value, DEBUG_REPL ); struct cons_pointer result = - print( pointer2cell( stream_pointer ).payload.stream.stream, value ); - debug_print( L"repl_print: returning\n", DEBUG_REPL ); + print( pointer2cell( stream_pointer ).payload.stream.stream, value ); + debug_print( L"repl_print: returning\n", DEBUG_REPL ); debug_dump_object( result, DEBUG_REPL ); return result; @@ -88,7 +91,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 ) { - debug_print( L"Entered repl\n", DEBUG_REPL ); + debug_print( L"Entered repl\n", DEBUG_REPL ); struct cons_pointer input_stream = make_read_stream( in_stream ); inc_ref( input_stream ); @@ -113,5 +116,5 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, } dec_ref( input ); } - debug_print( L"Leaving repl\n", DEBUG_REPL ); + debug_print( L"Leaving repl\n", DEBUG_REPL ); } From ad806de65677da4fd5ae0feb9442c68b9684d818 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 29 Dec 2018 08:23:26 +0000 Subject: [PATCH 003/101] Freeing vector-space objects, apparently good. Not freeing enough cons-space objects, though! --- src/memory/conspage.c | 15 ++++++++++++++- src/memory/stack.c | 4 ++-- src/memory/vectorspace.c | 1 + 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/src/memory/conspage.c b/src/memory/conspage.c index bf3819c..3c32126 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -20,6 +20,8 @@ #include "conspage.h" #include "debug.h" #include "dump.h" +#include "stack.h" +#include "vectorspace.h" /** * Flag indicating whether conspage initialisation has been done. @@ -169,7 +171,18 @@ void free_cell( struct cons_pointer pointer ) { debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n", cell->payload.vectorp.address ); - //free( ( void * ) cell->payload.vectorp.address ); + struct vector_space_object *vso = cell->payload.vectorp.address; + + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + free_stack_frame(get_stack_frame(pointer)); + break; + } + + free( ( void * ) cell->payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, + L"Freed vector-space object at %ld\n", + cell->payload.vectorp.address ); break; } diff --git a/src/memory/stack.c b/src/memory/stack.c index f036402..da4c17d 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -222,14 +222,14 @@ void free_stack_frame( struct stack_frame *frame ) { /* * TODO: later, push it back on the stack-frame freelist */ + debug_print(L"Entering free_stack_frame\n", DEBUG_ALLOC); for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->arg[i] ); } if ( !nilp( frame->more ) ) { dec_ref( frame->more ); } - - free( frame ); + debug_print(L"Leaving free_stack_frame\n", DEBUG_ALLOC); } diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 3aef0f1..cf0b1d6 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -67,6 +67,7 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { struct vector_space_object *vso = malloc( padded ); if ( vso != NULL ) { + memset(vso, 0, padded); debug_printf( DEBUG_ALLOC, L"make_vso: about to write tag '%s' into vso at %p\n", tag, vso ); From 7b126ea979d57ddada0f6f470fa503ae44d29a68 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 29 Dec 2018 09:35:29 +0000 Subject: [PATCH 004/101] Garbage collection now much better, not good There's clearly still a lot of things getting incremented but not decremented. --- lisp/fact.lisp | 2 ++ src/init.c | 10 ++++++++++ src/memory/conspage.c | 4 ++-- src/memory/consspaceobject.c | 2 +- src/ops/intern.c | 3 +++ src/ops/lispops.c | 14 ++++++++++++-- src/repl.c | 10 +++++++++- 7 files changed, 39 insertions(+), 6 deletions(-) diff --git a/lisp/fact.lisp b/lisp/fact.lisp index 2f578a6..de1f12b 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -2,3 +2,5 @@ (lambda (n) (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) + +(fact 20) diff --git a/src/init.c b/src/init.c index 4a2032d..65a6b84 100644 --- a/src/init.c +++ b/src/init.c @@ -133,8 +133,18 @@ int main( int argc, char *argv[] ) { bind_special( L"quote", &lisp_quote ); bind_special( L"set!", &lisp_set_shriek ); + debug_print(L"Initialised oblist\n", DEBUG_BOOTSTRAP); + debug_dump_object(oblist, DEBUG_BOOTSTRAP); + repl( stdin, stdout, stderr, show_prompt ); + debug_print(L"Freeing oblist\n", DEBUG_BOOTSTRAP); + debug_printf(DEBUG_BOOTSTRAP, L"Oblist has %u references\n", pointer2cell(oblist).count); + debug_dump_object(oblist, DEBUG_BOOTSTRAP); + dec_ref(oblist); + debug_dump_object(oblist, DEBUG_BOOTSTRAP); + + if ( dump_at_end ) { dump_pages( stdout ); } diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 3c32126..4fa1108 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -169,7 +169,7 @@ void free_cell( struct cons_pointer pointer ) { /* for vector space pointers, free the actual vector-space * object. Dangerous! */ debug_printf( DEBUG_ALLOC, - L"About to free vector-space object at %ld\n", + L"About to free vector-space object at 0x%lx\n", cell->payload.vectorp.address ); struct vector_space_object *vso = cell->payload.vectorp.address; @@ -181,7 +181,7 @@ void free_cell( struct cons_pointer pointer ) { free( ( void * ) cell->payload.vectorp.address ); debug_printf( DEBUG_ALLOC, - L"Freed vector-space object at %ld\n", + L"Freed vector-space object at 0x%lx\n", cell->payload.vectorp.address ); break; diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 31927d8..6f89742 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -95,7 +95,7 @@ struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ +// inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ inc_ref( message ); inc_ref( frame_pointer ); diff --git a/src/ops/intern.c b/src/ops/intern.c index e36437d..29848a7 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -128,8 +128,11 @@ bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ) { debug_print( L"Entering deep_bind\n", DEBUG_BIND ); + struct cons_pointer old = oblist; oblist = bind( key, value, oblist ); + inc_ref(oblist); + dec_ref(old); debug_print( L"Leaving deep_bind\n", DEBUG_BIND ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index b0a1a7e..1d9f2d3 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -194,9 +194,11 @@ 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; - debug_print( L"eval_lambda called\n", DEBUG_EVAL ); + debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); + debug_println(DEBUG_LAMBDA); struct cons_pointer new_env = env; + inc_ref(new_env); struct cons_pointer names = cell.payload.lambda.args; struct cons_pointer body = cell.payload.lambda.body; @@ -236,11 +238,19 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer sexpr = c_car( body ); body = c_cdr( body ); - debug_print( L"In lambda: ", DEBUG_LAMBDA ); + debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); + debug_print_object(sexpr, DEBUG_LAMBDA); + debug_println( DEBUG_LAMBDA); result = eval_form( frame, frame_pointer, sexpr, new_env ); } + dec_ref(new_env); + + debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); + debug_print_object( result, DEBUG_LAMBDA); + debug_println(DEBUG_LAMBDA); + return result; } diff --git a/src/repl.c b/src/repl.c index 7914fd4..d07df94 100644 --- a/src/repl.c +++ b/src/repl.c @@ -112,9 +112,17 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, } break; } else { - repl_print( output_stream, repl_eval( input ) ); + struct cons_pointer val = repl_eval( input ); + inc_ref(val); + repl_print( output_stream, val ); + dec_ref(val); } + dec_ref( input ); } + + dec_ref(input_stream); + dec_ref(output_stream); + debug_print( L"Leaving repl\n", DEBUG_REPL ); } From 2ec5d373059cc28f257bb8dc91832e682aca2040 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 29 Dec 2018 16:39:20 +0000 Subject: [PATCH 005/101] Noticed that my notes files weren't being rendered by github Because .txt, not .md --- README.md | 2 +- notes/{connection-machine.txt => connection-machine.md} | 0 notes/{psh-architecture.txt => psh-architecture.md} | 0 3 files changed, 1 insertion(+), 1 deletion(-) rename notes/{connection-machine.txt => connection-machine.md} (100%) rename notes/{psh-architecture.txt => psh-architecture.md} (100%) diff --git a/README.md b/README.md index 953a83c..9c08aab 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ Very Nearly a Big Lisp Environment -tl,dr: look at the [[wiki]]. +tl,dr: look at the [wiki](wiki). ## State of play diff --git a/notes/connection-machine.txt b/notes/connection-machine.md similarity index 100% rename from notes/connection-machine.txt rename to notes/connection-machine.md diff --git a/notes/psh-architecture.txt b/notes/psh-architecture.md similarity index 100% rename from notes/psh-architecture.txt rename to notes/psh-architecture.md From c21a762413c71f4345fbf65b099fc6493ed2fd27 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 29 Dec 2018 20:03:06 +0000 Subject: [PATCH 006/101] Much better GC, still a few things being missed. --- .gitignore | 2 ++ src/arith/peano.c | 1 + src/init.c | 34 ++++++++++++++++++++++++++-------- src/memory/conspage.c | 1 + src/ops/lispops.c | 8 +++++++- src/ops/print.c | 24 ++++++++++++++++++------ 6 files changed, 55 insertions(+), 15 deletions(-) diff --git a/.gitignore b/.gitignore index 0742055..b428e03 100644 --- a/.gitignore +++ b/.gitignore @@ -30,3 +30,5 @@ log* \.settings/language\.settings\.xml utils_src/readprintwc/out + +*.dump diff --git a/src/arith/peano.c b/src/arith/peano.c index d040e28..a52f314 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -567,6 +567,7 @@ struct cons_pointer lisp_divide( struct struct cons_pointer one = make_integer( 1 ); struct cons_pointer ratio = make_ratio( frame_pointer, frame->arg[0], one ); + inc_ref( ratio ); result = divide_ratio_ratio( frame_pointer, ratio, frame->arg[1] ); diff --git a/src/init.c b/src/init.c index 65a6b84..9cbe701 100644 --- a/src/init.c +++ b/src/init.c @@ -30,15 +30,35 @@ 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 ) ); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref(n); + + /* TODO: where a function is not compiled from source, we could cache + * the name on the source pointer. Would make stack frames potentially + * more readable and aid debugging generally. */ + deep_bind( n, make_function( NIL, executable ) ); + + dec_ref(n); } 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 ), - make_special( NIL, executable ) ); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref(n); + + deep_bind( n, make_special( NIL, executable ) ); + + dec_ref(n); +} + +void bind_value( wchar_t *name, struct cons_pointer value) { + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref(n); + + deep_bind( n, value ); + + dec_ref(n); } int main( int argc, char *argv[] ) { @@ -87,8 +107,8 @@ int main( int argc, char *argv[] ) { /* * privileged variables (keywords) */ - deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL ); - deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE ); + bind_value( L"nil" , NIL ); + bind_value( L"t" , TRUE ); /* * primitive function operations @@ -139,8 +159,6 @@ int main( int argc, char *argv[] ) { repl( stdin, stdout, stderr, show_prompt ); debug_print(L"Freeing oblist\n", DEBUG_BOOTSTRAP); - debug_printf(DEBUG_BOOTSTRAP, L"Oblist has %u references\n", pointer2cell(oblist).count); - debug_dump_object(oblist, DEBUG_BOOTSTRAP); dec_ref(oblist); debug_dump_object(oblist, DEBUG_BOOTSTRAP); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 4fa1108..eee6d2d 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -145,6 +145,7 @@ void free_cell( struct cons_pointer pointer ) { break; case EXCEPTIONTV: dec_ref( cell->payload.exception.message ); + dec_ref( cell->payload.exception.frame ); break; case FUNCTIONTV: dec_ref( cell->payload.function.source ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 1d9f2d3..d94a2ff 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -198,7 +198,6 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, debug_println(DEBUG_LAMBDA); struct cons_pointer new_env = env; - inc_ref(new_env); struct cons_pointer names = cell.payload.lambda.args; struct cons_pointer body = cell.payload.lambda.body; @@ -214,6 +213,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, names = c_cdr( names ); } + inc_ref(new_env); + /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ } else if ( symbolp( names ) ) { /* if `names` is a symbol, rather than a list of symbols, @@ -232,6 +233,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } new_env = bind( names, vals, new_env ); + inc_ref(new_env); } while ( !nilp( body ) ) { @@ -242,6 +244,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, debug_print_object(sexpr, DEBUG_LAMBDA); debug_println( DEBUG_LAMBDA); + /* if a result is not the terminal result in the lambda, it's a + * side effect, and needs to be GCed */ + if (!nilp(result)) dec_ref(result); + result = eval_form( frame, frame_pointer, sexpr, new_env ); } diff --git a/src/ops/print.c b/src/ops/print.c index 6b971ef..6c0c6e7 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -130,20 +130,32 @@ 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( L"lambda" ), + case LAMBDATV: { + struct cons_pointer to_print = make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( cell.payload.lambda.args, cell.payload. - lambda.body ) ) ); + lambda.body )); + inc_ref(to_print); + + print( output, to_print ); + + dec_ref(to_print); + } break; case NILTV: fwprintf( output, L"nil" ); break; - case NLAMBDATV: - print( output, make_cons( c_string_to_lisp_symbol( L"nlambda" ), + case NLAMBDATV: { + struct cons_pointer to_print = make_cons( c_string_to_lisp_symbol( L"nlambda" ), make_cons( cell.payload.lambda.args, cell.payload. - lambda.body ) ) ); + lambda.body )); + inc_ref(to_print); + + print( output, to_print ); + + dec_ref(to_print); + } break; case RATIOTV: print( output, cell.payload.ratio.dividend ); From 342f0308d35f7fef87f73a29af4e856f44c8a7e0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 29 Dec 2018 22:30:07 +0000 Subject: [PATCH 007/101] The beginning of bignums is in place, tests still pass. --- src/arith/bignum.c | 14 ----- src/arith/bignum.h | 16 ----- src/arith/integer.c | 104 +++++++++++++++++++++++++++---- src/arith/integer.h | 6 +- src/arith/peano.c | 25 ++++---- src/arith/ratio.c | 25 ++++---- src/memory/conspage.c | 3 + src/memory/consspaceobject.h | 22 +------ src/ops/equal.c | 5 +- src/ops/read.c | 6 +- unit-tests/integer-allocation.sh | 4 +- 11 files changed, 134 insertions(+), 96 deletions(-) delete mode 100644 src/arith/bignum.c delete mode 100644 src/arith/bignum.h diff --git a/src/arith/bignum.c b/src/arith/bignum.c deleted file mode 100644 index a21a7df..0000000 --- a/src/arith/bignum.c +++ /dev/null @@ -1,14 +0,0 @@ -/* - * bignum.c - * - * Allocation of and operations on arbitrary precision integers. - * - * (c) 2018 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -/* - * Bignums generally follow Knuth, vol 2, 4.3. The word size is 64 bits, - * and words are stored in individual cons-space objects, comprising the - * word itself and a pointer to the next word in the number. - */ diff --git a/src/arith/bignum.h b/src/arith/bignum.h deleted file mode 100644 index 05c9073..0000000 --- a/src/arith/bignum.h +++ /dev/null @@ -1,16 +0,0 @@ -/** - * bignum.h - * - * functions for bignum cells. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __bignum_h -#define __bignum_h - - - -#endif diff --git a/src/arith/integer.c b/src/arith/integer.c index 5239746..7b14d22 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -8,8 +8,10 @@ */ #define _GNU_SOURCE +#include #include #include +#include #include "conspage.h" #include "consspaceobject.h" @@ -17,31 +19,109 @@ /** * return the numeric value of this cell, as a C primitive double, not - * as a cons-space object. Cell may in principle be any kind of number, - * but only integers and reals are so far implemented. + * as a cons-space object. Cell may in principle be any kind of number. */ long double numeric_value( struct cons_pointer pointer ) { - long double result = NAN; - struct cons_space_object *cell = &pointer2cell( pointer ); + long double result = NAN; + struct cons_space_object *cell = &pointer2cell( pointer ); - if ( integerp( pointer ) ) { - result = cell->payload.integer.value * 1.0; - } else if ( realp( pointer ) ) { - result = cell->payload.real.value; + switch (cell->tag.value) { + case INTEGERTV: + result = 1.0; + while (cell->tag.value == INTEGERTV) { + result = (result * LONG_MAX * cell->payload.integer.value); + cell = &pointer2cell(cell->payload.integer.more); } + break; + case RATIOTV: + result = numeric_value(cell->payload.ratio.dividend) / + numeric_value(cell->payload.ratio.divisor); + break; + case REALTV: + result = cell->payload.real.value; + break; + // default is NAN + } - return result; + return result; } /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer( int64_t value ) { - struct cons_pointer result = allocate_cell( INTEGERTAG ); +struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { + struct cons_pointer result = NIL; + + if (integerp(more) || nilp(more)) { + result = allocate_cell( INTEGERTAG ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; + cell->payload.integer.more = more; debug_dump_object( result, DEBUG_ARITH ); + } - return result; + return result; +} + +/** + * Return the sum of the integers pointed to by `a` and `b`. If either isn't + * an integer, will return nil. + */ +struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b) { + struct cons_pointer result = NIL; + int64_t carry = 0; + + if (integerp(a) && integerp(b)) { + while (!nilp(a) || !nilp(b) || carry != 0) { + int64_t av = integerp(a) ? pointer2cell(a).payload.integer.value : 0; + int64_t bv = integerp(b) ? pointer2cell(b).payload.integer.value : 0; + + __int128_t rv = av + bv + carry; + + if (rv > LONG_MAX || rv < LONG_MIN) { + carry = llabs(rv / LONG_MAX); + rv = rv % LONG_MAX; + } else { + carry = 0; + } + + result = make_integer( rv, result); + a = pointer2cell(a).payload.integer.more; + b = pointer2cell(b).payload.integer.more; + } + } + + return result; +} + +/** + * Return the product of the integers pointed to by `a` and `b`. If either isn't + * an integer, will return nil. + */ +struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b) { + struct cons_pointer result = NIL; + int64_t carry = 0; + + if (integerp(a) && integerp(b)) { + while (!nilp(a) || ! nilp(b) || carry != 0) { + int64_t av = integerp(a) ? pointer2cell(a).payload.integer.value : 1; + int64_t bv = integerp(b) ? pointer2cell(b).payload.integer.value : 1; + + __int128_t rv = (av * bv) + carry; + + if (rv > LONG_MAX || rv < LONG_MIN) { + carry = llabs(rv / LONG_MAX); + rv = rv % LONG_MAX; + } else { + carry = 0; + } + + result = make_integer( rv, result); + a = pointer2cell(a).payload.integer.more; + b = pointer2cell(b).payload.integer.more; + } + } + + return result; } diff --git a/src/arith/integer.h b/src/arith/integer.h index 00b94a6..9f9b984 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -16,6 +16,10 @@ long double numeric_value( struct cons_pointer pointer ); /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer( int64_t value ); +struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); + +struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b); + +struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index a52f314..56c2190 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -152,8 +152,7 @@ struct cons_pointer add_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer( cell1.payload.integer.value + - cell2.payload.integer.value ); + result = add_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -224,7 +223,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = make_integer( 0 ); + struct cons_pointer result = make_integer( 0, NIL ); struct cons_pointer tmp; for ( int i = 0; @@ -285,8 +284,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer( cell1.payload.integer.value * - cell2.payload.integer.value ); + result = multiply_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -361,7 +359,7 @@ struct cons_pointer lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = make_integer( 1 ); + struct cons_pointer result = make_integer( 1, NIL ); struct cons_pointer tmp; for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) @@ -404,7 +402,8 @@ struct cons_pointer inverse( struct cons_pointer frame, result = arg; break; case INTEGERTV: - result = make_integer( 0 - to_long_int( arg ) ); + // TODO: bignums + result = make_integer( 0 - to_long_int( arg ), NIL ); break; case NILTV: result = TRUE; @@ -413,7 +412,7 @@ struct cons_pointer inverse( struct cons_pointer frame, result = make_ratio( frame, make_integer( 0 - to_long_int( cell.payload.ratio. - dividend ) ), + dividend ), NIL ), cell.payload.ratio.divisor ); break; case REALTV: @@ -453,12 +452,12 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV: result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value ); + - cell1.payload.integer.value, NIL ); break; case RATIOTV:{ struct cons_pointer tmp = make_ratio( frame_pointer, frame->arg[0], - make_integer( 1 ) ); + make_integer( 1, NIL ) ); inc_ref( tmp ); result = subtract_ratio_ratio( frame_pointer, tmp, @@ -486,7 +485,7 @@ struct cons_pointer lisp_subtract( struct case INTEGERTV:{ struct cons_pointer tmp = make_ratio( frame_pointer, frame->arg[1], - make_integer( 1 ) ); + make_integer( 1, NIL ) ); inc_ref( tmp ); result = subtract_ratio_ratio( frame_pointer, frame->arg[0], @@ -564,7 +563,7 @@ struct cons_pointer lisp_divide( struct } break; case RATIOTV:{ - struct cons_pointer one = make_integer( 1 ); + struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer ratio = make_ratio( frame_pointer, frame->arg[0], one ); inc_ref( ratio ); @@ -592,7 +591,7 @@ struct cons_pointer lisp_divide( struct result = frame->arg[1]; break; case INTEGERTV:{ - struct cons_pointer one = make_integer( 1 ); + struct cons_pointer one = make_integer( 1, NIL ); inc_ref( one ); struct cons_pointer ratio = make_ratio( frame_pointer, frame->arg[1], one ); diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 31dd0a2..7b587e1 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -68,11 +68,11 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, if ( gcd > 1 ) { if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd ); + result = make_integer( ddrv / gcd , NIL); } else { result = - make_ratio( frame_pointer, make_integer( ddrv / gcd ), - make_integer( drrv / gcd ) ); + make_ratio( frame_pointer, make_integer( ddrv / gcd , NIL), + make_integer( drrv / gcd , NIL) ); } } } else { @@ -106,6 +106,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); + // TODO: to be entirely reworked for bignums. All vars must be lisp integers. int64_t dd1v = pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, dd2v = @@ -122,13 +123,13 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, if ( dr1v == dr2v ) { r = make_ratio( frame_pointer, - make_integer( dd1v + dd2v ), + make_integer( dd1v + dd2v, NIL ), cell1.payload.ratio.divisor ); } else { - struct cons_pointer dd1vm = make_integer( dd1v * m1 ), - dr1vm = make_integer( dr1v * m1 ), - dd2vm = make_integer( dd2v * m2 ), - dr2vm = make_integer( dr2v * m2 ), + struct cons_pointer dd1vm = make_integer( dd1v * m1, NIL ), + dr1vm = make_integer( dr1v * m1, NIL ), + dd2vm = make_integer( dd2v * m2, NIL ), + dr2vm = make_integer( dr2v * m2, NIL ), r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); @@ -173,7 +174,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1 ), + struct cons_pointer one = make_integer( 1, NIL ), ratio = make_ratio( frame_pointer, intarg, one ); result = add_ratio_ratio( frame_pointer, ratio, ratarg ); @@ -243,8 +244,8 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str ddrv = dd1v * dd2v, drrv = dr1v * dr2v; struct cons_pointer unsimplified = - make_ratio( frame_pointer, make_integer( ddrv ), - make_integer( drrv ) ); + make_ratio( frame_pointer, make_integer( ddrv, NIL ), + make_integer( drrv , NIL) ); result = simplify_ratio( frame_pointer, unsimplified ); if ( !eq( unsimplified, result ) ) { @@ -271,7 +272,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1 ), + struct cons_pointer one = make_integer( 1, NIL), ratio = make_ratio( frame_pointer, intarg, one ); result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index eee6d2d..975c9da 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -150,6 +150,9 @@ void free_cell( struct cons_pointer pointer ) { case FUNCTIONTV: dec_ref( cell->payload.function.source ); break; + case INTEGERTV: + dec_ref( cell->payload.integer.more); + break; case LAMBDATV: case NLAMBDATV: dec_ref( cell->payload.lambda.args ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 523fdaa..0cf44a7 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -29,12 +29,6 @@ * tag values, all of which must be 4 bytes. Must not collide with vector space tag values */ -/** - * A word within a bignum - arbitrary precision integer. - */ -#define BIGNUMTAG "BIGN" -#define BIGNUMTV 1313294658 - /** * An ordinary cons cell: 1397641027 */ @@ -168,11 +162,6 @@ */ #define nilp(conspoint) (check_tag(conspoint,NILTAG)) -/** - * true if conspointer points to a cons cell, else false - */ -#define bignump(conspoint) (check_tag(conspoint,BIGNUMTAG)) - /** * true if conspointer points to a cons cell, else false */ @@ -289,16 +278,6 @@ struct stack_frame { int args; }; -/** - * payload of a bignum cell. Intentionally similar to an integer payload, but - * with a next pointer. - */ -struct bignum_payload { - int64_t value; - struct cons_pointer next; -}; - - /** * payload of a cons cell. */ @@ -348,6 +327,7 @@ struct free_payload { */ struct integer_payload { int64_t value; + struct cons_pointer more; }; /** diff --git a/src/ops/equal.c b/src/ops/equal.c index ebb085e..877a8cc 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -85,8 +85,9 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { break; case INTEGERTV: result = - cell_a->payload.integer.value == - cell_b->payload.integer.value; + (cell_a->payload.integer.value == + cell_b->payload.integer.value) && + equal(cell_a->payload.integer.more, cell_b->payload.integer.more); break; case REALTV: { diff --git a/src/ops/read.c b/src/ops/read.c index 69de893..2a8522c 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -220,13 +220,13 @@ struct cons_pointer read_number( struct stack_frame *frame, result = make_real( rv ); } else if ( dividend != 0 ) { result = - make_ratio( frame_pointer, make_integer( dividend ), - make_integer( accumulator ) ); + make_ratio( frame_pointer, make_integer( dividend, NIL ), + make_integer( accumulator, NIL ) ); } else { if ( negative ) { accumulator = 0 - accumulator; } - result = make_integer( accumulator ); + result = make_integer( accumulator, NIL ); } debug_print( L"read_number returning\n", DEBUG_IO ); diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh index 5d07d90..ced92f2 100644 --- a/unit-tests/integer-allocation.sh +++ b/unit-tests/integer-allocation.sh @@ -1,8 +1,8 @@ #!/bin/bash value=354 -expected="Integer cell: value ${value}" -echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null +expected="Integer cell: value ${value}," +echo ${value} | target/psse -v5 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then From 489f0080447c5399dacb1aa8110f867e80b9c21d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 29 Dec 2018 23:44:28 +0000 Subject: [PATCH 008/101] Printing of bignums basically done, not tested. --- src/arith/integer.c | 198 ++++++++++++++++++++++++++------------- src/arith/integer.h | 9 +- src/arith/peano.c | 8 +- src/arith/ratio.c | 28 +++--- src/init.c | 44 ++++----- src/memory/conspage.c | 6 +- src/memory/dump.c | 8 +- src/memory/stack.c | 4 +- src/memory/vectorspace.c | 2 +- src/ops/equal.c | 11 ++- src/ops/intern.c | 4 +- src/ops/lispops.c | 30 +++--- src/ops/print.c | 48 +++++----- src/repl.c | 8 +- 14 files changed, 244 insertions(+), 164 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 7b14d22..be50013 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -12,116 +12,182 @@ #include #include #include +/* + * wide characters + */ +#include +#include #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +/** + * hexadecimal digits for printing numbers. + */ +const wchar_t *hex_digits = L"0123456789ABCDEF"; + +/* + * Doctrine from here on in is that ALL integers are bignums, it's just + * that integers less than 65 bits are bignums of one cell only. + * + * TODO: I have no idea at all how I'm going to print bignums! + */ + /** * return the numeric value of this cell, as a C primitive double, not * as a cons-space object. Cell may in principle be any kind of number. */ long double numeric_value( struct cons_pointer pointer ) { - long double result = NAN; - struct cons_space_object *cell = &pointer2cell( pointer ); + long double result = NAN; + struct cons_space_object *cell = &pointer2cell( pointer ); - switch (cell->tag.value) { - case INTEGERTV: - result = 1.0; - while (cell->tag.value == INTEGERTV) { - result = (result * LONG_MAX * cell->payload.integer.value); - cell = &pointer2cell(cell->payload.integer.more); + switch ( cell->tag.value ) { + case INTEGERTV: + result = 1.0; + while ( cell->tag.value == INTEGERTV ) { + result = ( result * LONG_MAX * cell->payload.integer.value ); + cell = &pointer2cell( cell->payload.integer.more ); + } + break; + case RATIOTV: + result = numeric_value( cell->payload.ratio.dividend ) / + numeric_value( cell->payload.ratio.divisor ); + break; + case REALTV: + result = cell->payload.real.value; + break; + // default is NAN } - break; - case RATIOTV: - result = numeric_value(cell->payload.ratio.dividend) / - numeric_value(cell->payload.ratio.divisor); - break; - case REALTV: - result = cell->payload.real.value; - break; - // default is NAN - } - return result; + return result; } /** * Allocate an integer cell representing this value and return a cons pointer to it. */ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if (integerp(more) || nilp(more)) { - result = allocate_cell( INTEGERTAG ); - struct cons_space_object *cell = &pointer2cell( result ); - cell->payload.integer.value = value; - cell->payload.integer.more = more; + if ( integerp( more ) || nilp( more ) ) { + result = allocate_cell( INTEGERTAG ); + struct cons_space_object *cell = &pointer2cell( result ); + cell->payload.integer.value = value; + cell->payload.integer.more = more; - debug_dump_object( result, DEBUG_ARITH ); - } + debug_dump_object( result, DEBUG_ARITH ); + } - return result; + return result; } /** * Return the sum of the integers pointed to by `a` and `b`. If either isn't * an integer, will return nil. */ -struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b) { - struct cons_pointer result = NIL; - int64_t carry = 0; +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ) { + struct cons_pointer result = NIL; + int64_t carry = 0; - if (integerp(a) && integerp(b)) { - while (!nilp(a) || !nilp(b) || carry != 0) { - int64_t av = integerp(a) ? pointer2cell(a).payload.integer.value : 0; - int64_t bv = integerp(b) ? pointer2cell(b).payload.integer.value : 0; + if ( integerp( a ) && integerp( b ) ) { + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + int64_t av = + integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + int64_t bv = + integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - __int128_t rv = av + bv + carry; + __int128_t rv = av + bv + carry; - if (rv > LONG_MAX || rv < LONG_MIN) { - carry = llabs(rv / LONG_MAX); - rv = rv % LONG_MAX; - } else { - carry = 0; - } + if ( rv > LONG_MAX || rv < LONG_MIN ) { + carry = llabs( rv / LONG_MAX ); + rv = rv % LONG_MAX; + } else { + carry = 0; + } - result = make_integer( rv, result); - a = pointer2cell(a).payload.integer.more; - b = pointer2cell(b).payload.integer.more; + result = make_integer( rv, result ); + a = pointer2cell( a ).payload.integer.more; + b = pointer2cell( b ).payload.integer.more; + } } - } - return result; + return result; } /** * Return the product of the integers pointed to by `a` and `b`. If either isn't * an integer, will return nil. */ -struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b) { - struct cons_pointer result = NIL; - int64_t carry = 0; +struct cons_pointer multiply_integers( struct cons_pointer a, + struct cons_pointer b ) { + struct cons_pointer result = NIL; + int64_t carry = 0; - if (integerp(a) && integerp(b)) { - while (!nilp(a) || ! nilp(b) || carry != 0) { - int64_t av = integerp(a) ? pointer2cell(a).payload.integer.value : 1; - int64_t bv = integerp(b) ? pointer2cell(b).payload.integer.value : 1; + if ( integerp( a ) && integerp( b ) ) { + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + int64_t av = + integerp( a ) ? pointer2cell( a ).payload.integer.value : 1; + int64_t bv = + integerp( b ) ? pointer2cell( b ).payload.integer.value : 1; - __int128_t rv = (av * bv) + carry; + __int128_t rv = ( av * bv ) + carry; - if (rv > LONG_MAX || rv < LONG_MIN) { - carry = llabs(rv / LONG_MAX); - rv = rv % LONG_MAX; - } else { - carry = 0; - } + if ( rv > LONG_MAX || rv < LONG_MIN ) { + carry = llabs( rv / LONG_MAX ); + rv = rv % LONG_MAX; + } else { + carry = 0; + } - result = make_integer( rv, result); - a = pointer2cell(a).payload.integer.more; - b = pointer2cell(b).payload.integer.more; + result = make_integer( rv, result ); + a = pointer2cell( a ).payload.integer.more; + b = pointer2cell( b ).payload.integer.more; + } } - } - return result; + return result; +} + +/** + * The general principle of printing a bignum is that you print the least + * significant digit in whatever base you're dealing with, divide through + * by the base, print the next, and carry on until you've none left. + * Obviously, that means you print from right to left. Given that we build + * strings from right to left, 'printing' an integer to a lisp string + * would seem reasonably easy. The problem is when you jump from one integer + * object to the next. 64 bit integers don't align with decimal numbers, so + * when we get to the last digit from one integer cell, we have potentially + * to be looking to the next. H'mmmm. + */ +struct cons_pointer integer_to_string( struct cons_pointer int_pointer, + int base ) { + struct cons_pointer result = NIL; + struct cons_space_object integer = pointer2cell( int_pointer ); + int64_t accumulator = integer.payload.integer.value; + bool is_negative = accumulator < 0; + accumulator = llabs( accumulator ); + + while ( accumulator > 0 ) { + while ( accumulator > base ) { + result = make_string( hex_digits[accumulator % base], result ); + accumulator = accumulator / base; + } + + if ( integerp( integer.payload.integer.more ) ) { + integer = pointer2cell( integer.payload.integer.more ); + int64_t i = integer.payload.integer.value; + + /* TODO: I don't believe it's as simple as this! */ + accumulator += ( base * ( i % base ) ); + result = make_string( hex_digits[accumulator % base], result ); + accumulator += ( base * ( i / base ) ); + } + } + + if ( is_negative ) { + result = make_string( L'-', result ); + } + + return result; } diff --git a/src/arith/integer.h b/src/arith/integer.h index 9f9b984..1eda28f 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -18,8 +18,13 @@ long double numeric_value( struct cons_pointer pointer ); */ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); -struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b); +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ); -struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b); +struct cons_pointer multiply_integers( struct cons_pointer a, + struct cons_pointer b ); + +struct cons_pointer integer_to_string( struct cons_pointer int_pointer, + int base ); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index 56c2190..3fb732a 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -411,8 +411,9 @@ struct cons_pointer inverse( struct cons_pointer frame, case RATIOTV: result = make_ratio( frame, make_integer( 0 - - to_long_int( cell.payload.ratio. - dividend ), NIL ), + to_long_int( cell.payload. + ratio.dividend ), + NIL ), cell.payload.ratio.divisor ); break; case REALTV: @@ -452,7 +453,8 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV: result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, NIL ); + - cell1.payload.integer.value, + NIL ); break; case RATIOTV:{ struct cons_pointer tmp = diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 7b587e1..95c9a8f 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -61,18 +61,18 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg ) ) { int64_t ddrv = - pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload. - integer.value, drrv = - pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload. - integer.value, gcd = greatest_common_divisor( ddrv, drrv ); + pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). + payload.integer.value, drrv = + pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). + payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); if ( gcd > 1 ) { if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd , NIL); + result = make_integer( ddrv / gcd, NIL ); } else { result = - make_ratio( frame_pointer, make_integer( ddrv / gcd , NIL), - make_integer( drrv / gcd , NIL) ); + make_ratio( frame_pointer, make_integer( ddrv / gcd, NIL ), + make_integer( drrv / gcd, NIL ) ); } } } else { @@ -106,7 +106,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); - // TODO: to be entirely reworked for bignums. All vars must be lisp integers. + // TODO: to be entirely reworked for bignums. All vars must be lisp integers. int64_t dd1v = pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, dd2v = @@ -203,10 +203,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload.ratio. - divisor, - pointer2cell( arg2 ).payload.ratio. - dividend ), result = + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), result = multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -245,7 +245,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str struct cons_pointer unsimplified = make_ratio( frame_pointer, make_integer( ddrv, NIL ), - make_integer( drrv , NIL) ); + make_integer( drrv, NIL ) ); result = simplify_ratio( frame_pointer, unsimplified ); if ( !eq( unsimplified, result ) ) { @@ -272,7 +272,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1, NIL), + struct cons_pointer one = make_integer( 1, NIL ), ratio = make_ratio( frame_pointer, intarg, one ); result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); diff --git a/src/init.c b/src/init.c index 9cbe701..773afb5 100644 --- a/src/init.c +++ b/src/init.c @@ -30,35 +30,35 @@ void bind_function( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref(n); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); - /* TODO: where a function is not compiled from source, we could cache - * the name on the source pointer. Would make stack frames potentially - * more readable and aid debugging generally. */ + /* TODO: where a function is not compiled from source, we could cache + * the name on the source pointer. Would make stack frames potentially + * more readable and aid debugging generally. */ deep_bind( n, make_function( NIL, executable ) ); - dec_ref(n); + dec_ref( n ); } void bind_special( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref(n); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); - deep_bind( n, make_special( NIL, executable ) ); + deep_bind( n, make_special( NIL, executable ) ); - dec_ref(n); + dec_ref( n ); } -void bind_value( wchar_t *name, struct cons_pointer value) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref(n); +void bind_value( wchar_t *name, struct cons_pointer value ) { + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); - deep_bind( n, value ); + deep_bind( n, value ); - dec_ref(n); + dec_ref( n ); } int main( int argc, char *argv[] ) { @@ -107,8 +107,8 @@ int main( int argc, char *argv[] ) { /* * privileged variables (keywords) */ - bind_value( L"nil" , NIL ); - bind_value( L"t" , TRUE ); + bind_value( L"nil", NIL ); + bind_value( L"t", TRUE ); /* * primitive function operations @@ -153,14 +153,14 @@ int main( int argc, char *argv[] ) { bind_special( L"quote", &lisp_quote ); bind_special( L"set!", &lisp_set_shriek ); - debug_print(L"Initialised oblist\n", DEBUG_BOOTSTRAP); - debug_dump_object(oblist, DEBUG_BOOTSTRAP); + debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); + debug_dump_object( oblist, DEBUG_BOOTSTRAP ); repl( stdin, stdout, stderr, show_prompt ); - debug_print(L"Freeing oblist\n", DEBUG_BOOTSTRAP); - dec_ref(oblist); - debug_dump_object(oblist, DEBUG_BOOTSTRAP); + debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); + dec_ref( oblist ); + debug_dump_object( oblist, DEBUG_BOOTSTRAP ); if ( dump_at_end ) { diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 975c9da..2aa8dce 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -151,7 +151,7 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.function.source ); break; case INTEGERTV: - dec_ref( cell->payload.integer.more); + dec_ref( cell->payload.integer.more ); break; case LAMBDATV: case NLAMBDATV: @@ -179,8 +179,8 @@ void free_cell( struct cons_pointer pointer ) { switch ( vso->header.tag.value ) { case STACKFRAMETV: - free_stack_frame(get_stack_frame(pointer)); - break; + free_stack_frame( get_stack_frame( pointer ) ); + break; } free( ( void * ) cell->payload.vectorp.address ); diff --git a/src/memory/dump.c b/src/memory/dump.c index d3a53d3..6601e92 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -103,10 +103,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case RATIOTV: fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload. - integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload. - integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ). + payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ). + payload.integer.value, cell.count ); break; case READTV: fwprintf( output, L"\t\tInput stream\n" ); diff --git a/src/memory/stack.c b/src/memory/stack.c index da4c17d..a1026b4 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -222,14 +222,14 @@ void free_stack_frame( struct stack_frame *frame ) { /* * TODO: later, push it back on the stack-frame freelist */ - debug_print(L"Entering free_stack_frame\n", DEBUG_ALLOC); + debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC ); for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->arg[i] ); } if ( !nilp( frame->more ) ) { dec_ref( frame->more ); } - debug_print(L"Leaving free_stack_frame\n", DEBUG_ALLOC); + debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC ); } diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index cf0b1d6..5ec14a8 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -67,7 +67,7 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { struct vector_space_object *vso = malloc( padded ); if ( vso != NULL ) { - memset(vso, 0, padded); + memset( vso, 0, padded ); debug_printf( DEBUG_ALLOC, L"make_vso: about to write tag '%s' into vso at %p\n", tag, vso ); diff --git a/src/ops/equal.c b/src/ops/equal.c index 877a8cc..bade594 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -80,14 +80,15 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload.string. - cdr ) ) ); + && end_of_string( cell_b->payload. + string.cdr ) ) ); break; case INTEGERTV: result = - (cell_a->payload.integer.value == - cell_b->payload.integer.value) && - equal(cell_a->payload.integer.more, cell_b->payload.integer.more); + ( cell_a->payload.integer.value == + cell_b->payload.integer.value ) && + equal( cell_a->payload.integer.more, + cell_b->payload.integer.more ); break; case REALTV: { diff --git a/src/ops/intern.c b/src/ops/intern.c index 29848a7..9d2387c 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -131,8 +131,8 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { struct cons_pointer old = oblist; oblist = bind( key, value, oblist ); - inc_ref(oblist); - dec_ref(old); + inc_ref( oblist ); + dec_ref( old ); debug_print( L"Leaving deep_bind\n", DEBUG_BIND ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d94a2ff..c83287d 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -195,7 +195,7 @@ 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; debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); - debug_println(DEBUG_LAMBDA); + debug_println( DEBUG_LAMBDA ); struct cons_pointer new_env = env; struct cons_pointer names = cell.payload.lambda.args; @@ -213,7 +213,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, names = c_cdr( names ); } - inc_ref(new_env); + inc_ref( new_env ); /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ } else if ( symbolp( names ) ) { @@ -233,7 +233,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } new_env = bind( names, vals, new_env ); - inc_ref(new_env); + inc_ref( new_env ); } while ( !nilp( body ) ) { @@ -241,21 +241,22 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, body = c_cdr( body ); debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); - debug_print_object(sexpr, DEBUG_LAMBDA); - debug_println( DEBUG_LAMBDA); + debug_print_object( sexpr, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); - /* if a result is not the terminal result in the lambda, it's a - * side effect, and needs to be GCed */ - if (!nilp(result)) dec_ref(result); + /* if a result is not the terminal result in the lambda, it's a + * side effect, and needs to be GCed */ + if ( !nilp( result ) ) + dec_ref( result ); result = eval_form( frame, frame_pointer, sexpr, new_env ); } - dec_ref(new_env); + dec_ref( new_env ); debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); - debug_print_object( result, DEBUG_LAMBDA); - debug_println(DEBUG_LAMBDA); + debug_print_object( result, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); return result; } @@ -352,9 +353,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); diff --git a/src/ops/print.c b/src/ops/print.c index 6c0c6e7..9138077 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -124,38 +124,42 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case FUNCTIONTV: fwprintf( output, L"(Function)" ); break; - case INTEGERTV: - if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); + case INTEGERTV:{ + struct cons_pointer s = integer_to_string( pointer, 10 ); + inc_ref( s ); + if ( print_use_colours ) { + fputws( L"\x1B[34m", output ); + } + print_string_contents( output, s ); + dec_ref( s ); } - fwprintf( output, L"%ld%", cell.payload.integer.value ); break; - case LAMBDATV: { - struct cons_pointer to_print = make_cons( c_string_to_lisp_symbol( L"lambda" ), - make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body )); - inc_ref(to_print); + case LAMBDATV:{ + struct cons_pointer to_print = + make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + inc_ref( to_print ); - print( output, to_print ); + print( output, to_print ); - dec_ref(to_print); - } + dec_ref( to_print ); + } break; case NILTV: fwprintf( output, L"nil" ); break; - case NLAMBDATV: { - struct cons_pointer to_print = make_cons( c_string_to_lisp_symbol( L"nlambda" ), - make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body )); - inc_ref(to_print); + case NLAMBDATV:{ + struct cons_pointer to_print = + make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + inc_ref( to_print ); - print( output, to_print ); + print( output, to_print ); - dec_ref(to_print); - } + dec_ref( to_print ); + } break; case RATIOTV: print( output, cell.payload.ratio.dividend ); diff --git a/src/repl.c b/src/repl.c index d07df94..99f41f8 100644 --- a/src/repl.c +++ b/src/repl.c @@ -113,16 +113,16 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, break; } else { struct cons_pointer val = repl_eval( input ); - inc_ref(val); + inc_ref( val ); repl_print( output_stream, val ); - dec_ref(val); + dec_ref( val ); } dec_ref( input ); } - dec_ref(input_stream); - dec_ref(output_stream); + dec_ref( input_stream ); + dec_ref( output_stream ); debug_print( L"Leaving repl\n", DEBUG_REPL ); } From 61573d85d914f9b5c3797fa7809ff81201e9c3b8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 30 Dec 2018 11:10:14 +0000 Subject: [PATCH 009/101] /all-integers-are-bignums: broken, but I don't know why. --- src/arith/integer.c | 10 ++++++++++ src/arith/peano.c | 11 +++++------ src/memory/dump.c | 4 ++++ 3 files changed, 19 insertions(+), 6 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index be50013..29e536e 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -125,6 +125,12 @@ struct cons_pointer multiply_integers( struct cons_pointer a, int64_t carry = 0; if ( integerp( a ) && integerp( b ) ) { + debug_print(L"multiply_integers: ", DEBUG_ARITH); + debug_print_object(a, DEBUG_ARITH); + debug_print(L" x ", DEBUG_ARITH); + debug_print_object(b, DEBUG_ARITH); + debug_println(DEBUG_ARITH); + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { int64_t av = integerp( a ) ? pointer2cell( a ).payload.integer.value : 1; @@ -134,6 +140,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, __int128_t rv = ( av * bv ) + carry; if ( rv > LONG_MAX || rv < LONG_MIN ) { + debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", carry); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; } else { @@ -145,6 +152,9 @@ struct cons_pointer multiply_integers( struct cons_pointer a, b = pointer2cell( b ).payload.integer.more; } } + debug_print(L"multiply_integers returning: ", DEBUG_ARITH); + debug_print_object(result, DEBUG_ARITH); + debug_println(DEBUG_ARITH); return result; } diff --git a/src/arith/peano.c b/src/arith/peano.c index 3fb732a..2a9fb7f 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -284,7 +284,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = multiply_integers( arg1, arg2 ); + result = make_integer(cell1.payload.integer.value * cell2.payload.integer.value, NIL); + //result = multiply_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -411,9 +412,8 @@ struct cons_pointer inverse( struct cons_pointer frame, case RATIOTV: result = make_ratio( frame, make_integer( 0 - - to_long_int( cell.payload. - ratio.dividend ), - NIL ), + to_long_int( cell.payload.ratio. + dividend ), NIL ), cell.payload.ratio.divisor ); break; case REALTV: @@ -453,8 +453,7 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV: result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, - NIL ); + - cell1.payload.integer.value, NIL ); break; case RATIOTV:{ struct cons_pointer tmp = diff --git a/src/memory/dump.c b/src/memory/dump.c index 6601e92..24fd955 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -83,6 +83,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", cell.payload.integer.value, cell.count ); + if (!nilp(cell.payload.integer.more)) { + fputws( L"\t\tBIGNUM! More at\n:", output); + dump_object(output, cell.payload.integer.more); + } break; case LAMBDATV: fwprintf( output, L"\t\tLambda cell;\n\t\t args: " ); From 87b5b1afe8237ab9054fc08fde007455ef4d7012 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 30 Dec 2018 11:14:50 +0000 Subject: [PATCH 010/101] Fixed failing test --- unit-tests/integer-allocation.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh index 5d07d90..c2edf14 100644 --- a/unit-tests/integer-allocation.sh +++ b/unit-tests/integer-allocation.sh @@ -2,7 +2,7 @@ value=354 expected="Integer cell: value ${value}" -echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null +echo ${value} | target/psse -v4 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then From 47f4b4c7f79da807a6f45366398b28a9132403bd Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 30 Dec 2018 12:07:38 +0000 Subject: [PATCH 011/101] Bug was in integer_to_string; all tests now pass. --- src/arith/integer.c | 38 +++++++++++++++++++++++++++++++------- 1 file changed, 31 insertions(+), 7 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 29e536e..176b09e 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -25,7 +25,7 @@ /** * hexadecimal digits for printing numbers. */ -const wchar_t *hex_digits = L"0123456789ABCDEF"; +const wchar_t hex_digits[16] = L"0123456789ABCDEF"; /* * Doctrine from here on in is that ALL integers are bignums, it's just @@ -68,6 +68,7 @@ long double numeric_value( struct cons_pointer pointer ) { */ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { struct cons_pointer result = NIL; + debug_print(L"Entering make_integer\n", DEBUG_ARITH); if ( integerp( more ) || nilp( more ) ) { result = allocate_cell( INTEGERTAG ); @@ -75,9 +76,10 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { cell->payload.integer.value = value; cell->payload.integer.more = more; - debug_dump_object( result, DEBUG_ARITH ); } + debug_print(L"make_integer: returning\n", DEBUG_ARITH); + debug_dump_object( result, DEBUG_ARITH ); return result; } @@ -87,11 +89,19 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { */ struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b ) { + debug_print(L"Entering add_integers\n", DEBUG_ARITH); + struct cons_pointer result = NIL; int64_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + debug_print(L"add_integers: ", DEBUG_ARITH); + debug_print_object(a, DEBUG_ARITH); + debug_print(L" x ", DEBUG_ARITH); + debug_print_object(b, DEBUG_ARITH); + debug_printf(DEBUG_ARITH, L"; carry = %ld\n", carry); + int64_t av = integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; int64_t bv = @@ -100,6 +110,7 @@ struct cons_pointer add_integers( struct cons_pointer a, __int128_t rv = av + bv + carry; if ( rv > LONG_MAX || rv < LONG_MIN ) { + debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", carry); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; } else { @@ -111,6 +122,9 @@ struct cons_pointer add_integers( struct cons_pointer a, b = pointer2cell( b ).payload.integer.more; } } + debug_print(L"add_integers returning: ", DEBUG_ARITH); + debug_print_object(result, DEBUG_ARITH); + debug_println(DEBUG_ARITH); return result; } @@ -178,11 +192,20 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, bool is_negative = accumulator < 0; accumulator = llabs( accumulator ); + if (accumulator == 0) { + result = c_string_to_lisp_string( L"0"); + } else { while ( accumulator > 0 ) { - while ( accumulator > base ) { - result = make_string( hex_digits[accumulator % base], result ); + debug_printf(DEBUG_ARITH, L"integer_to_string: accumulator is %ld\n:", + accumulator); + do { + debug_printf(DEBUG_ARITH, L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", + accumulator % base, hex_digits[accumulator % base]); + wint_t digit = (wint_t)hex_digits[accumulator % base]; + + result = make_string( (wint_t)hex_digits[accumulator % base], result ); accumulator = accumulator / base; - } + } while ( accumulator > base ); if ( integerp( integer.payload.integer.more ) ) { integer = pointer2cell( integer.payload.integer.more ); @@ -190,7 +213,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, /* TODO: I don't believe it's as simple as this! */ accumulator += ( base * ( i % base ) ); - result = make_string( hex_digits[accumulator % base], result ); + result = make_string( (wint_t)hex_digits[accumulator % base], result ); accumulator += ( base * ( i / base ) ); } } @@ -198,6 +221,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, if ( is_negative ) { result = make_string( L'-', result ); } + } return result; } From 02fe5669d8ccaa1907e48acce8d8506c10e49d08 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 30 Dec 2018 17:56:15 +0000 Subject: [PATCH 012/101] Complete reworking of the REPL which is good in itself, but not what I was meant to be working on. --- Makefile | 4 +- lisp/expt.lisp | 6 + lisp/types.lisp | 24 +++ src/arith/integer.c | 105 ++++++------ src/arith/peano.c | 12 +- src/arith/ratio.c | 16 +- src/init.c | 29 +++- src/memory/dump.c | 14 +- src/ops/equal.c | 4 +- src/ops/lispops.c | 268 +++++++++++++++++++++++++------ src/ops/lispops.h | 4 + src/ops/print.c | 4 + src/ops/print.h | 1 + src/repl.c | 108 ++----------- src/repl.h | 7 +- unit-tests/add.sh | 10 +- unit-tests/apply.sh | 2 +- unit-tests/complex-list.sh | 2 +- unit-tests/cond.sh | 4 +- unit-tests/empty-list.sh | 4 +- unit-tests/empty-string.sh | 2 +- unit-tests/eval-integer.sh | 2 +- unit-tests/eval-quote-sexpr.sh | 2 +- unit-tests/eval-quote-symbol.sh | 2 +- unit-tests/eval-real.sh | 3 +- unit-tests/eval-string.sh | 2 +- unit-tests/fred.sh | 2 +- unit-tests/integer.sh | 4 +- unit-tests/intepreter.sh | 2 +- unit-tests/lambda.sh | 5 +- unit-tests/many-args.sh | 2 +- unit-tests/multiply.sh | 4 +- unit-tests/nil.sh | 2 +- unit-tests/nlambda.sh | 2 +- unit-tests/progn.sh | 4 +- unit-tests/quote.sh | 2 +- unit-tests/quoted-list.sh | 2 +- unit-tests/ratio-addition.sh | 2 +- unit-tests/recursion.sh | 5 +- unit-tests/reverse.sh | 6 +- unit-tests/simple-list.sh | 2 +- unit-tests/string-with-spaces.sh | 2 +- unit-tests/varargs.sh | 7 +- 43 files changed, 415 insertions(+), 281 deletions(-) create mode 100644 lisp/expt.lisp create mode 100644 lisp/types.lisp diff --git a/Makefile b/Makefile index c368d50..4fe322f 100644 --- a/Makefile +++ b/Makefile @@ -15,13 +15,11 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ -d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \ -npsl -nsc -nsob -nss -nut -prs -l79 -ts2 -VERSION := "0.0.2" - CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm $(TARGET): $(OBJS) Makefile - $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) + $(CC) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) doc: $(SRCS) Makefile Doxyfile doxygen diff --git a/lisp/expt.lisp b/lisp/expt.lisp new file mode 100644 index 0000000..db6a7b3 --- /dev/null +++ b/lisp/expt.lisp @@ -0,0 +1,6 @@ +(set! expt (lambda + (n x) + "Return the value of `n` raised to the `x`th power." + (cond + ((= x 1) n) + (t (* n (expt n (- x 1))))))) diff --git a/lisp/types.lisp b/lisp/types.lisp new file mode 100644 index 0000000..cba1ef6 --- /dev/null +++ b/lisp/types.lisp @@ -0,0 +1,24 @@ +(set! cons? (lambda (o) "True if o is a cons cell." (= (type o) "CONS") ) ) +(set! exception? (lambda (o) "True if o is an exception." (= (type o) "EXEP"))) +(set! free? (lambda (o) "Trus if o is a free cell - this should be impossible!" (= (type o) "FREE"))) +(set! function? (lambda (o) "True if o is a compiled function." (= (type o) "EXEP"))) +(set! integer? (lambda (o) "True if o is an integer." (= (type o) "INTR"))) +(set! lambda? (lambda (o) "True if o is an interpreted (source) function." (= (type o) "LMDA"))) +(set! nil? (lambda (o) "True if o is the canonical nil value." (= (type o) "NIL "))) +(set! nlambda? (lambda (o) "True if o is an interpreted (source) special form." (= (type o) "NLMD"))) +(set! rational? (lambda (o) "True if o is an rational number." (= (type o) "RTIO"))) +(set! read? (lambda (o) "True if o is a read stream." (= (type o) "READ") ) ) +(set! real? (lambda (o) "True if o is an real number." (= (type o) "REAL"))) +(set! special? (lambda (o) "True if o is a compiled special form." (= (type o) "SPFM") ) ) +(set! string? (lambda (o) "True if o is a string." (= (type o) "STRG") ) ) +(set! symbol? (lambda (o) "True if o is a symbol." (= (type o) "SYMB") ) ) +(set! true? (lambda (o) "True if o is the canonical true value." (= (type o) "TRUE") ) ) +(set! write? (lambda (o) "True if o is a write stream." (= (type o) "WRIT") ) ) + +(set! or (lambda values + "True if any of `values` are non-nil." + (cond ((car values) t) (t (apply 'or (cdr values)))))) + +(set! number? + (lambda (o) + "I don't yet have an `or` operator diff --git a/src/arith/integer.c b/src/arith/integer.c index 176b09e..0e74f7b 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -68,7 +68,7 @@ long double numeric_value( struct cons_pointer pointer ) { */ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { struct cons_pointer result = NIL; - debug_print(L"Entering make_integer\n", DEBUG_ARITH); + debug_print( L"Entering make_integer\n", DEBUG_ARITH ); if ( integerp( more ) || nilp( more ) ) { result = allocate_cell( INTEGERTAG ); @@ -78,7 +78,7 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { } - debug_print(L"make_integer: returning\n", DEBUG_ARITH); + debug_print( L"make_integer: returning\n", DEBUG_ARITH ); debug_dump_object( result, DEBUG_ARITH ); return result; } @@ -89,18 +89,18 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { */ struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b ) { - debug_print(L"Entering add_integers\n", DEBUG_ARITH); + debug_print( L"Entering add_integers\n", DEBUG_ARITH ); struct cons_pointer result = NIL; int64_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - debug_print(L"add_integers: ", DEBUG_ARITH); - debug_print_object(a, DEBUG_ARITH); - debug_print(L" x ", DEBUG_ARITH); - debug_print_object(b, DEBUG_ARITH); - debug_printf(DEBUG_ARITH, L"; carry = %ld\n", carry); + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + debug_print( L"add_integers: ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L" x ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_printf( DEBUG_ARITH, L"; carry = %ld\n", carry ); int64_t av = integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; @@ -110,7 +110,9 @@ struct cons_pointer add_integers( struct cons_pointer a, __int128_t rv = av + bv + carry; if ( rv > LONG_MAX || rv < LONG_MIN ) { - debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", carry); + debug_printf( DEBUG_ARITH, + L"add_integers: 64 bit overflow; setting carry to %ld\n", + carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; } else { @@ -122,9 +124,9 @@ struct cons_pointer add_integers( struct cons_pointer a, b = pointer2cell( b ).payload.integer.more; } } - debug_print(L"add_integers returning: ", DEBUG_ARITH); - debug_print_object(result, DEBUG_ARITH); - debug_println(DEBUG_ARITH); + debug_print( L"add_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); return result; } @@ -139,11 +141,11 @@ struct cons_pointer multiply_integers( struct cons_pointer a, int64_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - debug_print(L"multiply_integers: ", DEBUG_ARITH); - debug_print_object(a, DEBUG_ARITH); - debug_print(L" x ", DEBUG_ARITH); - debug_print_object(b, DEBUG_ARITH); - debug_println(DEBUG_ARITH); + debug_print( L"multiply_integers: ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L" x ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { int64_t av = @@ -154,7 +156,9 @@ struct cons_pointer multiply_integers( struct cons_pointer a, __int128_t rv = ( av * bv ) + carry; if ( rv > LONG_MAX || rv < LONG_MIN ) { - debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", carry); + debug_printf( DEBUG_ARITH, + L"multiply_integers: 64 bit overflow; setting carry to %ld\n", + carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; } else { @@ -166,9 +170,9 @@ struct cons_pointer multiply_integers( struct cons_pointer a, b = pointer2cell( b ).payload.integer.more; } } - debug_print(L"multiply_integers returning: ", DEBUG_ARITH); - debug_print_object(result, DEBUG_ARITH); - debug_println(DEBUG_ARITH); + debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); return result; } @@ -192,36 +196,43 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, bool is_negative = accumulator < 0; accumulator = llabs( accumulator ); - if (accumulator == 0) { - result = c_string_to_lisp_string( L"0"); - } else { - while ( accumulator > 0 ) { - debug_printf(DEBUG_ARITH, L"integer_to_string: accumulator is %ld\n:", - accumulator); - do { - debug_printf(DEBUG_ARITH, L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", - accumulator % base, hex_digits[accumulator % base]); - wint_t digit = (wint_t)hex_digits[accumulator % base]; + if ( accumulator == 0 ) { + result = c_string_to_lisp_string( L"0" ); + } else { + while ( accumulator > 0 ) { + debug_printf( DEBUG_ARITH, + L"integer_to_string: accumulator is %ld\n:", + accumulator ); + do { + debug_printf( DEBUG_ARITH, + L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", + accumulator % base, + hex_digits[accumulator % base] ); + wint_t digit = ( wint_t ) hex_digits[accumulator % base]; - result = make_string( (wint_t)hex_digits[accumulator % base], result ); - accumulator = accumulator / base; - } while ( accumulator > base ); + result = + make_string( ( wint_t ) hex_digits[accumulator % base], + result ); + accumulator = accumulator / base; + } while ( accumulator > base ); - if ( integerp( integer.payload.integer.more ) ) { - integer = pointer2cell( integer.payload.integer.more ); - int64_t i = integer.payload.integer.value; + if ( integerp( integer.payload.integer.more ) ) { + integer = pointer2cell( integer.payload.integer.more ); + int64_t i = integer.payload.integer.value; - /* TODO: I don't believe it's as simple as this! */ - accumulator += ( base * ( i % base ) ); - result = make_string( (wint_t)hex_digits[accumulator % base], result ); - accumulator += ( base * ( i / base ) ); + /* TODO: I don't believe it's as simple as this! */ + accumulator += ( base * ( i % base ) ); + result = + make_string( ( wint_t ) hex_digits[accumulator % base], + result ); + accumulator += ( base * ( i / base ) ); + } + } + + if ( is_negative ) { + result = make_string( L'-', result ); } } - if ( is_negative ) { - result = make_string( L'-', result ); - } - } - return result; } diff --git a/src/arith/peano.c b/src/arith/peano.c index 2a9fb7f..3a24ed1 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -284,7 +284,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer(cell1.payload.integer.value * cell2.payload.integer.value, NIL); + result = + make_integer( cell1.payload.integer.value * + cell2.payload.integer.value, NIL ); //result = multiply_integers( arg1, arg2 ); break; case RATIOTV: @@ -412,8 +414,9 @@ struct cons_pointer inverse( struct cons_pointer frame, case RATIOTV: result = make_ratio( frame, make_integer( 0 - - to_long_int( cell.payload.ratio. - dividend ), NIL ), + to_long_int( cell.payload. + ratio.dividend ), + NIL ), cell.payload.ratio.divisor ); break; case REALTV: @@ -453,7 +456,8 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV: result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, NIL ); + - cell1.payload.integer.value, + NIL ); break; case RATIOTV:{ struct cons_pointer tmp = diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 95c9a8f..fd6a770 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -61,10 +61,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg ) ) { int64_t ddrv = - pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). - payload.integer.value, drrv = - pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). - payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); + pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload. + integer.value, drrv = + pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload. + integer.value, gcd = greatest_common_divisor( ddrv, drrv ); if ( gcd > 1 ) { if ( drrv / gcd == 1 ) { @@ -203,10 +203,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload. - ratio.divisor, - pointer2cell( arg2 ).payload. - ratio.dividend ), result = + pointer2cell( arg2 ).payload.ratio. + divisor, + pointer2cell( arg2 ).payload.ratio. + dividend ), result = multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); diff --git a/src/init.c b/src/init.c index 773afb5..15fd8e4 100644 --- a/src/init.c +++ b/src/init.c @@ -62,12 +62,6 @@ void bind_value( wchar_t *name, struct cons_pointer value ) { } int main( int argc, char *argv[] ) { - /* - * attempt to set wide character acceptance on all streams - */ - fwide( stdin, 1 ); - fwide( stdout, 1 ); - fwide( stderr, 1 ); int option; bool dump_at_end = false; bool show_prompt = false; @@ -110,6 +104,26 @@ int main( int argc, char *argv[] ) { bind_value( L"nil", NIL ); bind_value( L"t", TRUE ); + /* + * standard input, output, error and sink streams + * attempt to set wide character acceptance on all streams + */ + FILE *sink = fopen( "/dev/null", "w" ); + fwide( stdin, 1 ); + fwide( stdout, 1 ); + fwide( stderr, 1 ); + fwide( sink, 1 ); + bind_value( L"*in*", make_read_stream( stdin ) ); + bind_value( L"*out*", make_write_stream( stdout ) ); + bind_value( L"*log*", make_write_stream( stderr ) ); + bind_value( L"*sink*", make_write_stream( sink ) ); + + /* + * the default prompt + */ + bind_value( L"*prompt*", + show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL ); + /* * primitive function operations */ @@ -126,6 +140,7 @@ int main( int argc, char *argv[] ) { bind_function( L"exception", &lisp_exception ); bind_function( L"multiply", &lisp_multiply ); bind_function( L"read", &lisp_read ); + bind_function( L"repl", &lisp_repl ); bind_function( L"oblist", &lisp_oblist ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); @@ -156,7 +171,7 @@ int main( int argc, char *argv[] ) { debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); - repl( stdin, stdout, stderr, show_prompt ); + repl( show_prompt ); debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); dec_ref( oblist ); diff --git a/src/memory/dump.c b/src/memory/dump.c index 24fd955..bd6587f 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -83,9 +83,9 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", cell.payload.integer.value, cell.count ); - if (!nilp(cell.payload.integer.more)) { - fputws( L"\t\tBIGNUM! More at\n:", output); - dump_object(output, cell.payload.integer.more); + if ( !nilp( cell.payload.integer.more ) ) { + fputws( L"\t\tBIGNUM! More at\n:", output ); + dump_object( output, cell.payload.integer.more ); } break; case LAMBDATV: @@ -107,10 +107,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case RATIOTV: fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); break; case READTV: fwprintf( output, L"\t\tInput stream\n" ); diff --git a/src/ops/equal.c b/src/ops/equal.c index bade594..9eedd53 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload. - string.cdr ) ) ); + && end_of_string( cell_b->payload.string. + cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/ops/lispops.c b/src/ops/lispops.c index c83287d..1913406 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -117,11 +117,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer list, struct cons_pointer env ) { - /* TODO: refactor. This runs up the C stack. */ - return consp( list ) ? - make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), - eval_forms( frame, frame_pointer, c_cdr( list ), - env ) ) : NIL; + struct cons_pointer result = NIL; + + while ( consp( list ) ) { + result = + make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), + result ); + list = c_cdr( list ); + } + + return result; } /** @@ -220,7 +225,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, /* if `names` is a symbol, rather than a list of symbols, * then bind a list of the values of args to that symbol. */ /* TODO: eval all the things in frame->more */ - struct cons_pointer vals = frame->more; + struct cons_pointer vals = + eval_forms( frame, frame_pointer, frame->more, env ); for ( int i = args_in_frame - 1; i >= 0; i-- ) { struct cons_pointer val = @@ -353,10 +359,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload. - special.executable ) ( get_stack_frame - ( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -480,10 +485,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { -#ifdef DEBUG debug_print( L"Apply: ", DEBUG_EVAL ); - dump_frame( stderr, frame_pointer ); -#endif + debug_dump_object( frame_pointer, DEBUG_EVAL ); + set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); set_reg( frame, 1, NIL ); @@ -612,17 +616,24 @@ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - if ( consp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.cons.car; - } else if ( stringp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = make_string( cell.payload.string.character, NIL ); - } else { - struct cons_pointer message = - c_string_to_lisp_string( L"Attempt to take CAR of non sequence" ); - result = throw_exception( message, frame_pointer ); + switch ( cell.tag.value ) { + case CONSTV: + result = cell.payload.cons.car; + break; + case READTV: + result = make_string( fgetwc( cell.payload.stream.stream ), NIL ); + case STRINGTV: + result = make_string( cell.payload.string.character, NIL ); + break; + case NILTV: + break; + default: + result = + throw_exception( c_string_to_lisp_string + ( L"Attempt to take CAR of non sequence" ), + frame_pointer ); } return result; @@ -632,22 +643,33 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, * (cdr s_expr) * Returns the remainder of a sequence when the head is removed. Valid for cons cells, * strings, and TODO read streams and other things which can be considered as sequences. + * NOTE that if the argument is an input stream, the first character is removed AND + * DISCARDED. */ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - if ( consp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.cons.cdr; - } else if ( stringp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.string.cdr; - } else { - struct cons_pointer message = - c_string_to_lisp_string( L"Attempt to take CDR of non sequence" ); - result = throw_exception( message, frame_pointer ); + switch ( cell.tag.value ) { + case CONSTV: + result = cell.payload.cons.cdr; + break; + case READTV: + fgetwc( cell.payload.stream.stream ); + result = frame->arg[0]; + break; + case STRINGTV: + result = cell.payload.string.cdr; + break; + case NILTV: + break; + default: + result = + throw_exception( c_string_to_lisp_string + ( L"Attempt to take CDR of non sequence" ), + frame_pointer ); } return result; @@ -683,6 +705,26 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } + +/** + * Resutn the current default input, or of `inputp` is false, output stream from + * this `env`ironment. + */ +struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer stream_name = + c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); + + inc_ref( stream_name ); + + result = c_assoc( stream_name, env ); + + dec_ref( stream_name ); + + return result; +} + + /** * (read) * (read read-stream) @@ -696,15 +738,24 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_print( L"entering lisp_read\n", DEBUG_IO ); #endif FILE *input = stdin; + struct cons_pointer in_stream = readp( frame->arg[0] ) ? + frame->arg[0] : get_default_stream( true, env ); - if ( readp( frame->arg[0] ) ) { - input = pointer2cell( frame->arg[0] ).payload.stream.stream; + if ( readp( in_stream ) ) { + debug_print( L"lisp_print: setting input stream\n", DEBUG_IO ); + debug_dump_object( in_stream, DEBUG_IO ); + input = pointer2cell( in_stream ).payload.stream.stream; + inc_ref( in_stream ); } struct cons_pointer result = read( frame, frame_pointer, input ); debug_print( L"lisp_read returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); + if ( readp( in_stream ) ) { + dec_ref( in_stream ); + } + return result; } @@ -757,12 +808,16 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_print( L"Entering print\n", DEBUG_IO ); struct cons_pointer result = NIL; FILE *output = stdout; + struct cons_pointer out_stream = writep( frame->arg[1] ) ? + frame->arg[1] : get_default_stream( false, env ); - if ( writep( frame->arg[1] ) ) { + if ( writep( out_stream ) ) { debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); - debug_dump_object( frame->arg[1], DEBUG_IO ); - output = pointer2cell( frame->arg[1] ).payload.stream.stream; + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + inc_ref( out_stream ); } + debug_print( L"lisp_print: about to print\n", DEBUG_IO ); debug_dump_object( frame->arg[0], DEBUG_IO ); @@ -771,6 +826,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_print( L"lisp_print returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); + if ( writep( out_stream ) ) { + dec_ref( out_stream ); + } + return result; } @@ -787,6 +846,27 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, return c_type( frame->arg[0] ); } +/** + * Evaluate each of these forms in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct cons_pointer +c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer forms, struct cons_pointer env ) { + struct cons_pointer result = NIL; + + while ( consp( forms ) ) { + struct cons_pointer r = result; + inc_ref( r ); + result = eval_form( frame, frame_pointer, c_car( forms ), env ); + dec_ref( r ); + + forms = c_cdr( forms ); + } + + return result; +} + /** * (progn forms...) @@ -803,17 +883,19 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer remaining = frame->more; struct cons_pointer result = NIL; for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { + struct cons_pointer r = result; + inc_ref( r ); + result = eval_form( frame, frame_pointer, frame->arg[i], env ); + + dec_ref( r ); } - while ( consp( remaining ) ) { - result = eval_form( frame, frame_pointer, c_car( remaining ), env ); - - remaining = c_cdr( remaining ); + if ( consp( frame->more ) ) { + result = c_progn( frame, frame_pointer, frame->more, env ); } return result; @@ -846,15 +928,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, env ); if ( !nilp( result ) ) { - struct cons_pointer vals = - eval_forms( frame, frame_pointer, c_cdr( clause_pointer ), - env ); - - while ( consp( vals ) ) { - result = c_car( vals ); - vals = c_cdr( vals ); - } - + result = + c_progn( frame, frame_pointer, c_cdr( clause_pointer ), + env ); done = true; } } else if ( nilp( clause_pointer ) ) { @@ -915,3 +991,91 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, return exceptionp( message ) ? message : make_exception( message, frame->previous ); } + +/** + * (repl) + * (repl prompt) + * (repl prompt input_stream output_stream) + * + * Function: the read/eval/print loop. Returns the value of the last expression + * entered. + */ +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer expr = NIL; + + /* TODO: bind *prompt*, *input*, *output* in the environment to the values + * of arguments 0, 1, and 2 respectively, but in each case only if the + * argument is not nil */ + + struct cons_pointer input = get_default_stream( true, env ); + struct cons_pointer output = get_default_stream( false, env ); + FILE *os = pointer2cell( output ).payload.stream.stream; + struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); + struct cons_pointer old_oblist = oblist; + struct cons_pointer new_env = env; + + inc_ref( input ); + inc_ref( output ); + inc_ref( prompt_name ); + inc_ref( new_env ); + + /* TODO: this is subtly wrong. If we were evaluating + * (print (eval (read))) + * then the stack frame for read would have the stack frame for + * eval as parent, and it in turn would have the stack frame for + * print as parent. + */ + while ( readp( input ) && writep( output ) + && !feof( pointer2cell( input ).payload.stream.stream ) ) { + /* OK, here's a really subtle problem: because lists are immutable, anything + * bound in the oblist subsequent to this function being invoked isn't in the + * environment. So, for example, changes to *prompt* or *log* made in the oblist + * are not visible. So copy changes made in the oblist into the enviroment. + * TODO: the whole process of resolving symbol values needs to be revisited + * when we get onto namespaces. */ + struct cons_pointer cursor = oblist; + while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = make_cons( c_car( cursor ), new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; + + println( os ); + + struct cons_pointer prompt = c_assoc( prompt_name, new_env ); + if ( !nilp( prompt ) ) { + print( os, prompt ); + } + + expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, + new_env ); + inc_ref( expr ); + + if ( exceptionp( expr ) + && feof( pointer2cell( input ).payload.stream.stream ) ) { + /* suppress printing end of stream exception */ + break; + } + + println( os ); + + print( os, eval_form( frame, frame_pointer, expr, new_env ) ); + + dec_ref( expr ); + } + + dec_ref( input ); + dec_ref( output ); + dec_ref( prompt_name ); + dec_ref( new_env ); + + return expr; +} diff --git a/src/ops/lispops.h b/src/ops/lispops.h index a1dee81..f9cd8ba 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -140,9 +140,13 @@ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + /** * Function: Get the Lisp type of the single argument. * @param frame My stack frame. diff --git a/src/ops/print.c b/src/ops/print.c index 9138077..3feeb21 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -224,3 +224,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { return pointer; } + +void println( FILE * output ) { + fputws( L"\n", output ); +} diff --git a/src/ops/print.h b/src/ops/print.h index 1399db4..2751032 100644 --- a/src/ops/print.h +++ b/src/ops/print.h @@ -15,6 +15,7 @@ #define __print_h struct cons_pointer print( FILE * output, struct cons_pointer pointer ); +void println( FILE * output ); extern int print_use_colours; #endif diff --git a/src/repl.c b/src/repl.c index 99f41f8..0ea104d 100644 --- a/src/repl.c +++ b/src/repl.c @@ -11,118 +11,28 @@ #include #include -#include "conspage.h" #include "consspaceobject.h" #include "debug.h" #include "intern.h" #include "lispops.h" -#include "read.h" -#include "print.h" #include "stack.h" -/* TODO: this is subtly wrong. If we were evaluating - * (print (eval (read))) - * then the stack frame for read would have the stack frame for - * eval as parent, and it in turn would have the stack frame for - * print as parent. - */ - /** - * Dummy up a Lisp read call with its own stack frame. + * The read/eval/print loop. */ -struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { - struct cons_pointer result = NIL; - 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 ); +void repl( ) { + debug_print( L"Entered repl\n", DEBUG_REPL ); + + struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, oblist ); + if ( !nilp( frame_pointer ) ) { inc_ref( frame_pointer ); - result = - lisp_read( get_stack_frame( frame_pointer ), frame_pointer, - oblist ); + + lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, oblist ); + dec_ref( frame_pointer ); } - debug_print( L"repl_read: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - - return result; -} - -/** - * Dummy up a Lisp eval call with its own stack frame. - */ -struct cons_pointer repl_eval( struct cons_pointer input ) { - debug_print( L"Entered repl_eval\n", DEBUG_REPL ); - struct cons_pointer result = NIL; - - result = eval_form( NULL, NIL, input, oblist ); - - debug_print( L"repl_eval: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - - return result; -} - -/** - * Dummy up a Lisp print call with its own stack frame. - */ -struct cons_pointer repl_print( struct cons_pointer stream_pointer, - struct cons_pointer value ) { - debug_print( L"Entered repl_print\n", DEBUG_REPL ); - debug_dump_object( value, DEBUG_REPL ); - struct cons_pointer result = - print( pointer2cell( stream_pointer ).payload.stream.stream, value ); - debug_print( L"repl_print: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - - return result; -} - -/** - * The read/eval/print loop - * @param in_stream the stream to read from; - * @param out_stream the stream to write to; - * @param err_stream the stream to send errors to; - * @param show_prompt true if prompts should be shown. - */ -void -repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, - bool show_prompt ) { - debug_print( L"Entered repl\n", DEBUG_REPL ); - struct cons_pointer input_stream = make_read_stream( in_stream ); - inc_ref( input_stream ); - - struct cons_pointer output_stream = make_write_stream( out_stream ); - inc_ref( output_stream ); - while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { - if ( show_prompt ) { - fwprintf( out_stream, L"\n:: " ); - } - - struct cons_pointer input = repl_read( input_stream ); - inc_ref( input ); - - if ( exceptionp( input ) ) { - /* suppress the end-of-stream exception */ - if ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { - repl_print( output_stream, input ); - } - break; - } else { - struct cons_pointer val = repl_eval( input ); - inc_ref( val ); - repl_print( output_stream, val ); - dec_ref( val ); - } - - dec_ref( input ); - } - - dec_ref( input_stream ); - dec_ref( output_stream ); debug_print( L"Leaving repl\n", DEBUG_REPL ); } diff --git a/src/repl.h b/src/repl.h index 1a7b0e9..8ff8b19 100644 --- a/src/repl.h +++ b/src/repl.h @@ -20,13 +20,8 @@ extern "C" { /** * The read/eval/print loop - * @param in_stream the stream to read from; - * @param out_stream the stream to write to; - * @param err_stream the stream to send errors to; - * @param show_prompt true if prompts should be shown. */ - void repl( FILE * in_stream, FILE * out_stream, - FILE * error_stream, bool show_prompt ); + void repl( ); #ifdef __cplusplus } diff --git a/unit-tests/add.sh b/unit-tests/add.sh index 4516808..2802c3a 100644 --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(add 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(add 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='5.5' -actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(add 2.5 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -24,7 +24,7 @@ else fi expected='1/4' -actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -36,7 +36,7 @@ fi # (+ integer ratio) should be ratio expected='25/4' -actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 6 1/4)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -48,7 +48,7 @@ fi # (+ ratio integer) should be ratio expected='25/4' -actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 1/4 6)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh index 3483fb0..811fdae 100644 --- a/unit-tests/apply.sh +++ b/unit-tests/apply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1' -actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(apply 'add '(1))"| target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index d3728d8..5bb5e9c 100644 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(1 2 3 ("Fred") nil 77354)' -actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/cond.sh b/unit-tests/cond.sh index 227f9b3..ab2e2f0 100644 --- a/unit-tests/cond.sh +++ b/unit-tests/cond.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(cond ((equal 2 2) 5))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(cond ((equal 2 2) 5))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='"should"' -actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-list.sh b/unit-tests/empty-list.sh index 1e24452..8f0f702 100644 --- a/unit-tests/empty-list.sh +++ b/unit-tests/empty-list.sh @@ -1,5 +1,5 @@ #!/bin/bash -# +# # File: empty-list.sh.bash # Author: simon # @@ -7,7 +7,7 @@ # expected=nil -actual=`echo "'()" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'()" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-string.sh b/unit-tests/empty-string.sh index 340fd1b..a1e5baa 100644 --- a/unit-tests/empty-string.sh +++ b/unit-tests/empty-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="\"\"" -actual=`echo '""' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo '""' | target/psse | tail -1` if [ "$expected" = "$actual" ] then diff --git a/unit-tests/eval-integer.sh b/unit-tests/eval-integer.sh index addc133..1aadb39 100644 --- a/unit-tests/eval-integer.sh +++ b/unit-tests/eval-integer.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(eval 5)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval 5)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-quote-sexpr.sh b/unit-tests/eval-quote-sexpr.sh index eea16ec..d83bbe8 100644 --- a/unit-tests/eval-quote-sexpr.sh +++ b/unit-tests/eval-quote-sexpr.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(eval '(add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval '(add 2 3))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh index 5eca83d..253ce32 100644 --- a/unit-tests/eval-quote-symbol.sh +++ b/unit-tests/eval-quote-symbol.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(Special form)' -actual=`echo "(eval 'cond)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval 'cond)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-real.sh b/unit-tests/eval-real.sh index 8832719..3aa16d7 100644 --- a/unit-tests/eval-real.sh +++ b/unit-tests/eval-real.sh @@ -5,12 +5,11 @@ expected='5.05' actual=`echo "(eval 5.05)" |\ target/psse 2> /dev/null |\ sed 's/0*$//' |\ - head -2 |\ tail -1` +# one part in a million is close enough... outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc` - if [ "${outcome}" = "1" ] then echo "OK" diff --git a/unit-tests/eval-string.sh b/unit-tests/eval-string.sh index 4b8dc8e..90f6f2c 100644 --- a/unit-tests/eval-string.sh +++ b/unit-tests/eval-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"5"' -actual=`echo '(eval "5")' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo '(eval "5")' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/fred.sh b/unit-tests/fred.sh index 427c60d..8e3d513 100644 --- a/unit-tests/fred.sh +++ b/unit-tests/fred.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Fred"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/integer.sh b/unit-tests/integer.sh index 41b2da3..18ae66e 100644 --- a/unit-tests/integer.sh +++ b/unit-tests/integer.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected="354" -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +expected='354' +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/intepreter.sh b/unit-tests/intepreter.sh index 9eb2a06..6f23fc9 100644 --- a/unit-tests/intepreter.sh +++ b/unit-tests/intepreter.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='6' -actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh index c1197e0..b7f1707 100644 --- a/unit-tests/lambda.sh +++ b/unit-tests/lambda.sh @@ -1,10 +1,11 @@ #!/bin/bash -expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)' -actual=`target/psse 2>/dev/null </dev/null < /dev/null | head -2 | tail -1` +actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/multiply.sh b/unit-tests/multiply.sh index 0675a6f..94b19f6 100644 --- a/unit-tests/multiply.sh +++ b/unit-tests/multiply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='6' -actual=`echo "(multiply 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(multiply 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='7.5' -actual=`echo "(multiply 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(multiply 2.5 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh index de4ef57..fcbf530 100644 --- a/unit-tests/nil.sh +++ b/unit-tests/nil.sh @@ -1,7 +1,7 @@ #!/bin/bash expected=nil -actual=`echo 'nil' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo 'nil' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nlambda.sh b/unit-tests/nlambda.sh index f267527..68f0447 100644 --- a/unit-tests/nlambda.sh +++ b/unit-tests/nlambda.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='a' -actual=`echo "((nlambda (x) x) a)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "((nlambda (x) x) a)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh index 017646b..352c87a 100644 --- a/unit-tests/progn.sh +++ b/unit-tests/progn.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(progn (add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2 3))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='"foo"' -actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh index bded011..78d4ce5 100644 --- a/unit-tests/quote.sh +++ b/unit-tests/quote.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='Fred' -actual=`echo "'Fred" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'Fred" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh index 24480c6..f69cd75 100644 --- a/unit-tests/quoted-list.sh +++ b/unit-tests/quoted-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(123 (4 (5 nil)) Fred)' -actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/ratio-addition.sh b/unit-tests/ratio-addition.sh index f57d0b0..ba93c5d 100644 --- a/unit-tests/ratio-addition.sh +++ b/unit-tests/ratio-addition.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1/4' -actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh index a49154b..407265e 100644 --- a/unit-tests/recursion.sh +++ b/unit-tests/recursion.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected='nil3628800' -actual=`target/psse 2>/dev/null </dev/null </dev/null < /dev/null | head -2 | tail -1` +actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='(1024 512 256 128 64 32 16 8 4 2)' -actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -23,7 +23,7 @@ else fi expected='esrever' -actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(reverse 'reverse)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh index 60492b9..daf3db2 100644 --- a/unit-tests/simple-list.sh +++ b/unit-tests/simple-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="(1 2 3)" -actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(1 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh index 384cc9f..0f0f6d0 100644 --- a/unit-tests/string-with-spaces.sh +++ b/unit-tests/string-with-spaces.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Strings should be able to include spaces (and other stuff)!"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/varargs.sh b/unit-tests/varargs.sh index 6c31163..27bac3e 100644 --- a/unit-tests/varargs.sh +++ b/unit-tests/varargs.sh @@ -1,10 +1,7 @@ #!/bin/bash -expected='(lambda l l)(1 2 3 4 5 6 7 8 9 10)' -actual=`target/psse 2>/dev/null < Date: Sun, 30 Dec 2018 19:07:07 +0000 Subject: [PATCH 013/101] Not really making progress. --- lisp/not-working-yet.lisp | 6 ++++ lisp/types.lisp | 7 ----- src/init.c | 1 + src/ops/lispops.c | 60 ++++++++++++++++++++++++++++++++------- src/ops/lispops.h | 4 +++ src/ops/read.c | 7 +++-- 6 files changed, 66 insertions(+), 19 deletions(-) create mode 100644 lisp/not-working-yet.lisp diff --git a/lisp/not-working-yet.lisp b/lisp/not-working-yet.lisp new file mode 100644 index 0000000..0f3a8c2 --- /dev/null +++ b/lisp/not-working-yet.lisp @@ -0,0 +1,6 @@ +(set! or (lambda values + "True if any of `values` are non-nil." + (cond + ((nil? values) nil) + ((car values) t) + (t (eval (cons 'or (cdr values))))))) diff --git a/lisp/types.lisp b/lisp/types.lisp index cba1ef6..7f7bf8c 100644 --- a/lisp/types.lisp +++ b/lisp/types.lisp @@ -15,10 +15,3 @@ (set! true? (lambda (o) "True if o is the canonical true value." (= (type o) "TRUE") ) ) (set! write? (lambda (o) "True if o is a write stream." (= (type o) "WRIT") ) ) -(set! or (lambda values - "True if any of `values` are non-nil." - (cond ((car values) t) (t (apply 'or (cdr values)))))) - -(set! number? - (lambda (o) - "I don't yet have an `or` operator diff --git a/src/init.c b/src/init.c index 15fd8e4..f446dc4 100644 --- a/src/init.c +++ b/src/init.c @@ -146,6 +146,7 @@ int main( int argc, char *argv[] ) { bind_function( L"progn", &lisp_progn ); bind_function( L"reverse", &lisp_reverse ); bind_function( L"set", &lisp_set ); + bind_function( L"source", &lisp_source ); bind_function( L"subtract", &lisp_subtract ); bind_function( L"throw", &lisp_exception ); bind_function( L"type", &lisp_type ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 1913406..476cf46 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1035,18 +1035,21 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * are not visible. So copy changes made in the oblist into the enviroment. * TODO: the whole process of resolving symbol values needs to be revisited * when we get onto namespaces. */ - struct cons_pointer cursor = oblist; - while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { - debug_print - ( L"lisp_repl: copying new oblist binding into REPL environment:\n", - DEBUG_REPL ); - debug_print_object( c_car( cursor ), DEBUG_REPL ); - debug_println( DEBUG_REPL ); + if ( !eq( oblist, old_oblist ) ) { + struct cons_pointer cursor = oblist; - new_env = make_cons( c_car( cursor ), new_env ); - cursor = c_cdr( cursor ); + while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = make_cons( c_car( cursor ), new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; } - old_oblist = oblist; println( os ); @@ -1079,3 +1082,40 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, return expr; } + +/** + * (source object) + * + * Function. + * Return the source code of the object, if it is an executable + * and has source code. + */ +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); + + switch ( cell.tag.value ) { + case FUNCTIONTV: + result = cell.payload.function.source; + break; + case SPECIALTV: + result = cell.payload.special.source; + break; + case LAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + case NLAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + } + // TODO: suffers from premature GC, and I can't see why! + inc_ref( result ); + + return result; +} diff --git a/src/ops/lispops.h b/src/ops/lispops.h index f9cd8ba..7868c4b 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -197,3 +197,7 @@ struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); diff --git a/src/ops/read.c b/src/ops/read.c index 2a8522c..410a27f 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -275,6 +275,9 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { result = make_string( initial, NIL ); break; case '"': + /* making a string of the null character means we can have an empty + * string. Just returning NIL here would make an empty string + * impossible. */ result = make_string( '\0', NIL ); break; default: @@ -302,9 +305,9 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { break; case ')': /* - * unquoted strings may not include right-parenthesis + * symbols may not include right-parenthesis */ - result = make_symbol( '\0', NIL ); + result = NIL; /* * push back the character read */ From 72ab4af20e4bc1baf1b0e58b08a01b21b7a60a36 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 14:43:47 +0000 Subject: [PATCH 014/101] Seem to have fixed the 'oblist getting lost' problem. --- lisp/fact.lisp | 1 + src/ops/lispops.c | 7 +++++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/fact.lisp b/lisp/fact.lisp index de1f12b..968ea73 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -1,5 +1,6 @@ (set! fact (lambda (n) + "Compute the factorial of `n`, expected to be an integer." (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 476cf46..d20dbf9 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1015,11 +1015,11 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; + inc_ref(env); inc_ref( input ); inc_ref( output ); inc_ref( prompt_name ); - inc_ref( new_env ); /* TODO: this is subtly wrong. If we were evaluating * (print (eval (read))) @@ -1039,6 +1039,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer cursor = oblist; while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + struct cons_pointer old_new_env = new_env; debug_print ( L"lisp_repl: copying new oblist binding into REPL environment:\n", DEBUG_REPL ); @@ -1046,6 +1047,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, debug_println( DEBUG_REPL ); new_env = make_cons( c_car( cursor ), new_env ); + inc_ref( new_env); + dec_ref( old_new_env); cursor = c_cdr( cursor ); } old_oblist = oblist; @@ -1078,7 +1081,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, dec_ref( input ); dec_ref( output ); dec_ref( prompt_name ); - dec_ref( new_env ); + dec_ref( env ); return expr; } From cad703f21862b578dbaf0e30ada6e7b475a4b16c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:11:55 +0000 Subject: [PATCH 015/101] Now safely detecting (but not dealing with) integer overflow. --- src/arith/integer.c | 53 ++++++++++++++++++++++++++++++++------------- src/ops/lispops.c | 13 ++++++----- src/ops/read.c | 4 +++- 3 files changed, 48 insertions(+), 22 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 0e74f7b..d916c99 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -12,6 +12,12 @@ #include #include #include +/* safe_iop, as available in the Ubuntu repository, is this one: + * https://code.google.com/archive/p/safe-iop/wikis/README.wiki + * which is installed as `libsafe-iop-dev`. There is an alternate + * implementation here: https://github.com/redpig/safe-iop/ + * which shares the same version number but is not compatible. */ +#include /* * wide characters */ @@ -107,16 +113,18 @@ struct cons_pointer add_integers( struct cons_pointer a, int64_t bv = integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - __int128_t rv = av + bv + carry; + int64_t rv = 0; - if ( rv > LONG_MAX || rv < LONG_MIN ) { + if ( safe_add( &rv, av, bv ) ) { + carry = 0; + } else { + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; - } else { - carry = 0; } result = make_integer( rv, result ); @@ -153,16 +161,18 @@ struct cons_pointer multiply_integers( struct cons_pointer a, int64_t bv = integerp( b ) ? pointer2cell( b ).payload.integer.value : 1; - __int128_t rv = ( av * bv ) + carry; + int64_t rv = 0; - if ( rv > LONG_MAX || rv < LONG_MIN ) { + if ( safe_mul( &rv, av, bv ) ) { + carry = 0; + } else { + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; - } else { - carry = 0; } result = make_integer( rv, result ); @@ -177,6 +187,19 @@ struct cons_pointer multiply_integers( struct cons_pointer a, return result; } +/** + * don't use; private to integer_to_string, and somewaht dodgy. + */ +struct cons_pointer integer_to_string_add_digit( int digit, int digits, + struct cons_pointer tail ) { + digits++; + wint_t character = ( wint_t ) hex_digits[digit]; + return ( digits % 3 == 0 ) ? + make_string( L',', make_string( character, + tail ) ) : + make_string( character, tail ); +} + /** * The general principle of printing a bignum is that you print the least * significant digit in whatever base you're dealing with, divide through @@ -195,24 +218,24 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int64_t accumulator = integer.payload.integer.value; bool is_negative = accumulator < 0; accumulator = llabs( accumulator ); + int digits = 0; if ( accumulator == 0 ) { result = c_string_to_lisp_string( L"0" ); } else { while ( accumulator > 0 ) { - debug_printf( DEBUG_ARITH, + debug_printf( DEBUG_IO, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { - debug_printf( DEBUG_ARITH, + debug_printf( DEBUG_IO, L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", accumulator % base, hex_digits[accumulator % base] ); - wint_t digit = ( wint_t ) hex_digits[accumulator % base]; result = - make_string( ( wint_t ) hex_digits[accumulator % base], - result ); + integer_to_string_add_digit( accumulator % base, digits++, + result ); accumulator = accumulator / base; } while ( accumulator > base ); @@ -223,8 +246,8 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, /* TODO: I don't believe it's as simple as this! */ accumulator += ( base * ( i % base ) ); result = - make_string( ( wint_t ) hex_digits[accumulator % base], - result ); + integer_to_string_add_digit( accumulator % base, digits++, + result ); accumulator += ( base * ( i / base ) ); } } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d20dbf9..d66af71 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -359,9 +359,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -1015,7 +1016,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; - inc_ref(env); + inc_ref( env ); inc_ref( input ); inc_ref( output ); @@ -1047,8 +1048,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, debug_println( DEBUG_REPL ); new_env = make_cons( c_car( cursor ), new_env ); - inc_ref( new_env); - dec_ref( old_new_env); + inc_ref( new_env ); + dec_ref( old_new_env ); cursor = c_cdr( cursor ); } old_oblist = oblist; diff --git a/src/ops/read.c b/src/ops/read.c index 410a27f..c83fc24 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -175,7 +175,7 @@ struct cons_pointer read_number( struct stack_frame *frame, initial ); for ( c = initial; iswdigit( c ) - || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { + || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { if ( seen_period || dividend != 0 ) { return throw_exception( c_string_to_lisp_string @@ -194,6 +194,8 @@ struct cons_pointer read_number( struct stack_frame *frame, accumulator = 0; } + } else if ( c == L',' ) { + // silently ignore it. } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); From e5f40032e960b3c182b9c66db502f5329d3cbb5b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:11:55 +0000 Subject: [PATCH 016/101] Now safely detecting (but not dealing with) integer overflow. Also printing and reading integers with comma separators. --- src/arith/integer.c | 53 ++++++++++++++++++++++++++++++++------------- src/ops/lispops.c | 13 ++++++----- src/ops/read.c | 4 +++- 3 files changed, 48 insertions(+), 22 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 0e74f7b..d916c99 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -12,6 +12,12 @@ #include #include #include +/* safe_iop, as available in the Ubuntu repository, is this one: + * https://code.google.com/archive/p/safe-iop/wikis/README.wiki + * which is installed as `libsafe-iop-dev`. There is an alternate + * implementation here: https://github.com/redpig/safe-iop/ + * which shares the same version number but is not compatible. */ +#include /* * wide characters */ @@ -107,16 +113,18 @@ struct cons_pointer add_integers( struct cons_pointer a, int64_t bv = integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - __int128_t rv = av + bv + carry; + int64_t rv = 0; - if ( rv > LONG_MAX || rv < LONG_MIN ) { + if ( safe_add( &rv, av, bv ) ) { + carry = 0; + } else { + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; - } else { - carry = 0; } result = make_integer( rv, result ); @@ -153,16 +161,18 @@ struct cons_pointer multiply_integers( struct cons_pointer a, int64_t bv = integerp( b ) ? pointer2cell( b ).payload.integer.value : 1; - __int128_t rv = ( av * bv ) + carry; + int64_t rv = 0; - if ( rv > LONG_MAX || rv < LONG_MIN ) { + if ( safe_mul( &rv, av, bv ) ) { + carry = 0; + } else { + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; - } else { - carry = 0; } result = make_integer( rv, result ); @@ -177,6 +187,19 @@ struct cons_pointer multiply_integers( struct cons_pointer a, return result; } +/** + * don't use; private to integer_to_string, and somewaht dodgy. + */ +struct cons_pointer integer_to_string_add_digit( int digit, int digits, + struct cons_pointer tail ) { + digits++; + wint_t character = ( wint_t ) hex_digits[digit]; + return ( digits % 3 == 0 ) ? + make_string( L',', make_string( character, + tail ) ) : + make_string( character, tail ); +} + /** * The general principle of printing a bignum is that you print the least * significant digit in whatever base you're dealing with, divide through @@ -195,24 +218,24 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int64_t accumulator = integer.payload.integer.value; bool is_negative = accumulator < 0; accumulator = llabs( accumulator ); + int digits = 0; if ( accumulator == 0 ) { result = c_string_to_lisp_string( L"0" ); } else { while ( accumulator > 0 ) { - debug_printf( DEBUG_ARITH, + debug_printf( DEBUG_IO, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { - debug_printf( DEBUG_ARITH, + debug_printf( DEBUG_IO, L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", accumulator % base, hex_digits[accumulator % base] ); - wint_t digit = ( wint_t ) hex_digits[accumulator % base]; result = - make_string( ( wint_t ) hex_digits[accumulator % base], - result ); + integer_to_string_add_digit( accumulator % base, digits++, + result ); accumulator = accumulator / base; } while ( accumulator > base ); @@ -223,8 +246,8 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, /* TODO: I don't believe it's as simple as this! */ accumulator += ( base * ( i % base ) ); result = - make_string( ( wint_t ) hex_digits[accumulator % base], - result ); + integer_to_string_add_digit( accumulator % base, digits++, + result ); accumulator += ( base * ( i / base ) ); } } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d20dbf9..d66af71 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -359,9 +359,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -1015,7 +1016,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; - inc_ref(env); + inc_ref( env ); inc_ref( input ); inc_ref( output ); @@ -1047,8 +1048,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, debug_println( DEBUG_REPL ); new_env = make_cons( c_car( cursor ), new_env ); - inc_ref( new_env); - dec_ref( old_new_env); + inc_ref( new_env ); + dec_ref( old_new_env ); cursor = c_cdr( cursor ); } old_oblist = oblist; diff --git a/src/ops/read.c b/src/ops/read.c index 410a27f..c83fc24 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -175,7 +175,7 @@ struct cons_pointer read_number( struct stack_frame *frame, initial ); for ( c = initial; iswdigit( c ) - || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { + || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { if ( seen_period || dividend != 0 ) { return throw_exception( c_string_to_lisp_string @@ -194,6 +194,8 @@ struct cons_pointer read_number( struct stack_frame *frame, accumulator = 0; } + } else if ( c == L',' ) { + // silently ignore it. } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); From a02d286ad536923c1201bf06687f5bd6b0147432 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:18:39 +0000 Subject: [PATCH 017/101] Spotted a bug in car of a stream, and fixed it. --- src/ops/lispops.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d66af71..9ab797a 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -625,6 +625,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, break; case READTV: result = make_string( fgetwc( cell.payload.stream.stream ), NIL ); + break; case STRINGTV: result = make_string( cell.payload.string.character, NIL ); break; From 6d2cf313cb8d162defb541b6c116aba09943f46c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:24:38 +0000 Subject: [PATCH 018/101] Very small fix to formatting integers. --- src/arith/integer.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/arith/integer.c b/src/arith/integer.c index d916c99..ec242bd 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -251,6 +251,14 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, accumulator += ( base * ( i / base ) ); } } + + if (stringp(result) && pointer2cell(result).payload.string.character == L',') { + /* if the number of digits in the string is divisible by 3, there will be + * an unwanted comma on the front. */ + struct cons_pointer tmp = result; + result = pointer2cell(result).payload.string.cdr; + dec_ref(tmp); + } if ( is_negative ) { result = make_string( L'-', result ); From 87007362f3dc7cf51b2faa35a911feaeff38e21b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:29:11 +0000 Subject: [PATCH 019/101] Fixed unit tests which were failing because of the change in formatting integers --- unit-tests/complex-list.sh | 2 +- unit-tests/recursion.sh | 2 +- unit-tests/reverse.sh | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index 5bb5e9c..3e84d79 100644 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(1 2 3 ("Fred") nil 77354)' +expected='(1 2 3 ("Fred") nil 77,354)' actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh index 407265e..6b5be2d 100644 --- a/unit-tests/recursion.sh +++ b/unit-tests/recursion.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='nil 3628800' +expected='nil 3,628,800' output=`target/psse 2>/dev/null < Date: Tue, 1 Jan 2019 15:04:44 +0000 Subject: [PATCH 020/101] This isn't working, but it's VERY promising. --- Makefile | 2 + lisp/fact.lisp | 2 +- notes/bignums.md | 7 ++++ src/arith/integer.c | 96 ++++++++++++++++++++++++++++++++------------- src/arith/peano.c | 12 +++--- 5 files changed, 84 insertions(+), 35 deletions(-) create mode 100644 notes/bignums.md diff --git a/Makefile b/Makefile index 4fe322f..7179c91 100644 --- a/Makefile +++ b/Makefile @@ -18,6 +18,8 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm +all: $(TARGET) + $(TARGET): $(OBJS) Makefile $(CC) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) diff --git a/lisp/fact.lisp b/lisp/fact.lisp index 968ea73..7df7246 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -4,4 +4,4 @@ (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) -(fact 20) +(fact 21) diff --git a/notes/bignums.md b/notes/bignums.md new file mode 100644 index 0000000..ea4b0b3 --- /dev/null +++ b/notes/bignums.md @@ -0,0 +1,7 @@ +# All integers are potentially bignums + +Each integer comprises at least one cell of type INTR, holding a signed 64 bit integer with a value in the range 0 ... MAX-INTEGER, where the actual value of MAX-INTEGER does not need to be the same as the C language LONG\_MAX, provided that it is less than this. It seems to me that a convenient number would be the largest number less than LONG\_MAX which has all bits set + +LONG\_MAX is 0x7FFFFFFFFFFFFFFF, so the number we're looking for is 0xFFFFFFFFFFFFFFF, which is 1,152,921,504,606,846,975, which is 2^60 - 1. This means we can use bit masking with 0xFFFFFFFFFFFFFFF to extract the part of **int64_t** which will fit in a single cell. + +It also means that if we multiply two **int64_t**s into an **__int128_t**, we can then right-shift by 60 places to get the carry. \ No newline at end of file diff --git a/src/arith/integer.c b/src/arith/integer.c index ec242bd..f7bb77d 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -28,6 +28,11 @@ #include "consspaceobject.h" #include "debug.h" +/* + * The maximum value we will allow in an integer cell. + */ +#define MAX_INTEGER ((__int128_t)0xFFFFFFFFFFFFFFF) + /** * hexadecimal digits for printing numbers. */ @@ -98,36 +103,48 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_print( L"Entering add_integers\n", DEBUG_ARITH ); struct cons_pointer result = NIL; - int64_t carry = 0; + struct cons_pointer cursor = NIL; + __int128_t carry = 0; if ( integerp( a ) && integerp( b ) ) { + debug_print( L"add_integers: ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L" x ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_printf( DEBUG_ARITH, L"; carry = %ld\n", carry ); + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - debug_print( L"add_integers: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" x ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L"; carry = %ld\n", carry ); + __int128_t av = + (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + __int128_t bv = + (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - int64_t av = - integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; - int64_t bv = - integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + __int128_t rv = av + bv + carry; - int64_t rv = 0; - - if ( safe_add( &rv, av, bv ) ) { + if ( MAX_INTEGER >= rv ) { carry = 0; } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", - carry ); - carry = llabs( rv / LONG_MAX ); - rv = rv % LONG_MAX; + (int64_t)carry ); + rv = rv & MAX_INTEGER; + } + + struct cons_pointer tail = make_integer( (int64_t)(rv << 64), NIL); + + if (nilp(cursor)) { + cursor = tail; + } else { + inc_ref(tail); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object * c = &pointer2cell(cursor); + c->payload.integer.more = tail; } - result = make_integer( rv, result ); a = pointer2cell( a ).payload.integer.more; b = pointer2cell( b ).payload.integer.more; } @@ -146,7 +163,8 @@ struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { struct cons_pointer result = NIL; - int64_t carry = 0; + struct cons_pointer cursor = NIL; + __int128_t carry = 0; if ( integerp( a ) && integerp( b ) ) { debug_print( L"multiply_integers: ", DEBUG_ARITH ); @@ -156,30 +174,52 @@ struct cons_pointer multiply_integers( struct cons_pointer a, debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - int64_t av = - integerp( a ) ? pointer2cell( a ).payload.integer.value : 1; - int64_t bv = - integerp( b ) ? pointer2cell( b ).payload.integer.value : 1; + __int128_t av = + (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + __int128_t bv = + (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - int64_t rv = 0; + /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and + * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry + * is very large (which I'm not certain whether it can be and am not + * intellectually up to proving it this morning) adding the carry might + * overflow `__int128_t`. Edge-case testing required. + */ + __int128_t rv = (av * bv) + carry; - if ( safe_mul( &rv, av, bv ) ) { + if ( MAX_INTEGER >= rv ) { carry = 0; } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", - carry ); - carry = llabs( rv / LONG_MAX ); - rv = rv % LONG_MAX; + (int64_t)carry ); + rv = rv & MAX_INTEGER; + } + + struct cons_pointer tail = make_integer( (int64_t)(rv << 64), NIL); + + if (nilp(cursor)) { + cursor = tail; + } else { + inc_ref(tail); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object * c = &pointer2cell(cursor); + c->payload.integer.more = tail; + } + + if ( nilp(result) ) { + result = cursor; } - result = make_integer( rv, result ); a = pointer2cell( a ).payload.integer.more; b = pointer2cell( b ).payload.integer.more; } } + debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); debug_print_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); diff --git a/src/arith/peano.c b/src/arith/peano.c index 3a24ed1..f34d632 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -284,10 +284,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = - make_integer( cell1.payload.integer.value * - cell2.payload.integer.value, NIL ); - //result = multiply_integers( arg1, arg2 ); +// result = +// make_integer( cell1.payload.integer.value * +// cell2.payload.integer.value, NIL ); + result = multiply_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -301,7 +301,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), + ( L"Cannot multiply: argument 2 is not a number" ), frame_pointer ); break; } @@ -327,7 +327,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), + ( L"Cannot multiply: argument 1 is not a number" ), frame_pointer ); } break; From d9d789fdd02455e9034e9c8cbc4070ff2971077f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 3 Jan 2019 11:21:08 +0000 Subject: [PATCH 021/101] Now creating the correct internal bignum representation add_integers returns an integer which by inspection of the internal representation is correct, but the print representation is not correct. --- lisp/expt.lisp | 2 ++ notes/bignums.md | 4 +-- src/arith/integer.c | 58 +++++++++++++++++++++++++------------------- src/ops/read.c | 3 +++ unit-tests/bignum.sh | 14 +++++++++++ 5 files changed, 54 insertions(+), 27 deletions(-) create mode 100644 unit-tests/bignum.sh diff --git a/lisp/expt.lisp b/lisp/expt.lisp index db6a7b3..af1fff1 100644 --- a/lisp/expt.lisp +++ b/lisp/expt.lisp @@ -4,3 +4,5 @@ (cond ((= x 1) n) (t (* n (expt n (- x 1))))))) + +(expt 2 65) diff --git a/notes/bignums.md b/notes/bignums.md index ea4b0b3..f77653c 100644 --- a/notes/bignums.md +++ b/notes/bignums.md @@ -2,6 +2,6 @@ Each integer comprises at least one cell of type INTR, holding a signed 64 bit integer with a value in the range 0 ... MAX-INTEGER, where the actual value of MAX-INTEGER does not need to be the same as the C language LONG\_MAX, provided that it is less than this. It seems to me that a convenient number would be the largest number less than LONG\_MAX which has all bits set -LONG\_MAX is 0x7FFFFFFFFFFFFFFF, so the number we're looking for is 0xFFFFFFFFFFFFFFF, which is 1,152,921,504,606,846,975, which is 2^60 - 1. This means we can use bit masking with 0xFFFFFFFFFFFFFFF to extract the part of **int64_t** which will fit in a single cell. +LONG\_MAX is 0x7FFFFFFFFFFFFFFF, so the number we're looking for is 0x0FFFFFFFFFFFFFFF, which is 1,152,921,504,606,846,975, which is 2^60 - 1. This means we can use bit masking with 0xFFFFFFFFFFFFFFF to extract the part of **int64_t** which will fit in a single cell. -It also means that if we multiply two **int64_t**s into an **__int128_t**, we can then right-shift by 60 places to get the carry. \ No newline at end of file +It also means that if we multiply two **int64_t**s into an **__int128_t**, we can then right-shift by 60 places to get the carry. diff --git a/src/arith/integer.c b/src/arith/integer.c index f7bb77d..957b6bb 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -31,7 +31,7 @@ /* * The maximum value we will allow in an integer cell. */ -#define MAX_INTEGER ((__int128_t)0xFFFFFFFFFFFFFFF) +#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL) /** * hexadecimal digits for printing numbers. @@ -109,9 +109,9 @@ struct cons_pointer add_integers( struct cons_pointer a, if ( integerp( a ) && integerp( b ) ) { debug_print( L"add_integers: ", DEBUG_ARITH ); debug_print_object( a, DEBUG_ARITH ); - debug_print( L" x ", DEBUG_ARITH ); + debug_print( L" + ", DEBUG_ARITH ); debug_print_object( b, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L"; carry = %ld\n", carry ); + debug_println( DEBUG_ARITH); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = @@ -133,16 +133,20 @@ struct cons_pointer add_integers( struct cons_pointer a, rv = rv & MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)(rv << 64), NIL); + struct cons_pointer tail = make_integer( (int64_t)rv, NIL); if (nilp(cursor)) { cursor = tail; } else { - inc_ref(tail); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object * c = &pointer2cell(cursor); - c->payload.integer.more = tail; + inc_ref(tail); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object * c = &pointer2cell(cursor); + c->payload.integer.more = tail; + } + + if ( nilp(result) ) { + result = cursor; } a = pointer2cell( a ).payload.integer.more; @@ -150,7 +154,7 @@ struct cons_pointer add_integers( struct cons_pointer a, } } debug_print( L"add_integers returning: ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); + debug_dump_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); return result; @@ -167,10 +171,10 @@ struct cons_pointer multiply_integers( struct cons_pointer a, __int128_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - debug_print( L"multiply_integers: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" x ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); + debug_print( L"multiply_integers: \n", DEBUG_ARITH ); + debug_dump_object( a, DEBUG_ARITH ); + debug_print( L" x \n", DEBUG_ARITH ); + debug_dump_object( b, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { @@ -196,19 +200,19 @@ struct cons_pointer multiply_integers( struct cons_pointer a, debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", (int64_t)carry ); - rv = rv & MAX_INTEGER; + rv &= MAX_INTEGER; // <<< PROBLEM IS HERE! } - struct cons_pointer tail = make_integer( (int64_t)(rv << 64), NIL); + struct cons_pointer tail = make_integer( (int64_t)rv, NIL); if (nilp(cursor)) { cursor = tail; } else { - inc_ref(tail); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object * c = &pointer2cell(cursor); - c->payload.integer.more = tail; + inc_ref(tail); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object * c = &pointer2cell(cursor); + c->payload.integer.more = tail; } if ( nilp(result) ) { @@ -220,8 +224,8 @@ struct cons_pointer multiply_integers( struct cons_pointer a, } } - debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); + debug_print( L"multiply_integers returning:\n", DEBUG_ARITH ); + debug_dump_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); return result; @@ -260,7 +264,11 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, accumulator = llabs( accumulator ); int digits = 0; - if ( accumulator == 0 ) { + if ( accumulator == 0 && !nilp(integer.payload.integer.more) ) { + accumulator = MAX_INTEGER; + } + + if ( accumulator == 0) { result = c_string_to_lisp_string( L"0" ); } else { while ( accumulator > 0 ) { @@ -291,7 +299,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, accumulator += ( base * ( i / base ) ); } } - + if (stringp(result) && pointer2cell(result).payload.string.character == L',') { /* if the number of digits in the string is divisible by 3, there will be * an unwanted comma on the front. */ diff --git a/src/ops/read.c b/src/ops/read.c index c83fc24..cc035a1 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -161,6 +161,9 @@ struct cons_pointer read_number( struct stack_frame *frame, wint_t initial, bool seen_period ) { debug_print( L"entering read_number\n", DEBUG_IO ); struct cons_pointer result = NIL; + + /* TODO: accumulator and dividend cannot be `int64_t`s, otherwise we cannot + * read bignums. They will have to be Lisp integers. */ int64_t accumulator = 0; int64_t dividend = 0; int places_of_decimals = 0; diff --git a/unit-tests/bignum.sh b/unit-tests/bignum.sh new file mode 100644 index 0000000..aa29143 --- /dev/null +++ b/unit-tests/bignum.sh @@ -0,0 +1,14 @@ +#!/bin/bash + +expected='1,152,921,504,606,846,976' +# 1,152,921,504,606,846,975 is the largest single cell positive integer; +# consequently 1,152,921,504,606,846,976 is the first two cell positive integer. +actual=`echo '(+ 1,152,921,504,606,846,975 1)' | target/psse -v 68 2>bignum.log | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From 9b6a37ebb5ae6e2a3411fed9552d8b525c7afb78 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 4 Jan 2019 10:39:48 +0000 Subject: [PATCH 022/101] Now successfully reading/printing 2 cell bignums Something is wrong with n-cell bignums, but let's make haste slowly. --- src/arith/integer.c | 117 +++++++++++++++++++++----------------------- src/arith/peano.c | 111 +++++++++++++++++++++-------------------- src/arith/peano.h | 62 +++++++++++++++-------- src/arith/ratio.c | 10 +--- 4 files changed, 157 insertions(+), 143 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 957b6bb..d6162ea 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -111,13 +111,15 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_print_object( a, DEBUG_ARITH ); debug_print( L" + ", DEBUG_ARITH ); debug_print_object( b, DEBUG_ARITH ); - debug_println( DEBUG_ARITH); + debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = - (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + ( __int128_t ) integerp( a ) ? pointer2cell( a ). + payload.integer.value : 0; __int128_t bv = - (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + ( __int128_t ) integerp( b ) ? pointer2cell( b ). + payload.integer.value : 0; __int128_t rv = av + bv + carry; @@ -126,27 +128,27 @@ struct cons_pointer add_integers( struct cons_pointer a, } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. - carry = rv >> 60; + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", - (int64_t)carry ); + ( int64_t ) carry ); rv = rv & MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)rv, NIL); + struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - if (nilp(cursor)) { - cursor = tail; + if ( nilp( cursor ) ) { + cursor = tail; } else { - inc_ref(tail); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object * c = &pointer2cell(cursor); - c->payload.integer.more = tail; + inc_ref( tail ); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object *c = &pointer2cell( cursor ); + c->payload.integer.more = tail; } - if ( nilp(result) ) { - result = cursor; + if ( nilp( result ) ) { + result = cursor; } a = pointer2cell( a ).payload.integer.more; @@ -179,9 +181,11 @@ struct cons_pointer multiply_integers( struct cons_pointer a, while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = - (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + ( __int128_t ) integerp( a ) ? pointer2cell( a ). + payload.integer.value : 1; __int128_t bv = - (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + ( __int128_t ) integerp( b ) ? pointer2cell( b ). + payload.integer.value : 1; /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry @@ -189,34 +193,34 @@ struct cons_pointer multiply_integers( struct cons_pointer a, * intellectually up to proving it this morning) adding the carry might * overflow `__int128_t`. Edge-case testing required. */ - __int128_t rv = (av * bv) + carry; + __int128_t rv = ( av * bv ) + carry; - if ( MAX_INTEGER >= rv ) { + if ( MAX_INTEGER >= rv ) { carry = 0; } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. - carry = rv >> 60; + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", - (int64_t)carry ); - rv &= MAX_INTEGER; // <<< PROBLEM IS HERE! + ( int64_t ) carry ); + rv &= MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)rv, NIL); + struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - if (nilp(cursor)) { - cursor = tail; + if ( nilp( cursor ) ) { + cursor = tail; } else { - inc_ref(tail); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object * c = &pointer2cell(cursor); - c->payload.integer.more = tail; - } + inc_ref( tail ); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object *c = &pointer2cell( cursor ); + c->payload.integer.more = tail; + } - if ( nilp(result) ) { - result = cursor; + if ( nilp( result ) ) { + result = cursor; } a = pointer2cell( a ).payload.integer.more; @@ -259,25 +263,27 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int base ) { struct cons_pointer result = NIL; struct cons_space_object integer = pointer2cell( int_pointer ); - int64_t accumulator = integer.payload.integer.value; - bool is_negative = accumulator < 0; - accumulator = llabs( accumulator ); + __int128_t accumulator = llabs( integer.payload.integer.value ); + bool is_negative = integer.payload.integer.value < 0; int digits = 0; - if ( accumulator == 0 && !nilp(integer.payload.integer.more) ) { - accumulator = MAX_INTEGER; - } - - if ( accumulator == 0) { + if ( accumulator == 0 && nilp( integer.payload.integer.more ) ) { result = c_string_to_lisp_string( L"0" ); } else { - while ( accumulator > 0 ) { + while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { + if ( !nilp( integer.payload.integer.more ) ) { + integer = pointer2cell( integer.payload.integer.more ); + accumulator += + ( llabs( integer.payload.integer.value ) * + ( MAX_INTEGER + 1 ) ); + } + debug_printf( DEBUG_IO, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", + L"integer_to_string: digit is %ld, hexadecimal is %c\n:", accumulator % base, hex_digits[accumulator % base] ); @@ -286,26 +292,15 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, result ); accumulator = accumulator / base; } while ( accumulator > base ); - - if ( integerp( integer.payload.integer.more ) ) { - integer = pointer2cell( integer.payload.integer.more ); - int64_t i = integer.payload.integer.value; - - /* TODO: I don't believe it's as simple as this! */ - accumulator += ( base * ( i % base ) ); - result = - integer_to_string_add_digit( accumulator % base, digits++, - result ); - accumulator += ( base * ( i / base ) ); - } } - if (stringp(result) && pointer2cell(result).payload.string.character == L',') { - /* if the number of digits in the string is divisible by 3, there will be - * an unwanted comma on the front. */ - struct cons_pointer tmp = result; - result = pointer2cell(result).payload.string.cdr; - dec_ref(tmp); + if ( stringp( result ) + && pointer2cell( result ).payload.string.character == L',' ) { + /* if the number of digits in the string is divisible by 3, there will be + * an unwanted comma on the front. */ + struct cons_pointer tmp = result; + result = pointer2cell( result ).payload.string.cdr; + dec_ref( tmp ); } if ( is_negative ) { diff --git a/src/arith/peano.c b/src/arith/peano.c index f34d632..481f33e 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -105,6 +105,9 @@ int64_t to_long_int( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: + /* TODO: if (integerp(cell.payload.integer.more)) { + * throw an exception! + * } */ result = cell.payload.integer.value; break; case RATIOTV: @@ -252,9 +255,9 @@ struct cons_pointer lisp_add( struct stack_frame /** -* return a cons_pointer indicating a number which is the product of -* the numbers indicated by `arg1` and `arg2`. -*/ + * return a cons_pointer indicating a number which is the product of + * the numbers indicated by `arg1` and `arg2`. + */ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, @@ -284,9 +287,6 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: -// result = -// make_integer( cell1.payload.integer.value * -// cell2.payload.integer.value, NIL ); result = multiply_integers( arg1, arg2 ); break; case RATIOTV: @@ -351,7 +351,6 @@ struct cons_pointer multiply_2( struct stack_frame *frame, return result; } - /** * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; @@ -393,10 +392,10 @@ struct cons_pointer lisp_multiply( struct /** * return a cons_pointer indicating a number which is the - * inverse of the number indicated by `arg`. + * 0 - the number indicated by `arg`. */ -struct cons_pointer inverse( struct cons_pointer frame, - struct cons_pointer arg ) { +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -405,18 +404,17 @@ struct cons_pointer inverse( struct cons_pointer frame, result = arg; break; case INTEGERTV: - // TODO: bignums - result = make_integer( 0 - to_long_int( arg ), NIL ); + result = + make_integer( 0 - cell.payload.integer.value, + cell.payload.integer.more ); break; case NILTV: result = TRUE; break; case RATIOTV: result = make_ratio( frame, - make_integer( 0 - - to_long_int( cell.payload. - ratio.dividend ), - NIL ), + negative( frame, + cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -430,50 +428,48 @@ struct cons_pointer inverse( struct cons_pointer frame, return result; } - /** - * Subtract one number from another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. + * return a cons_pointer indicating a number which is the result of + * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, + * in the context of this `frame`. */ -struct cons_pointer lisp_subtract( struct - stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { +struct cons_pointer subtract_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { struct cons_pointer result = NIL; - struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); - struct cons_space_object cell1 = pointer2cell( frame->arg[1] ); - switch ( cell0.tag.value ) { + switch ( pointer2cell( arg1 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[0]; + result = arg1; break; case INTEGERTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; - case INTEGERTV: - result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, - NIL ); + case INTEGERTV:{ + struct cons_pointer i = + negative( frame_pointer, arg2 ); + inc_ref( i ); + result = add_integers( arg1, i ); + dec_ref( i ); + } break; case RATIOTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[0], + make_ratio( frame_pointer, arg1, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, tmp, - frame->arg[1] ); + subtract_ratio_ratio( frame_pointer, tmp, arg2 ); dec_ref( tmp ); } break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -483,30 +479,27 @@ struct cons_pointer lisp_subtract( struct } break; case RATIOTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; case INTEGERTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[1], + make_ratio( frame_pointer, arg2, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - tmp ); + subtract_ratio_ratio( frame_pointer, arg1, tmp ); dec_ref( tmp ); } break; case RATIOTV: - result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - frame->arg[1] ); + result = subtract_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -516,9 +509,8 @@ struct cons_pointer lisp_subtract( struct } break; case REALTV: - result = exceptionp( frame->arg[1] ) ? frame->arg[1] : - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + result = exceptionp( arg2 ) ? arg2 : + make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -532,6 +524,19 @@ struct cons_pointer lisp_subtract( struct return result; } +/** + * Subtract one number from another. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer lisp_subtract( struct + stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return subtract_2( frame, frame_pointer, frame->arg[0], frame->arg[1] ); +} + /** * Divide one number by another. * @param env the evaluation environment - ignored; diff --git a/src/arith/peano.h b/src/arith/peano.h index f1c21b4..0bd09d5 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -12,9 +12,17 @@ #ifndef PEANO_H #define PEANO_H -#ifdef __cplusplus -extern "C" { -#endif +bool zerop( struct cons_pointer arg ); + +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ); + +/** + * TODO: cannot throw an exception out of here, which is a problem + * if a ratio may legally have zero as a divisor, or something which is + * not a number is passed in. + */ +long double to_long_double( struct cons_pointer arg ); /** * Add an indefinite number of numbers together @@ -22,9 +30,9 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Multiply an indefinite number of numbers together @@ -32,10 +40,26 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_multiply( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_multiply( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); + +/** + * return a cons_pointer indicating a number which is the + * 0 - the number indicated by `arg`. + */ +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ); + +/** + * return a cons_pointer indicating a number which is the result of + * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, + * in the context of this `frame`. + */ +struct cons_pointer subtract_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ); /** * Subtract one number from another. @@ -43,10 +67,9 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_subtract( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_subtract( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Divide one number by another. @@ -54,11 +77,8 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); -#ifdef __cplusplus -} -#endif -#endif /* PEANO_H */ +#endif /* PEANO_H */ diff --git a/src/arith/ratio.c b/src/arith/ratio.c index fd6a770..f9dd0f4 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -17,17 +17,11 @@ #include "equal.h" #include "integer.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" -/* - * declared in peano.c, can't include piano.h here because - * circularity. TODO: refactor. - */ -struct cons_pointer inverse( struct cons_pointer frame_pointer, - struct cons_pointer arg ); - /** * return, as a int64_t, the greatest common divisor of `m` and `n`, */ @@ -297,7 +291,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = inverse( frame_pointer, arg2 ), + struct cons_pointer i = negative( frame_pointer, arg2 ), result = add_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); From 67802a07b8f5b97502f1e7ae1102ccee5ce04b64 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 4 Jan 2019 10:39:48 +0000 Subject: [PATCH 023/101] Now successfully reading/printing 2 cell bignums Something is wrong with n-cell bignums, but let's make haste slowly. --- src/arith/integer.c | 117 +++++++++++++++++++++----------------------- src/arith/peano.c | 111 +++++++++++++++++++++-------------------- src/arith/peano.h | 62 +++++++++++++++-------- src/arith/ratio.c | 10 +--- src/ops/read.c | 66 +++++++++++++------------ 5 files changed, 192 insertions(+), 174 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 957b6bb..d6162ea 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -111,13 +111,15 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_print_object( a, DEBUG_ARITH ); debug_print( L" + ", DEBUG_ARITH ); debug_print_object( b, DEBUG_ARITH ); - debug_println( DEBUG_ARITH); + debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = - (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + ( __int128_t ) integerp( a ) ? pointer2cell( a ). + payload.integer.value : 0; __int128_t bv = - (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + ( __int128_t ) integerp( b ) ? pointer2cell( b ). + payload.integer.value : 0; __int128_t rv = av + bv + carry; @@ -126,27 +128,27 @@ struct cons_pointer add_integers( struct cons_pointer a, } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. - carry = rv >> 60; + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", - (int64_t)carry ); + ( int64_t ) carry ); rv = rv & MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)rv, NIL); + struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - if (nilp(cursor)) { - cursor = tail; + if ( nilp( cursor ) ) { + cursor = tail; } else { - inc_ref(tail); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object * c = &pointer2cell(cursor); - c->payload.integer.more = tail; + inc_ref( tail ); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object *c = &pointer2cell( cursor ); + c->payload.integer.more = tail; } - if ( nilp(result) ) { - result = cursor; + if ( nilp( result ) ) { + result = cursor; } a = pointer2cell( a ).payload.integer.more; @@ -179,9 +181,11 @@ struct cons_pointer multiply_integers( struct cons_pointer a, while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = - (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + ( __int128_t ) integerp( a ) ? pointer2cell( a ). + payload.integer.value : 1; __int128_t bv = - (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + ( __int128_t ) integerp( b ) ? pointer2cell( b ). + payload.integer.value : 1; /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry @@ -189,34 +193,34 @@ struct cons_pointer multiply_integers( struct cons_pointer a, * intellectually up to proving it this morning) adding the carry might * overflow `__int128_t`. Edge-case testing required. */ - __int128_t rv = (av * bv) + carry; + __int128_t rv = ( av * bv ) + carry; - if ( MAX_INTEGER >= rv ) { + if ( MAX_INTEGER >= rv ) { carry = 0; } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. - carry = rv >> 60; + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", - (int64_t)carry ); - rv &= MAX_INTEGER; // <<< PROBLEM IS HERE! + ( int64_t ) carry ); + rv &= MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)rv, NIL); + struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - if (nilp(cursor)) { - cursor = tail; + if ( nilp( cursor ) ) { + cursor = tail; } else { - inc_ref(tail); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object * c = &pointer2cell(cursor); - c->payload.integer.more = tail; - } + inc_ref( tail ); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object *c = &pointer2cell( cursor ); + c->payload.integer.more = tail; + } - if ( nilp(result) ) { - result = cursor; + if ( nilp( result ) ) { + result = cursor; } a = pointer2cell( a ).payload.integer.more; @@ -259,25 +263,27 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int base ) { struct cons_pointer result = NIL; struct cons_space_object integer = pointer2cell( int_pointer ); - int64_t accumulator = integer.payload.integer.value; - bool is_negative = accumulator < 0; - accumulator = llabs( accumulator ); + __int128_t accumulator = llabs( integer.payload.integer.value ); + bool is_negative = integer.payload.integer.value < 0; int digits = 0; - if ( accumulator == 0 && !nilp(integer.payload.integer.more) ) { - accumulator = MAX_INTEGER; - } - - if ( accumulator == 0) { + if ( accumulator == 0 && nilp( integer.payload.integer.more ) ) { result = c_string_to_lisp_string( L"0" ); } else { - while ( accumulator > 0 ) { + while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { + if ( !nilp( integer.payload.integer.more ) ) { + integer = pointer2cell( integer.payload.integer.more ); + accumulator += + ( llabs( integer.payload.integer.value ) * + ( MAX_INTEGER + 1 ) ); + } + debug_printf( DEBUG_IO, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", + L"integer_to_string: digit is %ld, hexadecimal is %c\n:", accumulator % base, hex_digits[accumulator % base] ); @@ -286,26 +292,15 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, result ); accumulator = accumulator / base; } while ( accumulator > base ); - - if ( integerp( integer.payload.integer.more ) ) { - integer = pointer2cell( integer.payload.integer.more ); - int64_t i = integer.payload.integer.value; - - /* TODO: I don't believe it's as simple as this! */ - accumulator += ( base * ( i % base ) ); - result = - integer_to_string_add_digit( accumulator % base, digits++, - result ); - accumulator += ( base * ( i / base ) ); - } } - if (stringp(result) && pointer2cell(result).payload.string.character == L',') { - /* if the number of digits in the string is divisible by 3, there will be - * an unwanted comma on the front. */ - struct cons_pointer tmp = result; - result = pointer2cell(result).payload.string.cdr; - dec_ref(tmp); + if ( stringp( result ) + && pointer2cell( result ).payload.string.character == L',' ) { + /* if the number of digits in the string is divisible by 3, there will be + * an unwanted comma on the front. */ + struct cons_pointer tmp = result; + result = pointer2cell( result ).payload.string.cdr; + dec_ref( tmp ); } if ( is_negative ) { diff --git a/src/arith/peano.c b/src/arith/peano.c index f34d632..481f33e 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -105,6 +105,9 @@ int64_t to_long_int( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: + /* TODO: if (integerp(cell.payload.integer.more)) { + * throw an exception! + * } */ result = cell.payload.integer.value; break; case RATIOTV: @@ -252,9 +255,9 @@ struct cons_pointer lisp_add( struct stack_frame /** -* return a cons_pointer indicating a number which is the product of -* the numbers indicated by `arg1` and `arg2`. -*/ + * return a cons_pointer indicating a number which is the product of + * the numbers indicated by `arg1` and `arg2`. + */ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, @@ -284,9 +287,6 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: -// result = -// make_integer( cell1.payload.integer.value * -// cell2.payload.integer.value, NIL ); result = multiply_integers( arg1, arg2 ); break; case RATIOTV: @@ -351,7 +351,6 @@ struct cons_pointer multiply_2( struct stack_frame *frame, return result; } - /** * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; @@ -393,10 +392,10 @@ struct cons_pointer lisp_multiply( struct /** * return a cons_pointer indicating a number which is the - * inverse of the number indicated by `arg`. + * 0 - the number indicated by `arg`. */ -struct cons_pointer inverse( struct cons_pointer frame, - struct cons_pointer arg ) { +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -405,18 +404,17 @@ struct cons_pointer inverse( struct cons_pointer frame, result = arg; break; case INTEGERTV: - // TODO: bignums - result = make_integer( 0 - to_long_int( arg ), NIL ); + result = + make_integer( 0 - cell.payload.integer.value, + cell.payload.integer.more ); break; case NILTV: result = TRUE; break; case RATIOTV: result = make_ratio( frame, - make_integer( 0 - - to_long_int( cell.payload. - ratio.dividend ), - NIL ), + negative( frame, + cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -430,50 +428,48 @@ struct cons_pointer inverse( struct cons_pointer frame, return result; } - /** - * Subtract one number from another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. + * return a cons_pointer indicating a number which is the result of + * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, + * in the context of this `frame`. */ -struct cons_pointer lisp_subtract( struct - stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { +struct cons_pointer subtract_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { struct cons_pointer result = NIL; - struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); - struct cons_space_object cell1 = pointer2cell( frame->arg[1] ); - switch ( cell0.tag.value ) { + switch ( pointer2cell( arg1 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[0]; + result = arg1; break; case INTEGERTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; - case INTEGERTV: - result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, - NIL ); + case INTEGERTV:{ + struct cons_pointer i = + negative( frame_pointer, arg2 ); + inc_ref( i ); + result = add_integers( arg1, i ); + dec_ref( i ); + } break; case RATIOTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[0], + make_ratio( frame_pointer, arg1, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, tmp, - frame->arg[1] ); + subtract_ratio_ratio( frame_pointer, tmp, arg2 ); dec_ref( tmp ); } break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -483,30 +479,27 @@ struct cons_pointer lisp_subtract( struct } break; case RATIOTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; case INTEGERTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[1], + make_ratio( frame_pointer, arg2, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - tmp ); + subtract_ratio_ratio( frame_pointer, arg1, tmp ); dec_ref( tmp ); } break; case RATIOTV: - result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - frame->arg[1] ); + result = subtract_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -516,9 +509,8 @@ struct cons_pointer lisp_subtract( struct } break; case REALTV: - result = exceptionp( frame->arg[1] ) ? frame->arg[1] : - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + result = exceptionp( arg2 ) ? arg2 : + make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -532,6 +524,19 @@ struct cons_pointer lisp_subtract( struct return result; } +/** + * Subtract one number from another. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer lisp_subtract( struct + stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return subtract_2( frame, frame_pointer, frame->arg[0], frame->arg[1] ); +} + /** * Divide one number by another. * @param env the evaluation environment - ignored; diff --git a/src/arith/peano.h b/src/arith/peano.h index f1c21b4..0bd09d5 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -12,9 +12,17 @@ #ifndef PEANO_H #define PEANO_H -#ifdef __cplusplus -extern "C" { -#endif +bool zerop( struct cons_pointer arg ); + +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ); + +/** + * TODO: cannot throw an exception out of here, which is a problem + * if a ratio may legally have zero as a divisor, or something which is + * not a number is passed in. + */ +long double to_long_double( struct cons_pointer arg ); /** * Add an indefinite number of numbers together @@ -22,9 +30,9 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Multiply an indefinite number of numbers together @@ -32,10 +40,26 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_multiply( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_multiply( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); + +/** + * return a cons_pointer indicating a number which is the + * 0 - the number indicated by `arg`. + */ +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ); + +/** + * return a cons_pointer indicating a number which is the result of + * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, + * in the context of this `frame`. + */ +struct cons_pointer subtract_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ); /** * Subtract one number from another. @@ -43,10 +67,9 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_subtract( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_subtract( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Divide one number by another. @@ -54,11 +77,8 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); -#ifdef __cplusplus -} -#endif -#endif /* PEANO_H */ +#endif /* PEANO_H */ diff --git a/src/arith/ratio.c b/src/arith/ratio.c index fd6a770..f9dd0f4 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -17,17 +17,11 @@ #include "equal.h" #include "integer.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" -/* - * declared in peano.c, can't include piano.h here because - * circularity. TODO: refactor. - */ -struct cons_pointer inverse( struct cons_pointer frame_pointer, - struct cons_pointer arg ); - /** * return, as a int64_t, the greatest common divisor of `m` and `n`, */ @@ -297,7 +291,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = inverse( frame_pointer, arg2 ), + struct cons_pointer i = negative( frame_pointer, arg2 ), result = add_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); diff --git a/src/ops/read.c b/src/ops/read.c index cc035a1..9074652 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -23,6 +23,7 @@ #include "integer.h" #include "intern.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" #include "read.h" @@ -152,25 +153,25 @@ struct cons_pointer read_continuation( struct stack_frame *frame, /** * read a number from this input stream, given this initial character. - * TODO: to be able to read bignums, we need to read the number from the - * input stream into a Lisp string, and then convert it to a number. + * TODO: Need to do a lot of inc_ref and dec_ref, to make sure the + * garbage is collected. */ struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer frame_pointer, FILE * input, wint_t initial, bool seen_period ) { debug_print( L"entering read_number\n", DEBUG_IO ); - struct cons_pointer result = NIL; - /* TODO: accumulator and dividend cannot be `int64_t`s, otherwise we cannot - * read bignums. They will have to be Lisp integers. */ - int64_t accumulator = 0; - int64_t dividend = 0; + struct cons_pointer result = make_integer( 0, NIL ); + /* TODO: we really need to be getting `base` from a privileged Lisp name - + * and it should be the same privileged name we use when writing numbers */ + struct cons_pointer base = make_integer( 10, NIL ); + struct cons_pointer dividend = NIL; int places_of_decimals = 0; wint_t c; - bool negative = initial == btowc( '-' ); + bool neg = initial == btowc( '-' ); - if ( negative ) { + if ( neg ) { initial = fgetwc( input ); } @@ -180,7 +181,7 @@ struct cons_pointer read_number( struct stack_frame *frame, for ( c = initial; iswdigit( c ) || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { - if ( seen_period || dividend != 0 ) { + if ( seen_period || !nilp( dividend ) ) { return throw_exception( c_string_to_lisp_string ( L"Malformed number: too many periods" ), frame_pointer ); @@ -188,23 +189,24 @@ struct cons_pointer read_number( struct stack_frame *frame, seen_period = true; } } else if ( c == btowc( '/' ) ) { - if ( seen_period || dividend > 0 ) { + if ( seen_period || !nilp( dividend ) ) { 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; + dividend = result; - accumulator = 0; + result = make_integer( 0, NIL ); } } else if ( c == L',' ) { // silently ignore it. } else { - accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); + result = add_integers( multiply_integers( result, base ), + make_integer( ( int ) c - ( int ) '0', + NIL ) ); debug_printf( DEBUG_IO, - L"Added character %c, accumulator now %ld\n", - c, accumulator ); + L"Added character %c, result now %ld\n", c, result ); if ( seen_period ) { places_of_decimals++; @@ -217,21 +219,23 @@ struct cons_pointer read_number( struct stack_frame *frame, */ ungetwc( c, input ); if ( seen_period ) { - long double rv = ( long double ) - ( accumulator / pow( 10, places_of_decimals ) ); - if ( negative ) { - rv = 0 - rv; - } - result = make_real( rv ); - } else if ( dividend != 0 ) { - result = - make_ratio( frame_pointer, make_integer( dividend, NIL ), - make_integer( accumulator, NIL ) ); - } else { - if ( negative ) { - accumulator = 0 - accumulator; - } - result = make_integer( accumulator, NIL ); + struct cons_pointer div = make_ratio( frame_pointer, result, + make_integer( powl + ( to_long_double + ( base ), + places_of_decimals ), + NIL ) ); + inc_ref( div ); + + result = make_real( to_long_double( div ) ); + + dec_ref( div ); + } else if ( integerp( dividend ) ) { + result = make_ratio( frame_pointer, dividend, result ); + } + + if ( neg ) { + result = negative( frame_pointer, result ); } debug_print( L"read_number returning\n", DEBUG_IO ); From 67443e1d462a5f7befe03b1aa38963e9725f9ce2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 4 Jan 2019 11:04:55 +0000 Subject: [PATCH 024/101] OK, adding bignums works; multiplying bignums does not work. There's no evidence of a bug in reading/printing, because the only way I can currently get a number big enough to trigger the supposed bug is by multiplying, which doesn't work. --- src/arith/integer.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index d6162ea..9b23001 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -79,7 +79,7 @@ long double numeric_value( struct cons_pointer pointer ) { */ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { struct cons_pointer result = NIL; - debug_print( L"Entering make_integer\n", DEBUG_ARITH ); + debug_print( L"Entering make_integer\n", DEBUG_ALLOC ); if ( integerp( more ) || nilp( more ) ) { result = allocate_cell( INTEGERTAG ); @@ -89,8 +89,8 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { } - debug_print( L"make_integer: returning\n", DEBUG_ARITH ); - debug_dump_object( result, DEBUG_ARITH ); + debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); + debug_dump_object( result, DEBUG_ALLOC ); return result; } From 396e214b5fb99c32fda2c260d96b68f8fb8cdfc8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 4 Jan 2019 11:24:05 +0000 Subject: [PATCH 025/101] Increased maximum memory allocation --- lisp/fact.lisp | 2 +- src/memory/conspage.h | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/fact.lisp b/lisp/fact.lisp index 7df7246..86d452a 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -4,4 +4,4 @@ (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) -(fact 21) +(fact 1000) diff --git a/src/memory/conspage.h b/src/memory/conspage.h index bc1361e..aff6f40 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -9,7 +9,7 @@ * to) is the maximum value of an unsigned 32 bit integer, which is to * say 4294967296. However, we'll start small. */ -#define CONSPAGESIZE 8 +#define CONSPAGESIZE 1024 /** * the number of cons pages we will initially allow for. For @@ -25,7 +25,7 @@ * of addressable memory, which is only slightly more than the * number of atoms in the universe. */ -#define NCONSPAGES 8 +#define NCONSPAGES 64 /** * a cons page is essentially just an array of cons space objects. It From d624c671cdbf55a8b475fcc385efca343a9cd664 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 5 Jan 2019 11:42:17 +0000 Subject: [PATCH 026/101] Major refactoring, all tests still pass Bignum issues not yet folly resolved. --- src/arith/integer.c | 159 +++++++++++++++++--------------------------- src/init.c | 1 + src/memory/dump.c | 1 + src/memory/dump.h | 1 - src/ops/lispops.c | 30 ++++++++- src/ops/lispops.h | 3 + 6 files changed, 96 insertions(+), 99 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 9b23001..779a112 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -94,145 +94,110 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { return result; } -/** - * Return the sum of the integers pointed to by `a` and `b`. If either isn't - * an integer, will return nil. - */ -struct cons_pointer add_integers( struct cons_pointer a, - struct cons_pointer b ) { - debug_print( L"Entering add_integers\n", DEBUG_ARITH ); +/** + * internal workings of both `add_integers` and `multiply_integers` (and + * possibly, later, other operations. Apply the operator `op` to the + * integer arguments `a` and `b`, and return a pointer to the result. If + * either `a` or `b` is not an integer, returns `NIL`. + */ +struct cons_pointer operate_on_integers( struct cons_pointer a, + struct cons_pointer b, + char op) { struct cons_pointer result = NIL; struct cons_pointer cursor = NIL; __int128_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - debug_print( L"add_integers: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" + ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); + debug_print( L"operate_on_integers: \n", DEBUG_ARITH ); + debug_dump_object( a, DEBUG_ARITH ); + debug_printf( DEBUG_ARITH, L" %c \n", op); + debug_dump_object( b, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = ( __int128_t ) integerp( a ) ? pointer2cell( a ). - payload.integer.value : 0; + payload.integer.value : op == '*' ? 1 : 0; __int128_t bv = ( __int128_t ) integerp( b ) ? pointer2cell( b ). - payload.integer.value : 0; + payload.integer.value : op == '*' ? 1 : 0; - __int128_t rv = av + bv + carry; + /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and + * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry + * is very large (which I'm not certain whether it can be and am not + * intellectually up to proving it this morning) adding the carry might + * overflow `__int128_t`. Edge-case testing required. + */ + __int128_t rv = NAN; + + switch (op) { + case '*': + rv = ( av * bv ) + carry; + break; + case '+': + rv = av + bv + carry; + break; + } if ( MAX_INTEGER >= rv ) { - carry = 0; + carry = 0; } else { - // TODO: we're correctly detecting overflow, but not yet correctly - // handling it. - carry = rv >> 60; - debug_printf( DEBUG_ARITH, - L"add_integers: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); - rv = rv & MAX_INTEGER; + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. + carry = rv >> 60; + debug_printf( DEBUG_ARITH, + L"operate_on_integers: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); + rv &= MAX_INTEGER; } struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); if ( nilp( cursor ) ) { - cursor = tail; + cursor = tail; } else { - inc_ref( tail ); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object *c = &pointer2cell( cursor ); - c->payload.integer.more = tail; + inc_ref( tail ); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object *c = &pointer2cell( cursor ); + c->payload.integer.more = tail; + cursor = tail; } if ( nilp( result ) ) { - result = cursor; + result = cursor; } a = pointer2cell( a ).payload.integer.more; b = pointer2cell( b ).payload.integer.more; } } - debug_print( L"add_integers returning: ", DEBUG_ARITH ); + + debug_print( L"operate_on_integers returning:\n", DEBUG_ARITH ); debug_dump_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); return result; } +/** + * Return the sum of the integers pointed to by `a` and `b`. If either isn't + * an integer, will return nil. + */ +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ) { + + return operate_on_integers(a, b, '+'); +} + /** * Return the product of the integers pointed to by `a` and `b`. If either isn't * an integer, will return nil. */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { - struct cons_pointer result = NIL; - struct cons_pointer cursor = NIL; - __int128_t carry = 0; - - if ( integerp( a ) && integerp( b ) ) { - debug_print( L"multiply_integers: \n", DEBUG_ARITH ); - debug_dump_object( a, DEBUG_ARITH ); - debug_print( L" x \n", DEBUG_ARITH ); - debug_dump_object( b, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - __int128_t av = - ( __int128_t ) integerp( a ) ? pointer2cell( a ). - payload.integer.value : 1; - __int128_t bv = - ( __int128_t ) integerp( b ) ? pointer2cell( b ). - payload.integer.value : 1; - - /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and - * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry - * is very large (which I'm not certain whether it can be and am not - * intellectually up to proving it this morning) adding the carry might - * overflow `__int128_t`. Edge-case testing required. - */ - __int128_t rv = ( av * bv ) + carry; - - if ( MAX_INTEGER >= rv ) { - carry = 0; - } else { - // TODO: we're correctly detecting overflow, but not yet correctly - // handling it. - carry = rv >> 60; - debug_printf( DEBUG_ARITH, - L"multiply_integers: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); - rv &= MAX_INTEGER; - } - - struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - - if ( nilp( cursor ) ) { - cursor = tail; - } else { - inc_ref( tail ); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object *c = &pointer2cell( cursor ); - c->payload.integer.more = tail; - } - - if ( nilp( result ) ) { - result = cursor; - } - - a = pointer2cell( a ).payload.integer.more; - b = pointer2cell( b ).payload.integer.more; - } - } - - debug_print( L"multiply_integers returning:\n", DEBUG_ARITH ); - debug_dump_object( result, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - return result; + return operate_on_integers( a, b, '*'); } /** @@ -283,9 +248,9 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, accumulator ); do { debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %c\n:", + L"integer_to_string: digit is %ld, hexadecimal is %C\n:", accumulator % base, - hex_digits[accumulator % base] ); + btowc(hex_digits[accumulator % base] )); result = integer_to_string_add_digit( accumulator % base, digits++, diff --git a/src/init.c b/src/init.c index f446dc4..1edb586 100644 --- a/src/init.c +++ b/src/init.c @@ -138,6 +138,7 @@ int main( int argc, char *argv[] ) { bind_function( L"equal", &lisp_equal ); bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); + bind_function( L"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); bind_function( L"read", &lisp_read ); bind_function( L"repl", &lisp_repl ); diff --git a/src/memory/dump.c b/src/memory/dump.c index bd6587f..a5faa87 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -151,3 +151,4 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { break; } } + diff --git a/src/memory/dump.h b/src/memory/dump.h index e49f453..2293189 100644 --- a/src/memory/dump.h +++ b/src/memory/dump.h @@ -25,5 +25,4 @@ */ void dump_object( FILE * output, struct cons_pointer pointer ); - #endif diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 9ab797a..aba7a92 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -744,7 +744,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, frame->arg[0] : get_default_stream( true, env ); if ( readp( in_stream ) ) { - debug_print( L"lisp_print: setting input stream\n", DEBUG_IO ); + debug_print( L"lisp_read: setting input stream\n", DEBUG_IO ); debug_dump_object( in_stream, DEBUG_IO ); input = pointer2cell( in_stream ).payload.stream.stream; inc_ref( in_stream ); @@ -1124,3 +1124,31 @@ struct cons_pointer lisp_source( struct stack_frame *frame, return result; } + + +/** + * Print the internal representation of the object indicated by `frame->arg[0]` to the + * (optional, defaults to `stdout`) stream indicated by `frame->arg[1]`. + */ +struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering print\n", DEBUG_IO ); + struct cons_pointer result = frame->arg[0]; + FILE *output = stdout; + struct cons_pointer out_stream = writep( frame->arg[1] ) ? + frame->arg[1] : get_default_stream( false, env ); + + if ( writep( out_stream ) ) { + debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + inc_ref( out_stream ); + } + dump_object( output, frame->arg[0] ); + + if ( writep( out_stream ) ) { + dec_ref( out_stream ); + } + + return result; +} diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 7868c4b..7d7d395 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -201,3 +201,6 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); From 7f93b04b725eed8932920917e3836eb99385fb23 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 17 Jan 2019 17:04:14 +0000 Subject: [PATCH 027/101] Various refactorings around bignum arithmetic --- src/arith/integer.c | 26 ++++++-- src/arith/peano.c | 7 +- src/debug.c | 23 +++++++ src/debug.h | 1 + src/ops/lispops.c | 3 +- src/ops/read.c | 159 ++++++++++++++++++++++++-------------------- 6 files changed, 134 insertions(+), 85 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 779a112..a5e2271 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -36,7 +36,7 @@ /** * hexadecimal digits for printing numbers. */ -const wchar_t hex_digits[16] = L"0123456789ABCDEF"; +const char * hex_digits = "0123456789ABCDEF"; /* * Doctrine from here on in is that ALL integers are bignums, it's just @@ -133,13 +133,24 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, switch (op) { case '*': - rv = ( av * bv ) + carry; + rv = av * bv * ((carry == 0) ? 1 : carry); break; case '+': rv = av + bv + carry; break; } + debug_printf( DEBUG_ARITH, L"operate_on_integers: op = '%c'; av = ", op); + debug_print_128bit( av, DEBUG_ARITH); + debug_print( L"; bv = ", DEBUG_ARITH); + debug_print_128bit( bv, DEBUG_ARITH); + debug_print( L"; carry = ", DEBUG_ARITH); + debug_print_128bit( carry, DEBUG_ARITH); + debug_print( L"; rv = ", DEBUG_ARITH); + debug_print_128bit( rv, DEBUG_ARITH); + debug_print( L"\n", DEBUG_ARITH); + + if ( MAX_INTEGER >= rv ) { carry = 0; } else { @@ -206,7 +217,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer integer_to_string_add_digit( int digit, int digits, struct cons_pointer tail ) { digits++; - wint_t character = ( wint_t ) hex_digits[digit]; + wint_t character = btowc(hex_digits[digit]); return ( digits % 3 == 0 ) ? make_string( L',', make_string( character, tail ) ) : @@ -247,13 +258,14 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { + int offset = (int)(accumulator % base); debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %C\n:", - accumulator % base, - btowc(hex_digits[accumulator % base] )); + L"integer_to_string: digit is %ld, hexadecimal is %c\n:", + offset, + hex_digits[offset] ); result = - integer_to_string_add_digit( accumulator % base, digits++, + integer_to_string_add_digit( offset, digits++, result ); accumulator = accumulator / base; } while ( accumulator > base ); diff --git a/src/arith/peano.c b/src/arith/peano.c index 481f33e..1dded80 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -41,7 +41,8 @@ bool zerop( struct cons_pointer arg ) { switch ( cell.tag.value ) { case INTEGERTV: - result = cell.payload.integer.value == 0; + result = cell.payload.integer.value == 0 && + nilp(cell.payload.integer.more); break; case RATIOTV: result = zerop( cell.payload.ratio.dividend ); @@ -134,9 +135,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_space_object cell2 = pointer2cell( arg2 ); debug_print( L"add_2( arg1 = ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); + debug_dump_object( arg1, DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); + debug_dump_object( arg2, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { diff --git a/src/debug.c b/src/debug.c index eba31e8..392aa71 100644 --- a/src/debug.c +++ b/src/debug.c @@ -42,6 +42,29 @@ void debug_print( wchar_t *message, int level ) { #endif } +/** + * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc + */ +void debug_print_128bit( __int128_t n, int level ) { + #ifdef DEBUG + if ( level & verbosity ) { + if (n == 0) { + fwprintf(stderr, L"0"); + } else { + char str[40] = {0}; // log10(1 << 128) + '\0' + char *s = str + sizeof(str) - 1; // start at the end + while (n != 0) { + if (s == str) return; // never happens + + *--s = "0123456789"[n % 10]; // save last digit + n /= 10; // drop it + } + fwprintf(stderr, L"%s", s); + } + } + #endif +} + /** * print a line feed to stderr, if `verbosity` matches `level`. * `verbosity is a set of flags, see debug_print.h; so you can diff --git a/src/debug.h b/src/debug.h index 72fa020..f961d6e 100644 --- a/src/debug.h +++ b/src/debug.h @@ -26,6 +26,7 @@ extern int verbosity; void debug_print( wchar_t *message, int level ); +void debug_print_128bit( __int128_t n, int level ); void debug_println( int level ); void debug_printf( int level, wchar_t *format, ... ); void debug_print_object( struct cons_pointer pointer, int level ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index aba7a92..298ae1a 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1133,7 +1133,6 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { debug_print( L"Entering print\n", DEBUG_IO ); - struct cons_pointer result = frame->arg[0]; FILE *output = stdout; struct cons_pointer out_stream = writep( frame->arg[1] ) ? frame->arg[1] : get_default_stream( false, env ); @@ -1150,5 +1149,5 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer dec_ref( out_stream ); } - return result; + return frame->arg[0]; } diff --git a/src/ops/read.c b/src/ops/read.c index 9074652..4f866d6 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -157,91 +157,104 @@ struct cons_pointer read_continuation( struct stack_frame *frame, * garbage is collected. */ struct cons_pointer read_number( struct stack_frame *frame, - struct cons_pointer frame_pointer, - FILE * input, - wint_t initial, bool seen_period ) { - debug_print( L"entering read_number\n", DEBUG_IO ); + struct cons_pointer frame_pointer, + FILE * input, + wint_t initial, bool seen_period ) { + debug_print( L"entering read_number\n", DEBUG_IO ); - struct cons_pointer result = make_integer( 0, NIL ); - /* TODO: we really need to be getting `base` from a privileged Lisp name - + struct cons_pointer result = make_integer( 0, NIL ); + /* TODO: we really need to be getting `base` from a privileged Lisp name - * and it should be the same privileged name we use when writing numbers */ - struct cons_pointer base = make_integer( 10, NIL ); - struct cons_pointer dividend = NIL; - int places_of_decimals = 0; - wint_t c; - bool neg = initial == btowc( '-' ); + struct cons_pointer base = make_integer( 10, NIL ); + struct cons_pointer dividend = NIL; + int places_of_decimals = 0; + wint_t c; + bool neg = initial == btowc( '-' ); - if ( neg ) { - initial = fgetwc( input ); + if ( neg ) { + initial = fgetwc( input ); + } + + debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, + initial ); + + for ( c = initial; iswdigit( c ) + || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { + switch (c) { + case L'.': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: too many periods" ), + frame_pointer ); + } else { + debug_print(L"read_number: decimal point seen\n", DEBUG_IO); + seen_period = true; + } + break; + case L'/': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: dividend of rational must be integer" ), + frame_pointer ); + } else { + debug_print(L"read_number: ratio slash seen\n", DEBUG_IO); + dividend = result; + + result = make_integer( 0, NIL ); + } + break; + case L',' : + // silently ignore it. + break; + default: + result = add_integers( multiply_integers( result, base ), + make_integer( ( int ) c - ( int ) '0', + NIL ) ); + + debug_printf( DEBUG_IO, + L"read_number: added character %c, result now ", c ); + debug_print_object( result, DEBUG_IO); + debug_print( L"\n", DEBUG_IO); + + if ( seen_period ) { + places_of_decimals++; + } } + } - debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, - initial ); - - for ( c = initial; iswdigit( c ) - || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { - if ( c == btowc( '.' ) ) { - if ( seen_period || !nilp( dividend ) ) { - 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 || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_string - ( L"Malformed number: dividend of rational must be integer" ), - frame_pointer ); - } else { - dividend = result; - - result = make_integer( 0, NIL ); - } - } else if ( c == L',' ) { - // silently ignore it. - } else { - result = add_integers( multiply_integers( result, base ), - make_integer( ( int ) c - ( int ) '0', - NIL ) ); - - debug_printf( DEBUG_IO, - L"Added character %c, result now %ld\n", c, result ); - - if ( seen_period ) { - places_of_decimals++; - } - } - } - - /* + /* * push back the character read which was not a digit */ - ungetwc( c, input ); - if ( seen_period ) { - struct cons_pointer div = make_ratio( frame_pointer, result, - make_integer( powl - ( to_long_double - ( base ), - places_of_decimals ), - NIL ) ); - inc_ref( div ); + ungetwc( c, input ); - result = make_real( to_long_double( div ) ); + if ( seen_period ) { + debug_print(L"read_number: converting result to real\n", DEBUG_IO); + struct cons_pointer div = make_ratio( frame_pointer, result, + make_integer( powl + ( to_long_double + ( base ), + places_of_decimals ), + NIL ) ); + inc_ref( div ); - dec_ref( div ); - } else if ( integerp( dividend ) ) { - result = make_ratio( frame_pointer, dividend, result ); - } + result = make_real( to_long_double( div ) ); - if ( neg ) { - result = negative( frame_pointer, result ); - } + dec_ref( div ); + } else if ( integerp( dividend ) ) { + debug_print(L"read_number: converting result to ratio\n", DEBUG_IO); + result = make_ratio( frame_pointer, dividend, result ); + } - debug_print( L"read_number returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); + if ( neg ) { + debug_print(L"read_number: converting result to negative\n", DEBUG_IO); - return result; + result = negative( frame_pointer, result ); + } + + debug_print( L"read_number returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + return result; } /** From c209abb4f93b9d75a10d21cae6e1653ad89e1e46 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 18 Jan 2019 13:39:12 +0000 Subject: [PATCH 028/101] Added unit tests to establish that bignum addition and print work the bug must be in multiplication. --- src/debug.h | 14 ++-- src/memory/dump.c | 2 +- unit-tests/bignum-add.sh | 155 +++++++++++++++++++++++++++++++++++++ unit-tests/bignum-expt.sh | 135 ++++++++++++++++++++++++++++++++ unit-tests/bignum-print.sh | 57 ++++++++++++++ 5 files changed, 355 insertions(+), 8 deletions(-) create mode 100644 unit-tests/bignum-add.sh create mode 100644 unit-tests/bignum-expt.sh create mode 100644 unit-tests/bignum-print.sh diff --git a/src/debug.h b/src/debug.h index f961d6e..babbaea 100644 --- a/src/debug.h +++ b/src/debug.h @@ -14,14 +14,14 @@ #define __debug_print_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_ARITH 2 +#define DEBUG_BIND 4 +#define DEBUG_BOOTSTRAP 8 +#define DEBUG_EVAL 16 +#define DEBUG_IO 32 +#define DEBUG_LAMBDA 64 #define DEBUG_REPL 128 -#define DEBUG_BIND 256 +#define DEBUG_STACK 256 extern int verbosity; diff --git a/src/memory/dump.c b/src/memory/dump.c index a5faa87..fc9175d 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -84,7 +84,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { L"\t\tInteger cell: value %ld, count %u\n", cell.payload.integer.value, cell.count ); if ( !nilp( cell.payload.integer.more ) ) { - fputws( L"\t\tBIGNUM! More at\n:", output ); + fputws( L"\t\tBIGNUM! More at:\n", output ); dump_object( output, cell.payload.integer.more ); } break; diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh new file mode 100644 index 0000000..678b766 --- /dev/null +++ b/unit-tests/bignum-add.sh @@ -0,0 +1,155 @@ +#!/bin/bash + +##################################################################### +# add two large numbers, not actally bignums to produce a smallnum +# (right on the boundary) +a=1152921504606846975 +b=1 +expected='1152921504606846976' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add two numbers, not actally bignums to produce a bignum +# (just over the boundary) +a='1152921504606846976' +b=1 +expected='1152921504606846977' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add a bignum and a smallnum to produce a bignum +# (just over the boundary) +a='1152921504606846977' +b=1 +expected='1152921504606846978' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add a smallnum and a bignum to produce a bignum +# (just over the boundary) +a=1 +b=1152921504606846977 +expected='1152921504606846978' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add two bignums to produce a bignum +a=10000000000000000000 +b=10000000000000000000 +expected='20000000000000000000' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi diff --git a/unit-tests/bignum-expt.sh b/unit-tests/bignum-expt.sh new file mode 100644 index 0000000..ab9cb24 --- /dev/null +++ b/unit-tests/bignum-expt.sh @@ -0,0 +1,135 @@ +#!/bin/bash + +##################################################################### +# last 'smallnum' value: +# sbcl calculates (expt 2 59) => 576460752303423488 +expected='576460752303423488' + +output=`target/psse < 1152921504606846976 +expected='1152921504606846976' + +output=`target/psse < 2305843009213693952 +expected='2305843009213693952' + +output=`target/psse < 18446744073709551616 +expected='18446744073709551616' + +output=`target/psse < 36893488147419103232 +expected='36893488147419103232' + +output=`target/psse < Date: Fri, 18 Jan 2019 13:57:41 +0000 Subject: [PATCH 029/101] Bignum subtraction does NOT work Also subtraction of large numbers which are not beyond the bignum barrier does not work. --- unit-tests/bignum-subtract.sh | 116 ++++++++++++++++++++++++++++++++++ 1 file changed, 116 insertions(+) create mode 100644 unit-tests/bignum-subtract.sh diff --git a/unit-tests/bignum-subtract.sh b/unit-tests/bignum-subtract.sh new file mode 100644 index 0000000..9342913 --- /dev/null +++ b/unit-tests/bignum-subtract.sh @@ -0,0 +1,116 @@ +#!/bin/bash + +##################################################################### +# subtract a smallnum from a smallnum to produce a smallnum +# (right on the boundary) +a=1152921504606846976 +b=1 +expected='1152921504606846975' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# subtract a smallnum from a bignum to produce a smallnum +# (just over the boundary) +a='1152921504606846977' +b=1 +expected='1152921504606846976' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# subtract a smallnum from a bignum to produce a smallnum +a='1152921504606846978' +b=1 +expected='1152921504606846977' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# subtract a bignum from a smallnum to produce a negstive smallnum +# (just over the boundary) +a=1 +b=1152921504606846977 +expected='-1152921504606846976' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# subtract a bignum from a bignum to produce a bignum +a=20000000000000000000 +b=10000000000000000000 +expected=10000000000000000000 +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + From d8991e8823dec702a5da41938fc47ba453a75c9c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 18 Jan 2019 14:09:26 +0000 Subject: [PATCH 030/101] H'mmm. But although two-cell bignums work, n-cell do not. Both add and print fail with numbers larger than 2^120 --- unit-tests/bignum-add.sh | 33 +++++++++++++++++++++++++++++++++ unit-tests/bignum-print.sh | 2 +- 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh index 678b766..a4244ee 100644 --- a/unit-tests/bignum-add.sh +++ b/unit-tests/bignum-add.sh @@ -153,3 +153,36 @@ else echo "Fail" exit 1 fi + +##################################################################### +# add a smallnum and a two-cell bignum to produce a three-cell bignum +# (just over the boundary) +a=1 +b=1329227995784915872903807060280344576 +expected='1329227995784915872903807060280344577' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +1329227995784915872903807060280344576 diff --git a/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh index c030f37..69d2d24 100644 --- a/unit-tests/bignum-print.sh +++ b/unit-tests/bignum-print.sh @@ -38,7 +38,7 @@ fi ##################################################################### # definitely a bignum -expected='2305843009213693952' +expected='1329227995784915872903807060280344577' output=`echo "(progn (print $expected) nil)" | target/psse` actual=`echo $output |\ From b433171fb643723a18b415605a84537aa990f8c8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 18 Jan 2019 14:25:32 +0000 Subject: [PATCH 031/101] Problem is that reading bignums depends on multiplying bignums... Which doesn't work for the second digit into bignum territory - so it's fine at the boundary... --- unit-tests/bignum-add.sh | 1 - unit-tests/bignum-print.sh | 81 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 77 insertions(+), 5 deletions(-) diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh index a4244ee..280eca9 100644 --- a/unit-tests/bignum-add.sh +++ b/unit-tests/bignum-add.sh @@ -185,4 +185,3 @@ else exit 1 fi -1329227995784915872903807060280344576 diff --git a/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh index 69d2d24..5615871 100644 --- a/unit-tests/bignum-print.sh +++ b/unit-tests/bignum-print.sh @@ -3,7 +3,7 @@ ##################################################################### # large number, not actally a bignum expected='576460752303423488' -output=`echo "(progn (print $expected) nil)" | target/psse` +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ sed 's/\,//g' |\ @@ -18,10 +18,22 @@ else exit 1 fi +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + + ##################################################################### # right on the boundary expected='1152921504606846976' -output=`echo "(progn (print $expected) nil)" | target/psse` +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ sed 's/\,//g' |\ @@ -36,10 +48,71 @@ else exit 1 fi +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + + ##################################################################### # definitely a bignum -expected='1329227995784915872903807060280344577' -output=`echo "(progn (print $expected) nil)" | target/psse` +expected='1152921504606846977' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# Just on the three cell boundary +expected='1329227995784915872903807060280344576' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +exit 0 + +##################################################################### +# definitely a three cell bignum +expected='1329227995784915872903807060280344577' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ sed 's/\,//g' |\ From 46a41328235403602a4a41b2f41550b5759dc96e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 18 Jan 2019 20:55:03 +0000 Subject: [PATCH 032/101] Made it easier to run individual unit tests --- src/arith/integer.c | 4 ++++ unit-tests/add.sh | 0 unit-tests/apply.sh | 0 unit-tests/bignum-add.sh | 0 unit-tests/bignum-expt.sh | 0 unit-tests/bignum-print.sh | 0 unit-tests/bignum-subtract.sh | 0 unit-tests/bignum.sh | 0 unit-tests/complex-list.sh | 0 unit-tests/cond.sh | 0 unit-tests/empty-list.sh | 0 unit-tests/empty-string.sh | 0 unit-tests/eval-integer.sh | 0 unit-tests/eval-quote-sexpr.sh | 0 unit-tests/eval-quote-symbol.sh | 0 unit-tests/eval-real.sh | 0 unit-tests/eval-string.sh | 0 unit-tests/fred.sh | 0 unit-tests/integer-allocation.sh | 0 unit-tests/integer.sh | 0 unit-tests/intepreter.sh | 0 unit-tests/lambda.sh | 0 unit-tests/many-args.sh | 0 unit-tests/multiply.sh | 0 unit-tests/nil.sh | 0 unit-tests/nlambda.sh | 0 unit-tests/progn.sh | 0 unit-tests/quote.sh | 0 unit-tests/quoted-list.sh | 0 unit-tests/ratio-addition.sh | 0 unit-tests/recursion.sh | 0 unit-tests/reverse.sh | 0 unit-tests/simple-list.sh | 0 unit-tests/string-allocation.sh | 0 unit-tests/string-with-spaces.sh | 0 unit-tests/varargs.sh | 0 36 files changed, 4 insertions(+) mode change 100644 => 100755 unit-tests/add.sh mode change 100644 => 100755 unit-tests/apply.sh mode change 100644 => 100755 unit-tests/bignum-add.sh mode change 100644 => 100755 unit-tests/bignum-expt.sh mode change 100644 => 100755 unit-tests/bignum-print.sh mode change 100644 => 100755 unit-tests/bignum-subtract.sh mode change 100644 => 100755 unit-tests/bignum.sh mode change 100644 => 100755 unit-tests/complex-list.sh mode change 100644 => 100755 unit-tests/cond.sh mode change 100644 => 100755 unit-tests/empty-list.sh mode change 100644 => 100755 unit-tests/empty-string.sh mode change 100644 => 100755 unit-tests/eval-integer.sh mode change 100644 => 100755 unit-tests/eval-quote-sexpr.sh mode change 100644 => 100755 unit-tests/eval-quote-symbol.sh mode change 100644 => 100755 unit-tests/eval-real.sh mode change 100644 => 100755 unit-tests/eval-string.sh mode change 100644 => 100755 unit-tests/fred.sh mode change 100644 => 100755 unit-tests/integer-allocation.sh mode change 100644 => 100755 unit-tests/integer.sh mode change 100644 => 100755 unit-tests/intepreter.sh mode change 100644 => 100755 unit-tests/lambda.sh mode change 100644 => 100755 unit-tests/many-args.sh mode change 100644 => 100755 unit-tests/multiply.sh mode change 100644 => 100755 unit-tests/nil.sh mode change 100644 => 100755 unit-tests/nlambda.sh mode change 100644 => 100755 unit-tests/progn.sh mode change 100644 => 100755 unit-tests/quote.sh mode change 100644 => 100755 unit-tests/quoted-list.sh mode change 100644 => 100755 unit-tests/ratio-addition.sh mode change 100644 => 100755 unit-tests/recursion.sh mode change 100644 => 100755 unit-tests/reverse.sh mode change 100644 => 100755 unit-tests/simple-list.sh mode change 100644 => 100755 unit-tests/string-allocation.sh mode change 100644 => 100755 unit-tests/string-with-spaces.sh mode change 100644 => 100755 unit-tests/varargs.sh diff --git a/src/arith/integer.c b/src/arith/integer.c index a5e2271..1fb22f1 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -101,6 +101,10 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { * integer arguments `a` and `b`, and return a pointer to the result. If * either `a` or `b` is not an integer, returns `NIL`. */ +/* TODO: there is a significant bug here, which manifests in multiply but + * may not manifest in add. The value in the least significant cell ends + * up significantly WRONG, but the value in the more significant cell + * ends up correct. */ struct cons_pointer operate_on_integers( struct cons_pointer a, struct cons_pointer b, char op) { diff --git a/unit-tests/add.sh b/unit-tests/add.sh old mode 100644 new mode 100755 diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum-expt.sh b/unit-tests/bignum-expt.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum-subtract.sh b/unit-tests/bignum-subtract.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum.sh b/unit-tests/bignum.sh old mode 100644 new mode 100755 diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh old mode 100644 new mode 100755 diff --git a/unit-tests/cond.sh b/unit-tests/cond.sh old mode 100644 new mode 100755 diff --git a/unit-tests/empty-list.sh b/unit-tests/empty-list.sh old mode 100644 new mode 100755 diff --git a/unit-tests/empty-string.sh b/unit-tests/empty-string.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-integer.sh b/unit-tests/eval-integer.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-quote-sexpr.sh b/unit-tests/eval-quote-sexpr.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-real.sh b/unit-tests/eval-real.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-string.sh b/unit-tests/eval-string.sh old mode 100644 new mode 100755 diff --git a/unit-tests/fred.sh b/unit-tests/fred.sh old mode 100644 new mode 100755 diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh old mode 100644 new mode 100755 diff --git a/unit-tests/integer.sh b/unit-tests/integer.sh old mode 100644 new mode 100755 diff --git a/unit-tests/intepreter.sh b/unit-tests/intepreter.sh old mode 100644 new mode 100755 diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh old mode 100644 new mode 100755 diff --git a/unit-tests/many-args.sh b/unit-tests/many-args.sh old mode 100644 new mode 100755 diff --git a/unit-tests/multiply.sh b/unit-tests/multiply.sh old mode 100644 new mode 100755 diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh old mode 100644 new mode 100755 diff --git a/unit-tests/nlambda.sh b/unit-tests/nlambda.sh old mode 100644 new mode 100755 diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh old mode 100644 new mode 100755 diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh old mode 100644 new mode 100755 diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh old mode 100644 new mode 100755 diff --git a/unit-tests/ratio-addition.sh b/unit-tests/ratio-addition.sh old mode 100644 new mode 100755 diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh old mode 100644 new mode 100755 diff --git a/unit-tests/reverse.sh b/unit-tests/reverse.sh old mode 100644 new mode 100755 diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh old mode 100644 new mode 100755 diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh old mode 100644 new mode 100755 diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh old mode 100644 new mode 100755 diff --git a/unit-tests/varargs.sh b/unit-tests/varargs.sh old mode 100644 new mode 100755 From 000ae3c392a237eeff60a72156f5248866c05b96 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 19 Jan 2019 10:55:24 +0000 Subject: [PATCH 033/101] Not really a unit test, just trying to find where the problem is --- unit-tests/where-does-it-break.sh | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100755 unit-tests/where-does-it-break.sh diff --git a/unit-tests/where-does-it-break.sh b/unit-tests/where-does-it-break.sh new file mode 100755 index 0000000..5c51aca --- /dev/null +++ b/unit-tests/where-does-it-break.sh @@ -0,0 +1,29 @@ +#!/bin/bash + +# Not really a unit test, but a check to see where bignum addition breaks + +broken=0 +i=1152921506900200000 +# we've already proven we can successfullu get up to here +increment=10000 + +while [ $broken -eq "0" ] +do + expr="(+ $i $increment)" + # Use sbcl as our reference implementation... + expected=`echo "$expr" | sbcl --noinform | grep -v '*'` + actual=`echo "$expr" | target/psse | tail -1 | sed 's/\,//g'` + + echo -n "adding $increment to $i: " + + if [ "${expected}" = "${actual}" ] + then + echo "OK" + else + echo "Fail: expected '${expected}', got '${actual}'" + broken=1 + exit 1 + fi + + i=$expected +done From 0f8bc990f24b9f7a8f6881d5f0b863c08a9afe1e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 19 Jan 2019 16:24:59 +0000 Subject: [PATCH 034/101] Much investigation of bignum problems bignum multiply is still not working, but as bignum read and bignum divide depend on it, it's the problem to hit first. --- lisp/expt.lisp | 2 +- lisp/scratchpad.lisp | 48 +++++ lisp/scratchpad2.lisp | 84 +++++++++ src/arith/integer.c | 133 ++++++++------ src/arith/peano.c | 2 +- src/debug.c | 31 ++-- src/ops/read.c | 172 +++++++++--------- unit-tests/bignum-add.sh | 69 +++++-- ...does-it-break.sh => where-does-it-break.sh | 4 +- 9 files changed, 372 insertions(+), 173 deletions(-) create mode 100644 lisp/scratchpad.lisp create mode 100644 lisp/scratchpad2.lisp rename unit-tests/where-does-it-break.sh => where-does-it-break.sh (94%) diff --git a/lisp/expt.lisp b/lisp/expt.lisp index af1fff1..433b0ea 100644 --- a/lisp/expt.lisp +++ b/lisp/expt.lisp @@ -5,4 +5,4 @@ ((= x 1) n) (t (* n (expt n (- x 1))))))) -(expt 2 65) +(expt 2 60) diff --git a/lisp/scratchpad.lisp b/lisp/scratchpad.lisp new file mode 100644 index 0000000..494fe59 --- /dev/null +++ b/lisp/scratchpad.lisp @@ -0,0 +1,48 @@ +(set! i + (+ + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000)) + +(set! j (+ i i i i i i i i i i)) + +(set! k (+ j j j j j j j j j j)) + +(set! l (+ k k k k k k k k k k)) + +(set! m (+ l l l l l l l l l l)) + +(set! n (+ m m m m m m m m m m)) + +(set! o (+ n n n n n n n n n n)) + +(set! p (+ o o o o o o o o o o)) + +(set! q (+ p p p p p p p p p p)) + +(set! r (+ q q q q q q q q q q)) + +(set! s (+ r r r r r r r r r r)) + +(set! t (+ s s s s s s s s s s)) + +(set! u (+ t t t t t t t t t t)) + +(set! v (+ u u u u u u u u u u)) + +(set! x (+ v v v v v v v v v v)) + +(set! y (+ x x x x x x x x x x)) + +"we're OK to here: 10^36, which is below the 2^120 barrier so represented as two cells" +(inspect (set! z (+ y y y y y y y y y y))) + +"This blows up: 10^37, which is a three cell bignum." +(inspect (+ z z z z z z z z z z)) diff --git a/lisp/scratchpad2.lisp b/lisp/scratchpad2.lisp new file mode 100644 index 0000000..e608106 --- /dev/null +++ b/lisp/scratchpad2.lisp @@ -0,0 +1,84 @@ +"This demonstrates that although the print representation of three cell bignums blows up, the internal representation is sane" + +"We start by adding 8 copies of 2^60 - i.e. the first two-cell integer" + +(set! a + (+ + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976)) + +"Then repeatedly add eight copies of the previous generation" + +(set! b (+ a a a a a a a a)) + +(set! c (+ b b b b b b b b)) + +(set! d (+ c c c c c c c c)) + +(set! e (+ d d d d d d d d)) + +(set! f (+ e e e e e e e e)) + +(set! g (+ f f f f f f f f)) + +(set! h (+ g g g g g g g g)) + +(set! i (+ h h h h h h h h)) + +(set! j (+ i i i i i i i i)) + +(set! k (+ j j j j j j j j)) + +(set! l (+ k k k k k k k k)) + +(set! m (+ l l l l l l l l)) + +(set! n (+ m m m m m m m m)) + +(set! o (+ n n n n n n n n)) + +"p" +(set! p (+ o o o o o o o o)) + +"q" +(set! q (+ p p p p p p p p)) + +"r" +(set! r (+ q q q q q q q q)) + +"s" +(inspect + (set! s (+ r r r r r r r r))) + +"t - first three cell integer. Printing blows up here" +(inspect + (set! t (+ s s s s s s s s))) + +"u" +(inspect + (set! u (+ t t t t t t t t))) + +"v" +(inspect + (set! v (+ u u u u u u u u))) + +"w" +(inspect + (set! w (+ v v v v v v v v))) + +(inspect + (set! x (+ w w w w w w w w))) + +(inspect + (set! y (+ x x x x x x x x))) + +(inspect + (set! z (+ y y y y y y y y))) + +(inspect (+ z z z z z z z z)) diff --git a/src/arith/integer.c b/src/arith/integer.c index 1fb22f1..b5ed859 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -36,7 +36,7 @@ /** * hexadecimal digits for printing numbers. */ -const char * hex_digits = "0123456789ABCDEF"; +const char *hex_digits = "0123456789ABCDEF"; /* * Doctrine from here on in is that ALL integers are bignums, it's just @@ -95,6 +95,21 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { } +__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { + long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; + long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 ); + + __int128_t result = ( __int128_t ) integerp( c ) ? + ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; + debug_printf( DEBUG_ARITH, + L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; returning ", + val, op, is_first_cell ? "true" : "false" ); + debug_print_128bit( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; +} + /** * internal workings of both `add_integers` and `multiply_integers` (and * possibly, later, other operations. Apply the operator `op` to the @@ -106,26 +121,22 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { * up significantly WRONG, but the value in the more significant cell * ends up correct. */ struct cons_pointer operate_on_integers( struct cons_pointer a, - struct cons_pointer b, - char op) { + struct cons_pointer b, char op ) { struct cons_pointer result = NIL; struct cons_pointer cursor = NIL; __int128_t carry = 0; + bool is_first_cell = true; if ( integerp( a ) && integerp( b ) ) { debug_print( L"operate_on_integers: \n", DEBUG_ARITH ); debug_dump_object( a, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L" %c \n", op); + debug_printf( DEBUG_ARITH, L" %c \n", op ); debug_dump_object( b, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - __int128_t av = - ( __int128_t ) integerp( a ) ? pointer2cell( a ). - payload.integer.value : op == '*' ? 1 : 0; - __int128_t bv = - ( __int128_t ) integerp( b ) ? pointer2cell( b ). - payload.integer.value : op == '*' ? 1 : 0; + __int128_t av = cell_value( a, op, is_first_cell ); + __int128_t bv = cell_value( b, op, is_first_cell ); /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry @@ -135,57 +146,59 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, */ __int128_t rv = NAN; - switch (op) { - case '*': - rv = av * bv * ((carry == 0) ? 1 : carry); - break; - case '+': - rv = av + bv + carry; - break; - } + switch ( op ) { + case '*': + rv = av * bv * ( ( carry == 0 ) ? 1 : carry ); + break; + case '+': + rv = av + bv + carry; + break; + } - debug_printf( DEBUG_ARITH, L"operate_on_integers: op = '%c'; av = ", op); - debug_print_128bit( av, DEBUG_ARITH); - debug_print( L"; bv = ", DEBUG_ARITH); - debug_print_128bit( bv, DEBUG_ARITH); - debug_print( L"; carry = ", DEBUG_ARITH); - debug_print_128bit( carry, DEBUG_ARITH); - debug_print( L"; rv = ", DEBUG_ARITH); - debug_print_128bit( rv, DEBUG_ARITH); - debug_print( L"\n", DEBUG_ARITH); + debug_printf( DEBUG_ARITH, + L"operate_on_integers: op = '%c'; av = ", op ); + debug_print_128bit( av, DEBUG_ARITH ); + debug_print( L"; bv = ", DEBUG_ARITH ); + debug_print_128bit( bv, DEBUG_ARITH ); + debug_print( L"; carry = ", DEBUG_ARITH ); + debug_print_128bit( carry, DEBUG_ARITH ); + debug_print( L"; rv = ", DEBUG_ARITH ); + debug_print_128bit( rv, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); if ( MAX_INTEGER >= rv ) { - carry = 0; + carry = 0; } else { - // TODO: we're correctly detecting overflow, but not yet correctly - // handling it. - carry = rv >> 60; - debug_printf( DEBUG_ARITH, - L"operate_on_integers: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); - rv &= MAX_INTEGER; + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. + carry = rv >> 60; + debug_printf( DEBUG_ARITH, + L"operate_on_integers: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); + rv &= MAX_INTEGER; } struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); if ( nilp( cursor ) ) { - cursor = tail; + cursor = tail; } else { - inc_ref( tail ); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object *c = &pointer2cell( cursor ); - c->payload.integer.more = tail; - cursor = tail; + inc_ref( tail ); + /* yes, this is a destructive change - but the integer has not yet been released + * into the wild */ + struct cons_space_object *c = &pointer2cell( cursor ); + c->payload.integer.more = tail; + cursor = tail; } if ( nilp( result ) ) { - result = cursor; + result = cursor; } a = pointer2cell( a ).payload.integer.more; b = pointer2cell( b ).payload.integer.more; + is_first_cell = false; } } @@ -203,7 +216,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b ) { - return operate_on_integers(a, b, '+'); + return operate_on_integers( a, b, '+' ); } /** @@ -212,7 +225,7 @@ struct cons_pointer add_integers( struct cons_pointer a, */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { - return operate_on_integers( a, b, '*'); + return operate_on_integers( a, b, '*' ); } /** @@ -221,7 +234,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer integer_to_string_add_digit( int digit, int digits, struct cons_pointer tail ) { digits++; - wint_t character = btowc(hex_digits[digit]); + wint_t character = btowc( hex_digits[digit] ); return ( digits % 3 == 0 ) ? make_string( L',', make_string( character, tail ) ) : @@ -239,6 +252,11 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, * when we get to the last digit from one integer cell, we have potentially * to be looking to the next. H'mmmm. */ +/* + * TODO: this blows up when printing three-cell integers, but works fine + * for two-cell. What's happening is that when we cross the barrier we + * SHOULD print 2^120, but what we actually print is 2^117. H'mmm. + */ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int base ) { struct cons_pointer result = NIL; @@ -253,24 +271,27 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { if ( !nilp( integer.payload.integer.more ) ) { integer = pointer2cell( integer.payload.integer.more ); - accumulator += + accumulator += integer.payload.integer.value == 0 ? + MAX_INTEGER : ( llabs( integer.payload.integer.value ) * ( MAX_INTEGER + 1 ) ); + debug_print + ( L"integer_to_string: crossing cell boundary, accumulator is: ", + DEBUG_IO ); + debug_print_128bit( accumulator, DEBUG_IO ); + debug_println( DEBUG_IO ); } - debug_printf( DEBUG_IO, - L"integer_to_string: accumulator is %ld\n:", - accumulator ); do { - int offset = (int)(accumulator % base); + int offset = ( int ) ( accumulator % base ); debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %c\n:", - offset, - hex_digits[offset] ); + L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", + offset, hex_digits[offset] ); + debug_print_128bit( accumulator, DEBUG_IO ); + debug_println( DEBUG_IO ); result = - integer_to_string_add_digit( offset, digits++, - result ); + integer_to_string_add_digit( offset, digits++, result ); accumulator = accumulator / base; } while ( accumulator > base ); } diff --git a/src/arith/peano.c b/src/arith/peano.c index 1dded80..0dc2ed0 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -42,7 +42,7 @@ bool zerop( struct cons_pointer arg ) { switch ( cell.tag.value ) { case INTEGERTV: result = cell.payload.integer.value == 0 && - nilp(cell.payload.integer.more); + nilp( cell.payload.integer.more ); break; case RATIOTV: result = zerop( cell.payload.ratio.dividend ); diff --git a/src/debug.c b/src/debug.c index 392aa71..d694827 100644 --- a/src/debug.c +++ b/src/debug.c @@ -46,23 +46,24 @@ void debug_print( wchar_t *message, int level ) { * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc */ void debug_print_128bit( __int128_t n, int level ) { - #ifdef DEBUG - if ( level & verbosity ) { - if (n == 0) { - fwprintf(stderr, L"0"); - } else { - char str[40] = {0}; // log10(1 << 128) + '\0' - char *s = str + sizeof(str) - 1; // start at the end - while (n != 0) { - if (s == str) return; // never happens +#ifdef DEBUG + if ( level & verbosity ) { + if ( n == 0 ) { + fwprintf( stderr, L"0" ); + } else { + char str[40] = { 0 }; // log10(1 << 128) + '\0' + char *s = str + sizeof( str ) - 1; // start at the end + while ( n != 0 ) { + if ( s == str ) + return; // never happens - *--s = "0123456789"[n % 10]; // save last digit - n /= 10; // drop it - } - fwprintf(stderr, L"%s", s); + *--s = "0123456789"[n % 10]; // save last digit + n /= 10; // drop it + } + fwprintf( stderr, L"%s", s ); + } } - } - #endif +#endif } /** diff --git a/src/ops/read.c b/src/ops/read.c index 4f866d6..6e2a07f 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -157,104 +157,108 @@ struct cons_pointer read_continuation( struct stack_frame *frame, * garbage is collected. */ struct cons_pointer read_number( struct stack_frame *frame, - struct cons_pointer frame_pointer, - FILE * input, - wint_t initial, bool seen_period ) { - debug_print( L"entering read_number\n", DEBUG_IO ); + struct cons_pointer frame_pointer, + FILE * input, + wint_t initial, bool seen_period ) { + debug_print( L"entering read_number\n", DEBUG_IO ); - struct cons_pointer result = make_integer( 0, NIL ); - /* TODO: we really need to be getting `base` from a privileged Lisp name - + struct cons_pointer result = make_integer( 0, NIL ); + /* TODO: we really need to be getting `base` from a privileged Lisp name - * and it should be the same privileged name we use when writing numbers */ - struct cons_pointer base = make_integer( 10, NIL ); - struct cons_pointer dividend = NIL; - int places_of_decimals = 0; - wint_t c; - bool neg = initial == btowc( '-' ); + struct cons_pointer base = make_integer( 10, NIL ); + struct cons_pointer dividend = NIL; + int places_of_decimals = 0; + wint_t c; + bool neg = initial == btowc( '-' ); - if ( neg ) { - initial = fgetwc( input ); - } - - debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, - initial ); - - for ( c = initial; iswdigit( c ) - || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { - switch (c) { - case L'.': - if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_string - ( L"Malformed number: too many periods" ), - frame_pointer ); - } else { - debug_print(L"read_number: decimal point seen\n", DEBUG_IO); - seen_period = true; - } - break; - case L'/': - if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_string - ( L"Malformed number: dividend of rational must be integer" ), - frame_pointer ); - } else { - debug_print(L"read_number: ratio slash seen\n", DEBUG_IO); - dividend = result; - - result = make_integer( 0, NIL ); - } - break; - case L',' : - // silently ignore it. - break; - default: - result = add_integers( multiply_integers( result, base ), - make_integer( ( int ) c - ( int ) '0', - NIL ) ); - - debug_printf( DEBUG_IO, - L"read_number: added character %c, result now ", c ); - debug_print_object( result, DEBUG_IO); - debug_print( L"\n", DEBUG_IO); - - if ( seen_period ) { - places_of_decimals++; - } + if ( neg ) { + initial = fgetwc( input ); } - } - /* + debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, + initial ); + + for ( c = initial; iswdigit( c ) + || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { + switch ( c ) { + case L'.': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: too many periods" ), + frame_pointer ); + } else { + debug_print( L"read_number: decimal point seen\n", + DEBUG_IO ); + seen_period = true; + } + break; + case L'/': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: dividend of rational must be integer" ), + frame_pointer ); + } else { + debug_print( L"read_number: ratio slash seen\n", + DEBUG_IO ); + dividend = result; + + result = make_integer( 0, NIL ); + } + break; + case L',': + // silently ignore it. + break; + default: + result = add_integers( multiply_integers( result, base ), + make_integer( ( int ) c - ( int ) '0', + NIL ) ); + + debug_printf( DEBUG_IO, + L"read_number: added character %c, result now ", + c ); + debug_print_object( result, DEBUG_IO ); + debug_print( L"\n", DEBUG_IO ); + + if ( seen_period ) { + places_of_decimals++; + } + } + } + + /* * push back the character read which was not a digit */ - ungetwc( c, input ); + ungetwc( c, input ); - if ( seen_period ) { - debug_print(L"read_number: converting result to real\n", DEBUG_IO); - struct cons_pointer div = make_ratio( frame_pointer, result, - make_integer( powl - ( to_long_double - ( base ), - places_of_decimals ), - NIL ) ); - inc_ref( div ); + if ( seen_period ) { + debug_print( L"read_number: converting result to real\n", DEBUG_IO ); + struct cons_pointer div = make_ratio( frame_pointer, result, + make_integer( powl + ( to_long_double + ( base ), + places_of_decimals ), + NIL ) ); + inc_ref( div ); - result = make_real( to_long_double( div ) ); + result = make_real( to_long_double( div ) ); - dec_ref( div ); - } else if ( integerp( dividend ) ) { - debug_print(L"read_number: converting result to ratio\n", DEBUG_IO); - result = make_ratio( frame_pointer, dividend, result ); - } + dec_ref( div ); + } else if ( integerp( dividend ) ) { + debug_print( L"read_number: converting result to ratio\n", DEBUG_IO ); + result = make_ratio( frame_pointer, dividend, result ); + } - if ( neg ) { - debug_print(L"read_number: converting result to negative\n", DEBUG_IO); + if ( neg ) { + debug_print( L"read_number: converting result to negative\n", + DEBUG_IO ); - result = negative( frame_pointer, result ); - } + result = negative( frame_pointer, result ); + } - debug_print( L"read_number returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); + debug_print( L"read_number returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); - return result; + return result; } /** diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh index 280eca9..7bbb41e 100755 --- a/unit-tests/bignum-add.sh +++ b/unit-tests/bignum-add.sh @@ -5,12 +5,12 @@ # (right on the boundary) a=1152921504606846975 b=1 -expected='1152921504606846976' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ - tail -1 |\ - sed 's/\,//g'` + tail -1` echo -n "adding $a to $b: " if [ "${expected}" = "${actual}" ] @@ -36,8 +36,9 @@ fi # (just over the boundary) a='1152921504606846976' b=1 -expected='1152921504606846977' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -62,13 +63,15 @@ else exit 1 fi + ##################################################################### # add a bignum and a smallnum to produce a bignum # (just over the boundary) a='1152921504606846977' b=1 -expected='1152921504606846978' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -98,8 +101,9 @@ fi # (just over the boundary) a=1 b=1152921504606846977 -expected='1152921504606846978' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -124,12 +128,14 @@ else exit 1 fi + ##################################################################### # add two bignums to produce a bignum a=10000000000000000000 b=10000000000000000000 -expected='20000000000000000000' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -154,13 +160,15 @@ else exit 1 fi + ##################################################################### # add a smallnum and a two-cell bignum to produce a three-cell bignum # (just over the boundary) a=1 b=1329227995784915872903807060280344576 -expected='1329227995784915872903807060280344577' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -185,3 +193,36 @@ else exit 1 fi + +##################################################################### +# This currently fails: +# (= (+ 1 3064991081731777716716694054300618367237478244367204352) +# 3064991081731777716716694054300618367237478244367204353) +a=1 +b=3064991081731777716716694054300618367237478244367204352 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi diff --git a/unit-tests/where-does-it-break.sh b/where-does-it-break.sh similarity index 94% rename from unit-tests/where-does-it-break.sh rename to where-does-it-break.sh index 5c51aca..4d70041 100755 --- a/unit-tests/where-does-it-break.sh +++ b/where-does-it-break.sh @@ -3,9 +3,9 @@ # Not really a unit test, but a check to see where bignum addition breaks broken=0 -i=1152921506900200000 +i=11529215046068469750 # we've already proven we can successfullu get up to here -increment=10000 +increment=1 while [ $broken -eq "0" ] do From 22fa7314d6b429aae7bb41d23bc7ca56ba0bc337 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 20 Jan 2019 19:44:56 +0000 Subject: [PATCH 035/101] Mostly fixing and standardising documentation. --- Doxyfile | 14 +- src/arith/integer.c | 43 +++-- src/arith/integer.h | 5 +- src/arith/peano.c | 46 +++-- src/arith/peano.h | 6 +- src/arith/ratio.c | 37 ++-- src/init.c | 22 ++- src/memory/conspage.c | 130 +++++++------ src/memory/conspage.h | 26 --- src/memory/consspaceobject.c | 26 ++- src/memory/consspaceobject.h | 359 ++++++++++++++++++++-------------- src/memory/dump.c | 1 - src/memory/dump.h | 5 +- src/memory/stack.c | 25 +-- src/memory/stack.h | 8 +- src/memory/vectorspace.c | 31 ++- src/memory/vectorspace.h | 46 +++-- src/ops/intern.c | 3 +- src/ops/intern.h | 29 +-- src/ops/lispops.c | 361 +++++++++++++++++++++++------------ src/ops/lispops.h | 5 +- src/ops/print.c | 12 +- src/ops/read.c | 8 +- unit-tests/string-cons.sh | 25 +++ 24 files changed, 770 insertions(+), 503 deletions(-) create mode 100644 unit-tests/string-cons.sh diff --git a/Doxyfile b/Doxyfile index 955cb32..e283f9a 100644 --- a/Doxyfile +++ b/Doxyfile @@ -135,7 +135,7 @@ ABBREVIATE_BRIEF = "The $name class" \ # description. # The default value is: NO. -ALWAYS_DETAILED_SEC = NO +ALWAYS_DETAILED_SEC = YES # If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all # inherited members of a class in the documentation of that class as if those @@ -162,7 +162,7 @@ FULL_PATH_NAMES = YES # will be relative from the directory where doxygen is started. # This tag requires that the tag FULL_PATH_NAMES is set to YES. -STRIP_FROM_PATH = +STRIP_FROM_PATH = src/ # The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the # path mentioned in the documentation of a class, which tells the reader which @@ -187,7 +187,7 @@ SHORT_NAMES = NO # description.) # The default value is: NO. -JAVADOC_AUTOBRIEF = NO +JAVADOC_AUTOBRIEF = YES # If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first # line (until the first dot) of a Qt-style comment as the brief description. If @@ -397,7 +397,7 @@ INLINE_GROUPED_CLASSES = NO # Man pages) or section (for LaTeX and RTF). # The default value is: NO. -INLINE_SIMPLE_STRUCTS = NO +INLINE_SIMPLE_STRUCTS = YES # When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or # enum is documented as struct, union, or enum with the name of the typedef. So @@ -578,7 +578,7 @@ SORT_MEMBER_DOCS = YES # this will also influence the order of the classes in the class list. # The default value is: NO. -SORT_BRIEF_DOCS = NO +SORT_BRIEF_DOCS = YES # If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the # (brief and detailed) documentation of class members so that constructors and @@ -790,7 +790,7 @@ WARN_LOGFILE = doxy.log # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. -INPUT = src src/arith src/memory src/ops +INPUT = src # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses @@ -864,7 +864,7 @@ FILE_PATTERNS = *.c \ # be searched for input files as well. # The default value is: NO. -RECURSIVE = NO +RECURSIVE = YES # The EXCLUDE tag can be used to specify files and/or directories that should be # excluded from the INPUT source files. This way you can easily exclude a diff --git a/src/arith/integer.c b/src/arith/integer.c index b5ed859..c51bc56 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -41,13 +41,12 @@ const char *hex_digits = "0123456789ABCDEF"; /* * Doctrine from here on in is that ALL integers are bignums, it's just * that integers less than 65 bits are bignums of one cell only. - * - * TODO: I have no idea at all how I'm going to print bignums! */ /** - * return the numeric value of this cell, as a C primitive double, not - * as a cons-space object. Cell may in principle be any kind of number. + * return the numeric value of the cell indicated by this `pointer`, as a C + * primitive double, not as a cons_space_object. The indicated cell may in + * principle be any kind of number; if it is not a number, will return `NAN`. */ long double numeric_value( struct cons_pointer pointer ) { long double result = NAN; @@ -75,7 +74,10 @@ long double numeric_value( struct cons_pointer pointer ) { } /** - * Allocate an integer cell representing this value and return a cons pointer to it. + * Allocate an integer cell representing this `value` and return a cons_pointer to it. + * @param value an integer value; + * @param more `NIL`, or a pointer to the more significant cell(s) of this number. + * *NOTE* that if `more` is not `NIL`, `value` *must not* exceed `MAX_INTEGER`. */ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { struct cons_pointer result = NIL; @@ -94,7 +96,13 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { return result; } - +/** + * Internal to `operate_on_integers`, do not use. + * @param c a pointer to a cell, assumed to be an integer cell; + * @param op a character representing the operation: expectedto be either + * '+' or '*'; behaviour with other values is undefined. + * \see operate_on_integers + */ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 ); @@ -115,8 +123,15 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { * possibly, later, other operations. Apply the operator `op` to the * integer arguments `a` and `b`, and return a pointer to the result. If * either `a` or `b` is not an integer, returns `NIL`. + * + * @param a a pointer to a cell, assumed to be an integer cell; + * @param b a pointer to a cell, assumed to be an integer cell; + * @param op a character representing the operation: expected to be either + * '+' or '*'; behaviour with other values is undefined. + * \see add_integers + * \see multiply_integers */ -/* TODO: there is a significant bug here, which manifests in multiply but +/* \todo there is a significant bug here, which manifests in multiply but * may not manifest in add. The value in the least significant cell ends * up significantly WRONG, but the value in the more significant cell * ends up correct. */ @@ -148,7 +163,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, switch ( op ) { case '*': - rv = av * bv * ( ( carry == 0 ) ? 1 : carry ); + rv = av * ( bv + carry ); break; case '+': rv = av + bv + carry; @@ -170,7 +185,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, if ( MAX_INTEGER >= rv ) { carry = 0; } else { - // TODO: we're correctly detecting overflow, but not yet correctly + // \todo we're correctly detecting overflow, but not yet correctly // handling it. carry = rv >> 60; debug_printf( DEBUG_ARITH, @@ -210,8 +225,8 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, } /** - * Return the sum of the integers pointed to by `a` and `b`. If either isn't - * an integer, will return nil. + * Return a pointer to an integer representing the sum of the integers + * pointed to by `a` and `b`. If either isn't an integer, will return nil. */ struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b ) { @@ -220,8 +235,8 @@ struct cons_pointer add_integers( struct cons_pointer a, } /** - * Return the product of the integers pointed to by `a` and `b`. If either isn't - * an integer, will return nil. + * Return a pointer to an integer representing the product of the integers + * pointed to by `a` and `b`. If either isn't an integer, will return nil. */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { @@ -253,7 +268,7 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, * to be looking to the next. H'mmmm. */ /* - * TODO: this blows up when printing three-cell integers, but works fine + * \todo this blows up when printing three-cell integers, but works fine * for two-cell. What's happening is that when we cross the barrier we * SHOULD print 2^120, but what we actually print is 2^117. H'mmm. */ diff --git a/src/arith/integer.h b/src/arith/integer.h index 1eda28f..f9eba33 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -1,4 +1,4 @@ -/** +/* * integer.h * * functions for integer cells. @@ -13,9 +13,6 @@ long double numeric_value( struct cons_pointer pointer ); -/** - * Allocate an integer cell representing this value and return a cons pointer to it. - */ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); struct cons_pointer add_integers( struct cons_pointer a, diff --git a/src/arith/peano.c b/src/arith/peano.c index 0dc2ed0..6666d0e 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -34,7 +34,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer arg2 ); - +/** + * return true if this `arg` points to a number whose value is zero. + */ bool zerop( struct cons_pointer arg ) { bool result = false; struct cons_space_object cell = pointer2cell( arg ); @@ -56,7 +58,13 @@ bool zerop( struct cons_pointer arg ) { } /** - * TODO: cannot throw an exception out of here, which is a problem + * Return the closest possible `binary64` representation to the value of + * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` + * is not any of these. + * + * @arg a pointer to an integer, ratio or real. + * + * \todo cannot throw an exception out of here, which is a problem * if a ratio may legally have zero as a divisor, or something which is * not a number is passed in. */ @@ -97,7 +105,13 @@ long double to_long_double( struct cons_pointer arg ) { /** - * TODO: cannot throw an exception out of here, which is a problem + * Return the closest possible `int64_t` representation to the value of + * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` + * is not any of these. + * + * @arg a pointer to an integer, ratio or real. + * + * \todo cannot throw an exception out of here, which is a problem * if a ratio may legally have zero as a divisor, or something which is * not a number (or is a big number) is passed in. */ @@ -106,7 +120,7 @@ int64_t to_long_int( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: - /* TODO: if (integerp(cell.payload.integer.more)) { + /* \todo if (integerp(cell.payload.integer.more)) { * throw an exception! * } */ result = cell.payload.integer.value; @@ -123,9 +137,9 @@ int64_t to_long_int( struct cons_pointer arg ) { /** -* return a cons_pointer indicating a number which is the sum of -* the numbers indicated by `arg1` and `arg2`. -*/ + * return a cons_pointer indicating a number which is the sum of + * the numbers indicated by `arg1` and `arg2`. + */ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, @@ -222,7 +236,8 @@ struct cons_pointer add_2( struct stack_frame *frame, * Add an indefinite number of numbers together * @param env the evaluation environment - ignored; * @param frame the stack frame. - * @return a pointer to an integer or real. + * @return a pointer to an integer, ratio or real. + * @exception if any argument is not a number, returns an exception. */ struct cons_pointer lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct @@ -356,7 +371,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; * @param frame the stack frame. - * @return a pointer to an integer or real. + * @return a pointer to an integer, ratio or real. + * @exception if any argument is not a number, returns an exception. */ struct cons_pointer lisp_multiply( struct stack_frame @@ -431,7 +447,7 @@ struct cons_pointer negative( struct cons_pointer frame, /** * return a cons_pointer indicating a number which is the result of - * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, + * subtracting the number indicated by `arg2` from that indicated by `arg1`, * in the context of this `frame`. */ struct cons_pointer subtract_2( struct stack_frame *frame, @@ -526,10 +542,12 @@ struct cons_pointer subtract_2( struct stack_frame *frame, } /** - * Subtract one number from another. + * Subtract one number from another. If more than two arguments are passed + * in the frame, the additional arguments are ignored. * @param env the evaluation environment - ignored; * @param frame the stack frame. - * @return a pointer to an integer or real. + * @return a pointer to an integer, ratio or real. + * @exception if either argument is not a number, returns an exception. */ struct cons_pointer lisp_subtract( struct stack_frame @@ -539,10 +557,12 @@ struct cons_pointer lisp_subtract( struct } /** - * Divide one number by another. + * Divide one number by another. If more than two arguments are passed + * in the frame, the additional arguments are ignored. * @param env the evaluation environment - ignored; * @param frame the stack frame. * @return a pointer to an integer or real. + * @exception if either argument is not a number, returns an exception. */ struct cons_pointer lisp_divide( struct stack_frame diff --git a/src/arith/peano.h b/src/arith/peano.h index 0bd09d5..816b147 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -1,4 +1,4 @@ -/** +/* * peano.h * * Basic peano arithmetic @@ -18,7 +18,7 @@ struct cons_pointer negative( struct cons_pointer frame, struct cons_pointer arg ); /** - * TODO: cannot throw an exception out of here, which is a problem + * \todo cannot throw an exception out of here, which is a problem. * if a ratio may legally have zero as a divisor, or something which is * not a number is passed in. */ @@ -35,7 +35,7 @@ lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); /** - * Multiply an indefinite number of numbers together + * Multiply an indefinite number of numbers together. * @param env the evaluation environment - ignored; * @param frame the stack frame. * @return a pointer to an integer or real. diff --git a/src/arith/ratio.c b/src/arith/ratio.c index f9dd0f4..784e71e 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -46,8 +46,8 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { /** * return a cons_pointer indicating a number which is of the * same value as the ratio indicated by `arg`, but which may - * be in a simplified representation. If `arg` isn't a ratio, - * will throw exception. + * be in a simplified representation. + * @exception If `arg` isn't a ratio, will return an exception. */ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg ) { @@ -83,8 +83,9 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the sum of - * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, - * this is going to break horribly. + * the ratios indicated by `arg1` and `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, @@ -100,7 +101,6 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); - // TODO: to be entirely reworked for bignums. All vars must be lisp integers. int64_t dd1v = pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, dd2v = @@ -160,7 +160,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the sum of * the intger indicated by `intarg` and the ratio indicated by - * `ratarg`. If you pass other types, this is going to break horribly. + * `ratarg`. + * @exception if either `intarg` or `ratarg` is not of the expected type. */ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, @@ -190,8 +191,9 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer to a ratio which represents the value of the ratio - * indicated by `arg1` divided by the ratio indicated by `arg2`. If either - * of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT. + * indicated by `arg1` divided by the ratio indicated by `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, @@ -210,8 +212,9 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the product of - * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, - * this is going to break horribly. + * the ratios indicated by `arg1` and `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct @@ -258,7 +261,8 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str /** * return a cons_pointer indicating a number which is the product of * the intger indicated by `intarg` and the ratio indicated by - * `ratarg`. If you pass other types, this is going to break horribly. + * `ratarg`. + * @exception if either `intarg` or `ratarg` is not of the expected type. */ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, @@ -285,8 +289,9 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the difference of - * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, - * this is going to break horribly. + * the ratios indicated by `arg1` and `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, @@ -301,8 +306,10 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, /** - * Construct a ratio frame from these two pointers, expected to be integers - * or (later) bignums, in the context of this stack_frame. + * Construct a ratio frame from this `dividend` and `divisor`, expected to + * be integers, in the context of the stack_frame indicated by this + * `frame_pointer`. + * @exception if either `dividend` or `divisor` is not an integer. */ struct cons_pointer make_ratio( struct cons_pointer frame_pointer, struct cons_pointer dividend, diff --git a/src/init.c b/src/init.c index 1edb586..7fdad2d 100644 --- a/src/init.c +++ b/src/init.c @@ -27,20 +27,28 @@ // extern char *optarg; /* defined in unistd.h */ +/** + * Bind this compiled `executable` function, as a Lisp function, to + * this name in the `oblist`. + * \todo where a function is not compiled from source, we could cache + * the name on the source pointer. Would make stack frames potentially + * more readable and aid debugging generally. + */ void bind_function( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer n = c_string_to_lisp_symbol( name ); inc_ref( n ); - /* TODO: where a function is not compiled from source, we could cache - * the name on the source pointer. Would make stack frames potentially - * more readable and aid debugging generally. */ deep_bind( n, make_function( NIL, executable ) ); dec_ref( n ); } +/** + * Bind this compiled `executable` function, as a Lisp special form, to + * this `name` in the `oblist`. + */ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { @@ -52,6 +60,9 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) dec_ref( n ); } +/** + * Bind this `value` to this `name` in the `oblist`. + */ void bind_value( wchar_t *name, struct cons_pointer value ) { struct cons_pointer n = c_string_to_lisp_symbol( name ); inc_ref( n ); @@ -61,6 +72,10 @@ void bind_value( wchar_t *name, struct cons_pointer value ) { dec_ref( n ); } +/** + * main entry point; parse command line arguments, initialise the environment, + * and enter the read-eval-print loop. + */ int main( int argc, char *argv[] ) { int option; bool dump_at_end = false; @@ -179,7 +194,6 @@ int main( int argc, char *argv[] ) { dec_ref( oblist ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); - if ( dump_at_end ) { dump_pages( stdout ); } diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 2aa8dce..f3c1760 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -45,9 +45,12 @@ struct cons_pointer freelist = NIL; struct cons_page *conspages[NCONSPAGES]; /** - * Make a cons page whose serial number (i.e. index in the conspages directory) is pageno. - * Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend - * cells 0 and 1 to the freelist but initialise them as NIL and T respectively. + * Make a cons page. Initialise all cells and prepend each to the freelist; + * if `initialised_cons_pages` is zero, do not prepend cells 0 and 1 to the + * freelist but initialise them as NIL and T respectively. + * \todo we ought to handle cons space exhaustion more gracefully than just + * crashing; should probably return an exception instead, although obviously + * that exception would have to have been pre-built. */ void make_cons_page( ) { struct cons_page *result = malloc( sizeof( struct cons_page ) ); @@ -110,7 +113,7 @@ void make_cons_page( ) { } /** - * dump the allocated pages to this output stream. + * dump the allocated pages to this `output` stream. */ void dump_pages( FILE * output ) { for ( int i = 0; i < initialised_cons_pages; i++ ) { @@ -125,8 +128,9 @@ void dump_pages( FILE * output ) { } /** - * Frees the cell at the specified pointer. Dangerous, primitive, low - * level. + * Frees the cell at the specified `pointer`; for all the types of cons-space + * object which point to other cons-space objects, cascade the decrement. + * Dangerous, primitive, low level. * * @pointer the cell to free */ @@ -136,63 +140,62 @@ void free_cell( struct cons_pointer pointer ) { 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 - * cons-space objects, cascade the decrement. */ - case CONSTV: - dec_ref( cell->payload.cons.car ); - dec_ref( cell->payload.cons.cdr ); - break; - case EXCEPTIONTV: - dec_ref( cell->payload.exception.message ); - dec_ref( cell->payload.exception.frame ); - break; - case FUNCTIONTV: - dec_ref( cell->payload.function.source ); - break; - case INTEGERTV: - dec_ref( cell->payload.integer.more ); - break; - case LAMBDATV: - case NLAMBDATV: - dec_ref( cell->payload.lambda.args ); - dec_ref( cell->payload.lambda.body ); - break; - case RATIOTV: - dec_ref( cell->payload.ratio.dividend ); - dec_ref( cell->payload.ratio.divisor ); - break; - case SPECIALTV: - dec_ref( cell->payload.special.source ); - break; - case STRINGTV: - case SYMBOLTV: - dec_ref( cell->payload.string.cdr ); - break; - case VECTORPOINTTV: - /* for vector space pointers, free the actual vector-space - * object. Dangerous! */ - debug_printf( DEBUG_ALLOC, - L"About to free vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); - struct vector_space_object *vso = cell->payload.vectorp.address; - - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - free_stack_frame( get_stack_frame( pointer ) ); - break; - } - - free( ( void * ) cell->payload.vectorp.address ); - debug_printf( DEBUG_ALLOC, - L"Freed vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); - break; - - } - if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { + switch ( cell->tag.value ) { + case CONSTV: + dec_ref( cell->payload.cons.car ); + dec_ref( cell->payload.cons.cdr ); + break; + case EXCEPTIONTV: + dec_ref( cell->payload.exception.message ); + dec_ref( cell->payload.exception.frame ); + break; + case FUNCTIONTV: + dec_ref( cell->payload.function.source ); + break; + case INTEGERTV: + dec_ref( cell->payload.integer.more ); + break; + case LAMBDATV: + case NLAMBDATV: + dec_ref( cell->payload.lambda.args ); + dec_ref( cell->payload.lambda.body ); + break; + case RATIOTV: + dec_ref( cell->payload.ratio.dividend ); + dec_ref( cell->payload.ratio.divisor ); + break; + case SPECIALTV: + dec_ref( cell->payload.special.source ); + break; + case STRINGTV: + case SYMBOLTV: + dec_ref( cell->payload.string.cdr ); + break; + case VECTORPOINTTV: + /* for vector space pointers, free the actual vector-space + * object. Dangerous! */ + debug_printf( DEBUG_ALLOC, + L"About to free vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); + struct vector_space_object *vso = + cell->payload.vectorp.address; + + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + free_stack_frame( get_stack_frame( pointer ) ); + break; + } + + free( ( void * ) cell->payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, + L"Freed vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); + break; + + } + strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; @@ -210,11 +213,14 @@ void free_cell( struct cons_pointer pointer ) { } /** - * Allocates a cell with the specified tag. Dangerous, primitive, low + * Allocates a cell with the specified `tag`. Dangerous, primitive, low * level. * * @param tag the tag of the cell to allocate - must be a valid cons space tag. * @return the cons pointer which refers to the cell allocated. + * \todo handle the case where another cons_page cannot be allocated; + * return an exception. Which, as we cannot create such an exception when + * cons space is exhausted, means we must construct it at init time. */ struct cons_pointer allocate_cell( char *tag ) { struct cons_pointer result = freelist; diff --git a/src/memory/conspage.h b/src/memory/conspage.h index aff6f40..ab04d6d 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -37,42 +37,16 @@ struct cons_page { struct cons_space_object cell[CONSPAGESIZE]; }; -/** - * The (global) pointer to the (global) freelist. Not sure whether this ultimately - * belongs in this file. - */ extern struct cons_pointer freelist; -/** - * An array of pointers to cons pages. - */ extern struct cons_page *conspages[NCONSPAGES]; -/** - * Frees the cell at the specified pointer. Dangerous, primitive, low - * level. - * - * @pointer the cell to free - */ void free_cell( struct cons_pointer pointer ); -/** - * Allocates a cell with the specified tag. Dangerous, primitive, low - * level. - * - * @param tag the tag of the cell to allocate - must be a valid cons space tag. - * @return the cons pointer which refers to the cell allocated. - */ struct cons_pointer allocate_cell( char *tag ); -/** - * initialise the cons page system; to be called exactly once during startup. - */ void initialise_cons_pages( ); -/** - * dump the allocated pages to this output stream. - */ void dump_pages( FILE * output ); #endif diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 6f89742..6a7e2bd 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -25,9 +25,9 @@ #include "stack.h" /** - * Check that the tag on the cell at this pointer is this tag + * True if the tag on the cell at this `pointer` is this `tag`, else false. */ -int check_tag( struct cons_pointer pointer, char *tag ) { +bool check_tag( struct cons_pointer pointer, char *tag ) { struct cons_space_object cell = pointer2cell( pointer ); return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; } @@ -178,12 +178,12 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { inc_ref( tail ); cell->payload.string.character = c; 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. Fix is probably * cell->payload.string.cdr = tsil */ cell->payload.string.cdr.offset = tail.offset; } else { - // TODO: should throw an exception! + // \todo should throw an exception! debug_printf( DEBUG_ALLOC, L"Warning: only NIL and %s can be prepended to %s\n", tag, tag ); @@ -193,17 +193,23 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { } /** - * Construct a string from this character and - * this tail. A string is implemented as a flat list of cells each of which - * has one character and a pointer to the next; in the last cell the - * pointer to next is NIL. + * Construct a string from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the string which is being built. */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { return make_string_like_thing( c, tail, STRINGTAG ); } /** - * Construct a symbol from this character and this tail. + * Construct a symbol from the character `c` and this `tail`. A symbol is + * internally identical to a string except for having a different tag. + * + * @param c the character to add (prepend); + * @param tail the symbol which is being built. */ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { return make_string_like_thing( c, tail, SYMBOLTAG ); @@ -239,7 +245,7 @@ struct cons_pointer make_read_stream( FILE * input ) { } /** - * Construct a cell which points to a stream open for writeing. + * Construct a cell which points to a stream open for writing. * @param output the C stream to wrap. */ struct cons_pointer make_write_stream( FILE * output ) { diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 0cf44a7..acc36df 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -1,4 +1,4 @@ -/** +/* * consspaceobject.h * * Declarations common to all cons space objects. @@ -25,113 +25,189 @@ */ #define TAGLENGTH 4 -/** - * tag values, all of which must be 4 bytes. Must not collide with vector space tag values +/* + * tag values, all of which must be 4 bytes. Must not collide with vector space + * tag values */ /** - * An ordinary cons cell: 1397641027 + * An ordinary cons cell: */ #define CONSTAG "CONS" + +/** + * The string `CONS`, considered as an `unsigned int`. + */ #define CONSTV 1397641027 /** * An exception. */ #define EXCEPTIONTAG "EXEP" + +/** + * The string `EXEP`, considered as an `unsigned int`. + */ #define EXCEPTIONTV 1346721861 /** * An unallocated cell on the free list - should never be encountered by a Lisp - * function. 1162170950 + * function. */ #define FREETAG "FREE" + +/** + * The string `FREE`, considered as an `unsigned int`. + */ #define FREETV 1162170950 /** - * An ordinary Lisp function - one whose arguments are pre-evaluated and passed as - * a stack frame. 1129207110 + * An ordinary Lisp function - one whose arguments are pre-evaluated. + * \see LAMBDATAG for interpretable functions. + * \see SPECIALTAG for functions whose arguments are not pre-evaluated. */ #define FUNCTIONTAG "FUNC" -#define FUNCTIONTV 1129207110 + /** - * An integer number. 1381256777 + * The string `FUNC`, considered as an `unsigned int`. + */ +#define FUNCTIONTV 1129207110 + +/** + * An integer number (bignums are integers). */ #define INTEGERTAG "INTR" + +/** + * The string `INTR`, considered as an `unsigned int`. + */ #define INTEGERTV 1381256777 /** - * A lambda cell. + * A lambda cell. Lambdas are the interpretable (source) versions of functions. + * \see FUNCTIONTAG. */ #define LAMBDATAG "LMDA" + +/** + * The string `LMDA`, considered as an `unsigned int`. + */ #define LAMBDATV 1094995276 /** - * The special cons cell at address {0,0} whose car and cdr both point to itself. - * 541870414 + * The special cons cell at address {0,0} whose car and cdr both point to + * itself. */ #define NILTAG "NIL " + +/** + * The string `NIL `, considered as an `unsigned int`. + */ #define NILTV 541870414 /** - * An nlambda cell. + * An nlambda cell. NLambdas are the interpretable (source) versions of special + * forms. \see SPECIALTAG. */ #define NLAMBDATAG "NLMD" + +/** + * The string `NLMD`, considered as an `unsigned int`. + */ #define NLAMBDATV 1145916494 +/** + * A rational number, stored as pointers two integers representing dividend + * and divisor respectively. + */ +#define RATIOTAG "RTIO" + +/** + * The string `RTIO`, considered as an `unsigned int`. + */ +#define RATIOTV 1330205778 + /** * An open read stream. */ #define READTAG "READ" + +/** + * The string `READ`, considered as an `unsigned int`. + */ #define READTV 1145128274 /** - * A real number. + * A real number, represented internally as an IEEE 754-2008 `binary64`. */ #define REALTAG "REAL" + +/** + * The string `REAL`, considered as an `unsigned int`. + */ #define REALTV 1279346002 /** - * A ratio. - */ -#define RATIOTAG "RTIO" -#define RATIOTV 1330205778 - -/** - * A special form - one whose arguments are not pre-evaluated but passed as a - * s-expression. 1296453715 + * A special form - one whose arguments are not pre-evaluated but passed as + * provided. + * \see NLAMBDATAG. */ #define SPECIALTAG "SPFM" + +/** + * The string `SPFM`, considered as an `unsigned int`. + */ #define SPECIALTV 1296453715 /** - * A string of characters, organised as a linked list. 1196577875 + * A string of characters, organised as a linked list. */ #define STRINGTAG "STRG" + +/** + * The string `STRG`, considered as an `unsigned int`. + */ #define STRINGTV 1196577875 /** - * A symbol is just like a string except not self-evaluating. 1112365395 + * A symbol is just like a string except not self-evaluating. */ #define SYMBOLTAG "SYMB" + +/** + * The string `SYMB`, considered as an `unsigned int`. + */ #define SYMBOLTV 1112365395 /** - * The special cons cell at address {0,1} which is canonically different from NIL. - * 1163219540 + * The special cons cell at address {0,1} which is canonically different + * from NIL. */ #define TRUETAG "TRUE" + +/** + * The string `TRUE`, considered as an `unsigned int`. + */ #define TRUETV 1163219540 /** * A pointer to an object in vector space. */ #define VECTORPOINTTAG "VECP" + +/** + * The string `VECP`, considered as an `unsigned int`. + */ #define VECTORPOINTTV 1346585942 + /** * An open write stream. */ #define WRITETAG "WRIT" + +/** + * The string `WRIT`, considered as an `unsigned int`. + */ #define WRITETV 1414091351 /** @@ -154,96 +230,103 @@ */ #define tag2uint(tag) ((uint32_t)*tag) +/** + * given a cons_pointer as argument, return the cell. + */ #define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset])) /** - * true if conspointer points to the special cell NIL, else false + * true if `conspoint` points to the special cell NIL, else false * (there should only be one of these so it's slightly redundant). */ #define nilp(conspoint) (check_tag(conspoint,NILTAG)) /** - * true if conspointer points to a cons cell, else false + * true if `conspoint` points to a cons cell, else false */ #define consp(conspoint) (check_tag(conspoint,CONSTAG)) /** - * true if conspointer points to an exception, else false + * true if `conspoint` points to an exception, else false */ #define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG)) /** - * true if conspointer points to a function cell, else false + * true if `conspoint` points to a function cell, else false */ #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) /** - * true if conspointer points to a special Lambda cell, else false + * true if `conspoint` points to a special Lambda cell, else false */ #define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) /** - * true if conspointer points to a special form cell, else false + * true if `conspoint` points to a special form cell, else false */ #define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) /** - * true if conspointer points to a string cell, else false + * true if `conspoint` points to a string cell, else false */ #define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) /** - * true if conspointer points to a symbol cell, else false + * true if `conspoint` points to a symbol cell, else false */ #define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) /** - * true if conspointer points to an integer cell, else false + * true if `conspoint` points to an integer cell, else false */ #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) /** - * true if conspointer points to a rational number cell, else false + * true if `conspoint` points to a rational number cell, else false */ #define ratiop(conspoint) (check_tag(conspoint,RATIOTAG)) /** - * true if conspointer points to a read stream cell, else false + * true if `conspoint` points to a read stream cell, else false */ #define readp(conspoint) (check_tag(conspoint,READTAG)) /** - * true if conspointer points to a real number cell, else false + * true if `conspoint` points to a real number cell, else false */ #define realp(conspoint) (check_tag(conspoint,REALTAG)) /** - * true if conspointer points to some sort of a number cell, + * true if `conspoint` points to some sort of a number cell, * else false */ #define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) +/** + * true if `conspoint` points to a sequence (list, string or, later, vector), + * else false. + */ #define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) /** - * true if thr conspointer points to a vector pointer. + * true if `conspoint` points to a vector pointer, else false. */ #define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) /** - * true if conspointer points to a write stream cell, else false. + * true if `conspoint` points to a write stream cell, else false. */ #define writep(conspoint) (check_tag(conspoint,WRITETAG)) /** - * true if conspointer points to a true cell, else false + * true if `conspoint` points to a true cell, else false * (there should only be one of these so it's slightly redundant). * Also note that anything that is not NIL is truthy. */ #define tp(conspoint) (checktag(conspoint,TRUETAG)) /** - * true if conspoint points to something that is truthy, i.e. + * true if `conspoint` points to something that is truthy, i.e. * anything but NIL. */ #define truep(conspoint) (!checktag(conspoint,NILTAG)) @@ -265,16 +348,18 @@ struct cons_pointer { /** * A stack frame. Yes, I know it isn't a cons-space object, but it's defined - * here to avoid circularity. TODO: refactor. + * here to avoid circularity. \todo refactor. */ struct stack_frame { - struct cons_pointer previous; /* the previous frame */ + /** the previous frame. */ + struct cons_pointer previous; + /** first 8 arument bindings. */ struct cons_pointer arg[args_in_frame]; - /* - * first 8 arument bindings - */ - struct cons_pointer more; /* list of any further argument bindings */ - struct cons_pointer function; /* the function to be called */ + /** list of any further argument bindings. */ + struct cons_pointer more; + /** the function to be called. */ + struct cons_pointer function; + /** the number of arguments provided. */ int args; }; @@ -282,7 +367,9 @@ struct stack_frame { * payload of a cons cell. */ struct cons_payload { + /** Contents of the Address Register, naturally. */ struct cons_pointer car; + /** Contents of the Decrement Register, naturally. */ struct cons_pointer cdr; }; @@ -291,7 +378,9 @@ struct cons_payload { * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. */ struct exception_payload { + /** The message: should be a Lisp string but in practice anything printable will do. */ struct cons_pointer message; + /** pointer to the (unfreed) stack frame in which the exception was thrown. */ struct cons_pointer frame; }; @@ -305,7 +394,17 @@ struct exception_payload { * result). */ struct function_payload { + /** + * pointer to the source from which the function was compiled, or NIL + * if it is a primitive. + */ struct cons_pointer source; + /** pointer to a function which takes a cons pointer (representing + * its argument list) and a cons pointer (representing its environment) and a + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). + * \todo check this documentation is current! + */ struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ); @@ -321,28 +420,37 @@ struct free_payload { }; /** - * payload of an integer cell. For the time being just a signed integer; - * later might be a signed 128 bit integer, or might have some flag to point to an - * optional bignum object. + * payload of an integer cell. An integer is in principle a sequence of cells; + * only 60 bits (+ sign bit) are actually used in each cell. If the value + * exceeds 60 bits, the least significant 60 bits are stored in the first cell + * in the chain, the next 60 in the next cell, and so on. Only the value of the + * first cell in any chain should be negative. */ struct integer_payload { + /** the value of the payload (i.e. 60 bits) of this cell. */ int64_t value; + /** the next (more significant) cell in the chain, ir `NIL` if there are no + * more. */ struct cons_pointer more; }; /** - * payload for lambda and nlambda cells + * payload for lambda and nlambda cells. */ struct lambda_payload { + /** the arument list */ struct cons_pointer args; + /** the body of the function to be applied to the arguments. */ struct cons_pointer body; }; /** - * payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells. + * payload for ratio cells. Both `dividend` and `divisor` must point to integer cells. */ struct ratio_payload { + /** a pointer to an integer representing the dividend */ struct cons_pointer dividend; + /** a pointer to an integer representing the divisor. */ struct cons_pointer divisor; }; @@ -351,20 +459,25 @@ struct ratio_payload { * precision, but I'm not sure of the detail. */ struct real_payload { + /** the value of the number */ long double value; }; /** - * Payload of a special form cell. - * source points to the source from which the function was compiled, or NIL - * if it is a primitive. - * executable points to a function which takes a cons pointer (representing - * its argument list) and a cons pointer (representing its environment) and a - * stack frame (representing the previous stack frame) as arguments and returns - * a cons pointer (representing its result). + * Payload of a special form cell. Currently identical to the payload of a + * function cell. + * \see function_payload */ struct special_payload { + /** + * pointer to the source from which the special form was compiled, or NIL + * if it is a primitive. + */ struct cons_pointer source; + /** pointer to a function which takes a cons pointer (representing + * its argument list) and a cons pointer (representing its environment) and a + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). */ struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ); @@ -374,6 +487,7 @@ struct special_payload { * payload of a read or write stream cell. */ struct stream_payload { + /** the stream to read from or write to. */ FILE *stream; }; @@ -384,8 +498,11 @@ struct stream_payload { * payload of a string cell. */ struct string_payload { - wint_t character; /* the actual character stored in this cell */ - uint32_t padding; /* unused padding to word-align the cdr */ + /** the actual character stored in this cell */ + wint_t character; + /** unused padding to word-align the cdr */ + uint32_t padding; + /** the remainder of the string following this character. */ struct cons_pointer cdr; }; @@ -393,19 +510,21 @@ struct string_payload { * payload of a vector pointer cell. */ struct vectorp_payload { + /** the tag of the vector-space object. NOTE that the vector space object + * should itself have the identical tag. */ union { - char bytes[TAGLENGTH]; /* the tag (type) of the - * vector-space object this cell - * points to, considered as bytes. - * NOTE that the vector space object - * should itself have the identical - * tag. */ - uint32_t value; /* the tag considered as a number */ + /** the tag (type) of the vector-space object this cell + * points to, considered as bytes. */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - void *address; - /* the address of the actual vector space - * object (TODO: will change when I actually + /** unused padding to word-align the address */ + uint32_t padding; + /** the address of the actual vector space + * object (\todo will change when I actually * implement vector space) */ + void *address; }; /** @@ -413,87 +532,80 @@ struct vectorp_payload { */ struct cons_space_object { union { - char bytes[TAGLENGTH]; /* the tag (type) of this cell, - * considered as bytes */ - uint32_t value; /* the tag considered as a number */ + /** the tag (type) of this cell, + * considered as bytes */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - uint32_t count; /* the count of the number of references to - * this cell */ - struct cons_pointer access; /* cons pointer to the access control list of - * this cell */ + /** the count of the number of references to this cell */ + uint32_t count; + /** cons pointer to the access control list of this cell */ + struct cons_pointer access; union { - /* + /** * if tag == CONSTAG */ struct cons_payload cons; - /* + /** * if tag == EXCEPTIONTAG */ struct exception_payload exception; - /* + /** * if tag == FREETAG */ struct free_payload free; - /* + /** * if tag == FUNCTIONTAG */ struct function_payload function; - /* + /** * if tag == INTEGERTAG */ struct integer_payload integer; - /* + /** * if tag == LAMBDATAG or NLAMBDATAG */ struct lambda_payload lambda; - /* + /** * if tag == NILTAG; we'll treat the special cell NIL as just a cons */ struct cons_payload nil; - /* + /** * if tag == RATIOTAG */ struct ratio_payload ratio; - /* + /** * if tag == READTAG || tag == WRITETAG */ struct stream_payload stream; - /* + /** * if tag == REALTAG */ struct real_payload real; - /* + /** * if tag == SPECIALTAG */ struct special_payload special; - /* + /** * if tag == STRINGTAG || tag == SYMBOLTAG */ struct string_payload string; - /* + /** * if tag == TRUETAG; we'll treat the special cell T as just a cons */ struct cons_payload t; - /* + /** * if tag == VECTORPTAG */ struct vectorp_payload vectorp; } payload; }; -/** - * Check that the tag on the cell at this pointer is this tag - */ -int check_tag( struct cons_pointer pointer, char *tag ); +bool check_tag( struct cons_pointer pointer, char *tag ); -/** - * increment the reference count of the object at this cons pointer - */ void inc_ref( struct cons_pointer pointer ); -/** - * decrement the reference count of the object at this cons pointer - */ void dec_ref( struct cons_pointer pointer ); struct cons_pointer make_cons( struct cons_pointer car, @@ -502,71 +614,34 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer frame_pointer ); -/** - * Construct a cell which points to an executable Lisp special form. - */ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ); -/** - * Construct a lambda (interpretable source) cell - */ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ); -/** - * Construct an nlambda (interpretable source) cell; to a - * lambda as a special form is to a function. - */ struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ); -/** - * Construct a cell which points to an executable Lisp special form. - */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ); -/** - * Construct a string from this character and this tail. A string is - * implemented as a flat list of cells each of which has one character and a - * pointer to the next; in the last cell the pointer to next is NIL. - */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); -/** - * Construct a symbol from this character and this tail. A symbol is identical - * to a string except for having a different tag. - */ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); -/** - * Construct a cell which points to a stream open for reading. - * @param input the C stream to wrap. - */ struct cons_pointer make_read_stream( FILE * input ); -/** - * Construct a cell which points to a stream open for writeing. - * @param output the C stream to wrap. - */ 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( wchar_t *string ); -/** - * Return a lisp symbol representation of this old skool ASCII string. - */ struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ); #endif diff --git a/src/memory/dump.c b/src/memory/dump.c index fc9175d..7ec2631 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -151,4 +151,3 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { break; } } - diff --git a/src/memory/dump.h b/src/memory/dump.h index 2293189..ec8928e 100644 --- a/src/memory/dump.h +++ b/src/memory/dump.h @@ -1,4 +1,4 @@ -/** +/* * dump.h * * Dump representations of both cons space and vector space objects. @@ -20,9 +20,6 @@ #define __dump_h -/** - * dump the object at this cons_pointer to this output stream. - */ void dump_object( FILE * output, struct cons_pointer pointer ); #endif diff --git a/src/memory/stack.c b/src/memory/stack.c index a1026b4..cf68701 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -26,14 +26,22 @@ #include "stack.h" #include "vectorspace.h" +/** + * set a register in a stack frame. Alwaye use this to do so, + * because that way we can be sure the inc_ref happens! + */ void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) { debug_printf( DEBUG_STACK, L"Setting register %d to ", reg ); debug_print_object( value, DEBUG_STACK ); debug_println( DEBUG_STACK ); - frame->arg[reg++] = value; + dec_ref(frame->arg[reg]); /* if there was anything in that slot + * previously other than NIL, we need to decrement it; + * NIL won't be decremented as it is locked. */ + frame->arg[reg] = value; inc_ref( value ); - if ( reg > frame->args ) { - frame->args = reg; + + if ( reg == frame->args ) { + frame->args++; } } @@ -71,15 +79,10 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { debug_dump_object( result, DEBUG_ALLOC ); -// 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 ) ) { 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 */ frame->previous = previous; @@ -131,7 +134,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_space_object cell = pointer2cell( args ); /* - * TODO: if we were running on real massively parallel hardware, + * \todo if we were running on real massively parallel hardware, * each arg except the first should be handed off to another * processor to be evaled in parallel; but see notes here: * https://github.com/simon-brooke/post-scarcity/wiki/parallelism @@ -220,7 +223,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, */ void free_stack_frame( struct stack_frame *frame ) { /* - * TODO: later, push it back on the stack-frame freelist + * \todo later, push it back on the stack-frame freelist */ debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC ); for ( int i = 0; i < args_in_frame; i++ ) { diff --git a/src/memory/stack.h b/src/memory/stack.h index 189ff6b..11763b2 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -35,12 +35,6 @@ */ #define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV) -/** - * set a register in a stack frame. Alwaye use this macro to do so, - • because that way we can be sure the inc_ref happens! - */ -//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);} - void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ); struct stack_frame *get_stack_frame( struct cons_pointer pointer ); @@ -65,7 +59,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, /* * struct stack_frame is defined in consspaceobject.h to break circularity - * TODO: refactor. + * \todo refactor. */ #endif diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 5ec14a8..9d98a77 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -26,19 +26,28 @@ /** - * make a cons-space object which points to the vector space object + * Make a cons_space_object which points to the vector_space_object * with this `tag` at this `address`. - * NOTE that `tag` should be the vector-space tag of the particular type of - * vector-space object, NOT `VECTORPOINTTAG`. + * + * @address the address of the vector_space_object to point to. + * @tag the vector-space tag of the particular type of vector-space object, + * NOT `VECTORPOINTTAG`. + * + * @return a cons_pointer to the object, or NIL if the object could not be + * allocated due to memory exhaustion. */ -struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { +struct cons_pointer make_vec_pointer( struct vector_space_object *address, char *tag ) { debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); + debug_printf( DEBUG_ALLOC, L"make_vec_pointer: tag written, about to set pointer address to %p\n", address ); + cell->payload.vectorp.address = address; + strncpy(&cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH); + debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", cell->payload.vectorp.address ); @@ -49,11 +58,15 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { } /** - * allocate a vector space object with this `payload_size` and `tag`, + * Allocate a vector space object with this `payload_size` and `tag`, * and return a `cons_pointer` which points to an object whigh points to it. - * NOTE that `tag` should be the vector-space tag of the particular type of - * vector-space object, NOT `VECTORPOINTTAG`. - * Returns NIL if the vector could not be allocated due to memory exhaustion. + * + * @tag the vector-space tag of the particular type of vector-space object, + * NOT `VECTORPOINTTAG`. + * @payload_size the size of the payload required, in bytes. + * + * @return a cons_pointer to the object, or NIL if the object could not be + * allocated due to memory exhaustion. */ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { debug_print( L"Entered make_vso\n", DEBUG_ALLOC ); @@ -72,7 +85,7 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { 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 ); + result = make_vec_pointer( vso, tag ); debug_dump_object( result, DEBUG_ALLOC ); vso->header.vecp = result; // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 1438d37..22b0d88 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -40,32 +40,48 @@ #define VECTORTAG "VECT" #define VECTORTV 0 +/** + * given a pointer to a vector space object, return the object. + */ #define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL)) -#define vso_get_vecp(vso)((vso->header.vecp)) + +/** + * given a vector space object, return its canonical pointer. + */ +#define vso_get_vecp(vso)((((vector_space_object)vso)->header.vecp)) struct cons_pointer make_vso( char *tag, uint64_t payload_size ); +/** + * the header which forms the start of every vector space object. + */ struct vector_space_header { + /** the tag (type) of this vector-space object. */ union { - char bytes[TAGLENGTH]; /* the tag (type) of the - * vector-space object this cell - * points to, considered as bytes. - * NOTE that the vector space object - * should itself have the identical - * tag. */ - uint32_t value; /* the tag considered as a number */ + /** the tag considered as bytes. */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - struct cons_pointer vecp; /* back pointer to the vector pointer - * which uniquely points to this vso */ - uint64_t size; /* the size of my payload, in bytes */ + /** back pointer to the vector pointer which uniquely points to this vso */ + struct cons_pointer vecp; + /** the size of my payload, in bytes */ + uint64_t size; }; +/** a vector_space_object is just a vector_space_header followed by a + * lump of bytes; what we deem to be in there is a function of the tag, + * and at this stage we don't have a good picture of what these may be. + * + * \see stack_frame for an example payload; + * \see make_empty_frame for an example of how to initialise and use one. + */ struct vector_space_object { + /** the header of this object */ struct vector_space_header header; - char payload; /* we'll malloc `size` bytes for payload, - * `payload` is just the first of these. - * TODO: this is almost certainly not - * idiomatic C. */ + /** we'll malloc `size` bytes for payload, `payload` is just the first of these. + * \todo this is almost certainly not idiomatic C. */ + char payload; }; #endif diff --git a/src/ops/intern.c b/src/ops/intern.c index 9d2387c..1e32a36 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -27,7 +27,8 @@ #include "print.h" /** - * The object list. What is added to this during system setup is 'global', that is, + * The global object list/or, to put it differently, the root namespace. + * What is added to this during system setup is 'global', that is, * visible to all sessions/threads. What is added during a session/thread is local to * that session/thread (because shallow binding). There must be some way for a user to * make the contents of their own environment persistent between threads but I don't diff --git a/src/ops/intern.h b/src/ops/intern.h index e940daa..b261242 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -1,14 +1,14 @@ -/** +/* * intern.h * * For now this implements an oblist and shallow binding; local environments can * be consed onto the front of the oblist. Later, this won't do; bindings will happen * in namespaces, which will probably be implemented as hash tables. - * + * * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; * so when a symbol is rebound in the master oblist, what in fact we do is construct * a new oblist without the previous binding but with the new binding. Anything which, - * prior to this action, held a pointer to the old oblist (as all current threads' + * prior to this action, held a pointer to the old oblist (as all current threads' * environments must do) continues to hold a pointer to the old oblist, and consequently * doesn't see the change. This is probably good but does mean you cannot use bindings * on the oblist to signal between threads. @@ -22,42 +22,19 @@ extern struct cons_pointer oblist; -/** - * return the value associated with this key in this store. In the current - * implementation a store is just an assoc list, but in future it might be a - * namespace, a regularity or a homogeneity. - */ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ); -/** - * Return true if this key is present as a key in this enviroment, defaulting to - * the oblist if no environment is passed. - */ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer environment ); -/** - * Return a new key/value store containing all the key/value pairs in this store - * with this key/value pair added to the front. - */ struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer store ); -/** - * Binds this key to this value in the global oblist, but doesn't affect the - * current environment. May not be useful except in bootstrapping (and even - * there it may not be especially useful). - */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ); -/** - * Ensure that a canonical copy of this key is bound in this environment, and - * return that canonical copy. If there is currently no such binding, create one - * with the value NIL. - */ struct cons_pointer intern( struct cons_pointer key, struct cons_pointer environment ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 298ae1a..775f3b4 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -39,9 +39,9 @@ /* * also to create in this section: * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); + * struct stack_frame* frame); * struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); + * struct stack_frame* frame); * * and others I haven't thought of yet. */ @@ -109,9 +109,13 @@ struct cons_pointer eval_form( struct stack_frame *parent, } /** - * eval all the forms in this `list` in the context of this stack `frame` + * Evaluate all the forms in this `list` in the context of this stack `frame` * and this `env`, and return a list of their values. If the arg passed as - * `list` is not in fact a list, return nil. + * `list` is not in fact a list, return NIL. + * @param frame the stack frame. + * @param list the list of forms to be evaluated. + * @param env the evaluation environment. + * @return a list of the the results of evaluating the forms. */ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -140,9 +144,8 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, return oblist; } - /** - * used to construct the body for `lambda` and `nlambda` expressions. + * Used to construct the body for `lambda` and `nlambda` expressions. */ struct cons_pointer compose_body( struct stack_frame *frame ) { struct cons_pointer body = frame->more; @@ -164,6 +167,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { /** * Construct an interpretable function. * + * (lambda args body) + * * @param frame the stack frame in which the expression is to be interpreted; * @param env the environment in which it is to be intepreted. */ @@ -176,6 +181,8 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, /** * Construct an interpretable special form. * + * (nlambda args body) + * * @param frame the stack frame in which the expression is to be interpreted; * @param env the environment in which it is to be intepreted. */ @@ -220,11 +227,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } inc_ref( new_env ); - /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ + /* \todo if there's more than `args_in_frame` arguments, bind those too. */ } else if ( symbolp( names ) ) { /* if `names` is a symbol, rather than a list of symbols, * then bind a list of the values of args to that symbol. */ - /* TODO: eval all the things in frame->more */ + /* \todo eval all the things in frame->more */ struct cons_pointer vals = eval_forms( frame, frame_pointer, frame->more, env ); @@ -412,17 +419,24 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { /** - * (eval s_expr) + * Function; evaluate the expression which is the first argument in the frame; + * further arguments are ignored. * - * function. - * If s_expr is a number, NIL, or T, returns s_expr. - * If s_expr is an unprotected string, returns the value that s_expr is bound - * to in the evaluation environment (env). - * If s_expr is a list, expects the car to be something that evaluates to a - * function or special form. - * If a function, evaluates all the other top level elements in s_expr and - * passes them in a stack frame as arguments to the function. - * If a special form, passes the cdr of s_expr to the special form as argument. + * * (eval expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return + * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. + * * If `expression` is a symbol, returns the value that expression is bound + * to in the evaluation environment (`env`). + * * If `expression` is a list, expects the car to be something that evaluates to a + * function or special form: + * * If a function, evaluates all the other top level elements in `expression` and + * passes them in a stack frame as arguments to the function; + * * If a special form, passes the cdr of expression to the special form as argument. + * @exception if `expression` is a symbol which is not bound in `env`. */ struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -457,12 +471,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, } break; /* - * TODO: + * \todo * the Clojure practice of having a map serve in the function place of - * an s-expression is a good one and I should adopt it; also if the - * object is a consp it could be interpretable source code but in the - * long run I don't want an interpreter, and if I can get away without - * so much the better. + * an s-expression is a good one and I should adopt it; */ default: result = frame->arg[0]; @@ -477,11 +488,16 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (apply fn args) - * - * function. Apply the function which is the result of evaluating the - * first argoment to the list of arguments which is the result of evaluating + * Function; apply the function which is the result of evaluating the + * first argument to the list of values which is the result of evaluating * the second argument + * + * * (apply fn args) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the result of applying `fn` to `args`. */ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -502,11 +518,16 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (quote a) - * - * Special form - * Returns its argument (strictly first argument - only one is expected but + * Special form; + * returns its argument (strictly first argument - only one is expected but * this isn't at this stage checked) unevaluated. + * + * * (quote a) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `a`, unevaluated, */ struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -516,13 +537,19 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (set name value) - * (set name value namespace) - * - * Function. + * Function; + * binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. Retuns `value`. * `namespace` defaults to the oblist. - * Binds the value of `name` in the `namespace` to value of `value`, altering - * the namespace in so doing. `namespace` defaults to the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set name value) + * * (set name value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` */ struct cons_pointer lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -548,20 +575,25 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (set! symbol value) - * (set! symbol value namespace) + * Special form; + * binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing, and returns value. `namespace` defaults to + * the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. * - * Special form. - * `namespace` defaults to the oblist. - * Binds `symbol` in the `namespace` to value of `value`, altering - * the namespace in so doing. `namespace` defaults to the value of `oblist`. + * * (set! symbol value) + * * (set! symbol value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` */ struct cons_pointer lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_pointer namespace = - nilp( frame->arg[2] ) ? oblist : frame->arg[2]; + struct cons_pointer namespace = frame->arg[2]; if ( symbolp( frame->arg[0] ) ) { struct cons_pointer val = @@ -581,12 +613,17 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (cons a b) - * - * Function. - * Returns a cell constructed from a and b. If a is of type string but its + * Function; + * returns a cell constructed from a and b. If a is of type string but its * cdr is nill, and b is of type string, then returns a new string cell; * otherwise returns a new cons cell. + * + * * (cons a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a new cons cell whose `car` is `a` and whose `cdr` is `b`. */ struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -597,8 +634,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( car ) && nilp( cdr ) ) { return NIL; - } else if ( stringp( car ) && stringp( cdr ) && - nilp( pointer2cell( car ).payload.string.cdr ) ) { + } else if ( stringp( car ) && stringp( cdr )) { + // \todo check that car is of length 1 result = make_string( pointer2cell( car ).payload.string.character, cdr ); } else { @@ -609,9 +646,17 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (car s_expr) - * Returns the first item (head) of a sequence. Valid for cons cells, - * strings, and TODO read streams and other things which can be considered as sequences. + * Function; + * returns the first item (head) of a sequence. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * + * * (car expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the first item (head) of `expression`. + * @exception if `expression` is not a sequence. */ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -626,11 +671,11 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, case READTV: result = make_string( fgetwc( cell.payload.stream.stream ), NIL ); break; + case NILTV: + break; case STRINGTV: result = make_string( cell.payload.string.character, NIL ); break; - case NILTV: - break; default: result = throw_exception( c_string_to_lisp_string @@ -642,11 +687,19 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (cdr s_expr) - * Returns the remainder of a sequence when the head is removed. Valid for cons cells, - * strings, and TODO read streams and other things which can be considered as sequences. - * NOTE that if the argument is an input stream, the first character is removed AND + * Function; + * returns the remainder of a sequence when the head is removed. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * *NOTE* that if the argument is an input stream, the first character is removed AND * DISCARDED. + * + * * (cdr expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the remainder of `expression` when the head is removed. + * @exception if `expression` is not a sequence. */ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -678,8 +731,14 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (assoc key store) - * Returns the value associated with key in store, or NIL if not found. + * Function; look up the value of a `key` in a `store`. + * + * * (assoc key store) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the value associated with `key` in `store`, or `nil` if not found. */ struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -688,8 +747,14 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (eq a b) - * Returns T if a and b are pointers to the same object, else NIL + * Function; are these two objects the same object? Shallow, cheap equality. + * + * * (eq a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are pointers to the same object, else `nil`; */ struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -698,8 +763,14 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, } /** - * (eq a b) - * Returns T if a and b are pointers to structurally identical objects, else NIL + * Function; are these two arguments identical? Deep, expensive equality. + * + * * (equal a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are recursively identical, else `nil`. */ struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -728,10 +799,17 @@ struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { /** - * (read) - * (read read-stream) - * Read one complete lisp form and return it. If read-stream is specified and - * is a read stream, then read from that stream, else stdin. + * Function; read one complete lisp form and return it. If read-stream is specified and + * is a read stream, then read from that stream, else the stream which is the value of + * `*in*` in the environment. + * + * * (read) + * * (read read-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the expression read. */ struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -788,8 +866,14 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) { /** - * (reverse sequence) - * Return a sequence like this sequence but with the members in the reverse order. + * Function; reverse the order of members in s sequence. + * + * * (reverse sequence) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a sequence like this `sequence` but with the members in the reverse order. */ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -799,10 +883,17 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, /** - * (print expr) - * (print expr write-stream) - * Print one complete lisp form and return NIL. If write-stream is specified and - * is a write stream, then print to that stream, else stdout. + * Function; print one complete lisp expression and return NIL. If write-stream is specified and + * is a write stream, then print to that stream, else the stream which is the value of + * `*out*` in the environment. + * + * * (print expr) + * * (print expr write-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the value of `expr`. */ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -837,10 +928,14 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * Function: Get the Lisp type of the single argument. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return As a Lisp string, the tag of the object which is the argument. + * Function: get the Lisp type of the single argument. + * + * * (type expression) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return As a Lisp string, the tag of `expression`. */ struct cons_pointer lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -849,21 +944,21 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * Evaluate each of these forms in this `env`ironment over this `frame`, + * Evaluate each of these expressions in this `env`ironment over this `frame`, * returning only the value of the last. */ struct cons_pointer c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer forms, struct cons_pointer env ) { + struct cons_pointer expressions, struct cons_pointer env ) { struct cons_pointer result = NIL; - while ( consp( forms ) ) { + while ( consp( expressions ) ) { struct cons_pointer r = result; inc_ref( r ); - result = eval_form( frame, frame_pointer, c_car( forms ), env ); + result = eval_form( frame, frame_pointer, c_car( expressions ), env ); dec_ref( r ); - forms = c_cdr( forms ); + expressions = c_cdr( expressions ); } return result; @@ -871,15 +966,16 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (progn forms...) - * - * Special form; evaluate the forms which are listed in my arguments + * Special form; evaluate the expressions which are listed in my arguments * sequentially and return the value of the last. This function is called 'do' * in some dialects of Lisp. * - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form on the sequence which is my single + * * (progn expressions...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which expressions are evaluated. + * @return the value of the last `expression` of the sequence which is my single * argument. */ struct cons_pointer @@ -904,16 +1000,20 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * Special form: conditional. Each arg is expected to be a list; if the first + * Special form: conditional. Each `clause` is expected to be a list; if the first * item in such a list evaluates to non-NIL, the remaining items in that list - * are evaluated in turn and the value of the last returned. If no arg (clause) + * are evaluated in turn and the value of the last returned. If no arg `clause` * has a first element which evaluates to non NIL, then NIL is returned. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form of the first successful clause. + * + * * (cond clauses...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression of the first successful `clause`. */ struct cons_pointer -lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, + lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; bool done = false; @@ -943,7 +1043,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, frame_pointer ); } } - /* TODO: if there are more than 8 clauses we need to continue into the + /* \todo if there are more than 8 clauses we need to continue into the * remainder */ return result; @@ -978,9 +1078,18 @@ throw_exception( struct cons_pointer message, } /** - * (exception ) + * Function; create an exception. Exceptions are special in as much as if an + * exception is created in the binding of the arguments of any function, the + * function will return the exception rather than whatever else it would + * normally return. A function which detects a problem it cannot resolve + * *should* return an exception. * - * Function. Returns an exception whose message is this `message`, and whose + * * (exception ) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return areturns an exception whose message is this `message`, and whose * stack frame is the parent stack frame when the function is invoked. * `message` does not have to be a string but should be something intelligible * which can be read. @@ -995,19 +1104,23 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (repl) - * (repl prompt) - * (repl prompt input_stream output_stream) + * Function: the read/eval/print loop. * - * Function: the read/eval/print loop. Returns the value of the last expression - * entered. + * * (repl) + * * (repl prompt) + * * (repl prompt input_stream output_stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which epressions will be evaluated. + * @return the value of the last expression read. */ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer expr = NIL; - /* TODO: bind *prompt*, *input*, *output* in the environment to the values + /* \todo bind *prompt*, *input*, *output* in the environment to the values * of arguments 0, 1, and 2 respectively, but in each case only if the * argument is not nil */ @@ -1023,7 +1136,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, inc_ref( output ); inc_ref( prompt_name ); - /* TODO: this is subtly wrong. If we were evaluating + /* \todo this is subtly wrong. If we were evaluating * (print (eval (read))) * then the stack frame for read would have the stack frame for * eval as parent, and it in turn would have the stack frame for @@ -1035,7 +1148,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * bound in the oblist subsequent to this function being invoked isn't in the * environment. So, for example, changes to *prompt* or *log* made in the oblist * are not visible. So copy changes made in the oblist into the enviroment. - * TODO: the whole process of resolving symbol values needs to be revisited + * \todo the whole process of resolving symbol values needs to be revisited * when we get onto namespaces. */ if ( !eq( oblist, old_oblist ) ) { struct cons_pointer cursor = oblist; @@ -1089,11 +1202,16 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, } /** - * (source object) + * Function. return the source code of the object which is its first argument, + * if it is an executable and has source code. * - * Function. - * Return the source code of the object, if it is an executable - * and has source code. + * * (source object) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment (ignored). + * @return the source of the `object` indicated, if it is a function, a lambda, + * an nlambda, or a spcial form; else `nil`. */ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -1119,7 +1237,7 @@ struct cons_pointer lisp_source( struct stack_frame *frame, cell.payload.lambda.body ) ); break; } - // TODO: suffers from premature GC, and I can't see why! + // \todo suffers from premature GC, and I can't see why! inc_ref( result ); return result; @@ -1127,11 +1245,20 @@ struct cons_pointer lisp_source( struct stack_frame *frame, /** - * Print the internal representation of the object indicated by `frame->arg[0]` to the - * (optional, defaults to `stdout`) stream indicated by `frame->arg[1]`. + * Function; print the internal representation of the object indicated by `frame->arg[0]` to the + * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. + * + * * (inspect expression) + * * (inspect expression ) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment. + * @return the value of the first argument - `expression`. */ -struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { debug_print( L"Entering print\n", DEBUG_IO ); FILE *output = stdout; struct cons_pointer out_stream = writep( frame->arg[1] ) ? diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 7d7d395..1aff486 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -202,5 +202,6 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); diff --git a/src/ops/print.c b/src/ops/print.c index 3feeb21..604c07c 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -25,7 +25,7 @@ /** * Whether or not we colorise output. - * TODO: this should be a Lisp symbol binding, not a C variable. + * \todo this should be a Lisp symbol binding, not a C variable. */ int print_use_colours = 0; @@ -122,7 +122,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { dump_stack_trace( output, pointer ); break; case FUNCTIONTV: - fwprintf( output, L"(Function)" ); + fwprintf( output, L"" ); break; case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); @@ -167,10 +167,10 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { print( output, cell.payload.ratio.divisor ); break; case READTV: - fwprintf( output, L"(Input stream)" ); + fwprintf( output, L"" ); break; case REALTV: - /* TODO: using the C heap is a bad plan because it will fragment. + /* \todo using the C heap is a bad plan because it will fragment. * As soon as I have working vector space I'll use a special purpose * vector space object */ buffer = ( char * ) malloc( 24 ); @@ -201,13 +201,13 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { print_string_contents( output, pointer ); break; case SPECIALTV: - fwprintf( output, L"(Special form)" ); + fwprintf( output, L"" ); break; case TRUETV: fwprintf( output, L"t" ); break; case WRITETV: - fwprintf( output, L"(Output stream)" ); + fwprintf( output, L"" ); break; default: fwprintf( stderr, diff --git a/src/ops/read.c b/src/ops/read.c index 6e2a07f..4006c99 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -119,7 +119,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, read_number( frame, frame_pointer, input, c, true ); } else if ( iswblank( next ) ) { - /* dotted pair. TODO: this isn't right, we + /* dotted pair. \todo this isn't right, we * really need to backtrack up a level. */ result = read_continuation( frame, frame_pointer, input, @@ -153,7 +153,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, /** * read a number from this input stream, given this initial character. - * TODO: Need to do a lot of inc_ref and dec_ref, to make sure the + * \todo Need to do a lot of inc_ref and dec_ref, to make sure the * garbage is collected. */ struct cons_pointer read_number( struct stack_frame *frame, @@ -163,7 +163,7 @@ struct cons_pointer read_number( struct stack_frame *frame, debug_print( L"entering read_number\n", DEBUG_IO ); struct cons_pointer result = make_integer( 0, NIL ); - /* TODO: we really need to be getting `base` from a privileged Lisp name - + /* \todo we really need to be getting `base` from a privileged Lisp name - * and it should be the same privileged name we use when writing numbers */ struct cons_pointer base = make_integer( 10, NIL ); struct cons_pointer dividend = NIL; @@ -298,7 +298,7 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { struct cons_pointer result; switch ( initial ) { case '\0': - result = make_string( initial, NIL ); + result = NIL; break; case '"': /* making a string of the null character means we can have an empty diff --git a/unit-tests/string-cons.sh b/unit-tests/string-cons.sh new file mode 100644 index 0000000..0ea0a71 --- /dev/null +++ b/unit-tests/string-cons.sh @@ -0,0 +1,25 @@ +#!/bin/bash + +# We should be able to cons a single character string onto the front of a string +expected='"Test"' +actual=`echo '(cons "T" "est")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# But if the first argument has more than one character, we should get a dotted pair +expected='("Test" . "pass")' +actual=`echo '(cons "Test" "pass")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From 64fc43e9fcc8b15a02cf02622a0c86a022c200d1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 20 Jan 2019 23:34:46 +0000 Subject: [PATCH 036/101] OK, my idea that long multiplication is like long addition is wrong. It's still broken, but it's broken because of fundamental misunderstanding which tinkering won't solve. --- lisp/scratchpad.lisp | 2 +- lisp/scratchpad2.lisp | 3 ++- src/arith/integer.c | 18 +++++++++++++----- src/ops/lispops.c | 32 +++++++++++++++++++++++++++----- unit-tests/eval-quote-symbol.sh | 2 +- unit-tests/many-args.sh | 13 ++++++++++++- 6 files changed, 56 insertions(+), 14 deletions(-) diff --git a/lisp/scratchpad.lisp b/lisp/scratchpad.lisp index 494fe59..0474099 100644 --- a/lisp/scratchpad.lisp +++ b/lisp/scratchpad.lisp @@ -45,4 +45,4 @@ (inspect (set! z (+ y y y y y y y y y y))) "This blows up: 10^37, which is a three cell bignum." -(inspect (+ z z z z z z z z z z)) +(inspect (set! final (+ z z z z z z z z z z))) diff --git a/lisp/scratchpad2.lisp b/lisp/scratchpad2.lisp index e608106..65f7aca 100644 --- a/lisp/scratchpad2.lisp +++ b/lisp/scratchpad2.lisp @@ -81,4 +81,5 @@ (inspect (set! z (+ y y y y y y y y))) -(inspect (+ z z z z z z z z)) +(inspect + (set! final (+ z z z z z z z z))) diff --git a/src/arith/integer.c b/src/arith/integer.c index c51bc56..5b2e26a 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -27,6 +27,7 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "lispops.h" /* * The maximum value we will allow in an integer cell. @@ -104,14 +105,20 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { * \see operate_on_integers */ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { - long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; + long int val = nilp( c ) ? + 0 : + pointer2cell( c ).payload.integer.value; + long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 ); __int128_t result = ( __int128_t ) integerp( c ) ? - ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; + ( val == 0 ) ? + carry : + val : + 0; debug_printf( DEBUG_ARITH, - L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; returning ", - val, op, is_first_cell ? "true" : "false" ); + L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; %4.4s; returning ", + val, op, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); debug_print_128bit( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); @@ -139,6 +146,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, struct cons_pointer b, char op ) { struct cons_pointer result = NIL; struct cons_pointer cursor = NIL; + __int128_t carry = 0; bool is_first_cell = true; @@ -163,7 +171,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, switch ( op ) { case '*': - rv = av * ( bv + carry ); + rv = (av * bv) + carry; break; case '+': rv = av + bv + carry; diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 775f3b4..c80d965 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -136,7 +136,12 @@ struct cons_pointer eval_forms( struct stack_frame *frame, /** * Return the object list (root namespace). * - * (oblist) + * * (oblist) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the root namespace. */ struct cons_pointer lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -165,12 +170,15 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { } /** - * Construct an interpretable function. + * Construct an interpretable function. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs function will be created. * * (lambda args body) * * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. * @param env the environment in which it is to be intepreted. + * @return an interpretable function with these `args` and this `body`. */ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -179,12 +187,15 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * Construct an interpretable special form. + * Construct an interpretable special form. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs special form will be created. * * (nlambda args body) * * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. * @param env the environment in which it is to be intepreted. + * @return an interpretable special form with these `args` and this `body`. */ struct cons_pointer lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -612,6 +623,16 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, return result; } +/** + * @return true if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp(struct cons_pointer arg) { + return nilp(arg) || + ( stringp( arg ) && + pointer2cell(arg).payload.string.character == (wint_t)'\0'); +} + /** * Function; * returns a cell constructed from a and b. If a is of type string but its @@ -634,7 +655,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( car ) && nilp( cdr ) ) { return NIL; - } else if ( stringp( car ) && stringp( cdr )) { + } else if ( stringp( car ) && stringp( cdr ) && + end_of_stringp( c_cdr( car)) ) { // \todo check that car is of length 1 result = make_string( pointer2cell( car ).payload.string.character, cdr ); @@ -1084,7 +1106,7 @@ throw_exception( struct cons_pointer message, * normally return. A function which detects a problem it cannot resolve * *should* return an exception. * - * * (exception ) + * * (exception message frame) * * @param frame my stack frame. * @param frame_pointer a pointer to my stack_frame. diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh index 253ce32..7e80c48 100755 --- a/unit-tests/eval-quote-symbol.sh +++ b/unit-tests/eval-quote-symbol.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(Special form)' +expected='' actual=`echo "(eval 'cond)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/many-args.sh b/unit-tests/many-args.sh index a574ecb..0317f77 100755 --- a/unit-tests/many-args.sh +++ b/unit-tests/many-args.sh @@ -6,7 +6,18 @@ actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" - exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# check that all the args are actually being evaluated... +expected="120" +actual=`echo "(+ (+ 0 1) (+ 0 2) (+ 0 3) (+ 0 4) (+ 0 5) (+ 0 6) (+ 0 7) (+ 0 8) (+ 0 9) (+ 0 10) (+ 0 11) (+ 0 12) (+ 0 13) (+ 0 14 ) (+ 0 15))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" exit 1 From 3fd322af6f147c55b415b7c286227381a0d501b6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 21 Jan 2019 16:14:25 +0000 Subject: [PATCH 037/101] Major progress, multiply now almost works There's a premature free() somewhere, and I'm not sure why. Print depends on divide, which is easy, but also on mod and floor (of rationals) which isn't. --- lisp/expt.lisp | 3 +- src/arith/integer.c | 238 +++++++++++++++++++++++++++++--------------- src/arith/peano.c | 138 ++++++++++++++++++++----- src/arith/peano.h | 50 +++------- src/init.c | 2 + 5 files changed, 287 insertions(+), 144 deletions(-) diff --git a/lisp/expt.lisp b/lisp/expt.lisp index 433b0ea..7ec849e 100644 --- a/lisp/expt.lisp +++ b/lisp/expt.lisp @@ -5,4 +5,5 @@ ((= x 1) n) (t (* n (expt n (- x 1))))))) -(expt 2 60) +(inspect expt) +(expt 2 59) diff --git a/src/arith/integer.c b/src/arith/integer.c index 5b2e26a..9e1a8a0 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -27,7 +27,9 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "equal.h" #include "lispops.h" +#include "peano.h" /* * The maximum value we will allow in an integer cell. @@ -100,11 +102,11 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { /** * Internal to `operate_on_integers`, do not use. * @param c a pointer to a cell, assumed to be an integer cell; - * @param op a character representing the operation: expectedto be either - * '+' or '*'; behaviour with other values is undefined. + * @param is_first_cell true if this is the first cell in a bignum + * chain, else false. * \see operate_on_integers */ -__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { +__int128_t cell_value( struct cons_pointer c, bool is_first_cell ) { long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; @@ -117,8 +119,8 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { val : 0; debug_printf( DEBUG_ARITH, - L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; %4.4s; returning ", - val, op, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); + L"cell_value: raw value is %ld, is_first_cell = %s; %4.4s; returning ", + val, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); debug_print_128bit( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); @@ -126,60 +128,77 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { } /** - * internal workings of both `add_integers` and `multiply_integers` (and - * possibly, later, other operations. Apply the operator `op` to the - * integer arguments `a` and `b`, and return a pointer to the result. If - * either `a` or `b` is not an integer, returns `NIL`. + * Overwrite the value field of the integer indicated by `new` with + * the least significant 60 bits of `val`, and return the more significant + * bits (if any) right-shifted by 60 places. Destructive, primitive, do not + * use in any context except primitive operations on integers. * - * @param a a pointer to a cell, assumed to be an integer cell; - * @param b a pointer to a cell, assumed to be an integer cell; - * @param op a character representing the operation: expected to be either - * '+' or '*'; behaviour with other values is undefined. - * \see add_integers - * \see multiply_integers + * @param val the value to represent; + * @param less_significant the less significant words of this bignum, if any, + * else NIL; + * @param new a newly created integer, which will be destructively changed. + * @return carry, if any, else 0. */ -/* \todo there is a significant bug here, which manifests in multiply but - * may not manifest in add. The value in the least significant cell ends - * up significantly WRONG, but the value in the more significant cell - * ends up correct. */ -struct cons_pointer operate_on_integers( struct cons_pointer a, - struct cons_pointer b, char op ) { +__int128_t int128_to_integer( __int128_t val, + struct cons_pointer less_significant, + struct cons_pointer new) +{ + struct cons_pointer cursor = NIL; + __int128_t carry = 0; + + if ( MAX_INTEGER >= val ) { + carry = 0; + } else { + carry = val >> 60; + debug_printf( DEBUG_ARITH, + L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); + val &= MAX_INTEGER; + } + + struct cons_space_object * newc = &pointer2cell( new); + newc->payload.integer.value = val; + + if ( integerp( less_significant ) ) { + struct cons_space_object *lsc = &pointer2cell( less_significant ); + inc_ref( new ); + lsc->payload.integer.more = new; + } + + return carry; +} + +/** + * Return a pointer to an integer representing the sum of the integers + * pointed to by `a` and `b`. If either isn't an integer, will return nil. + */ +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ) { struct cons_pointer result = NIL; struct cons_pointer cursor = NIL; + debug_print( L"add_integers: a = ", DEBUG_ARITH ); + debug_print_object(a, DEBUG_ARITH); + debug_print( L"; b = ", DEBUG_ARITH ); + debug_print_object(b, DEBUG_ARITH); + debug_println(DEBUG_ARITH); + __int128_t carry = 0; bool is_first_cell = true; if ( integerp( a ) && integerp( b ) ) { - debug_print( L"operate_on_integers: \n", DEBUG_ARITH ); + debug_print( L"add_integers: \n", DEBUG_ARITH ); debug_dump_object( a, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L" %c \n", op ); + debug_print( L" plus \n", DEBUG_ARITH ); debug_dump_object( b, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - __int128_t av = cell_value( a, op, is_first_cell ); - __int128_t bv = cell_value( b, op, is_first_cell ); + __int128_t av = cell_value( a, is_first_cell ); + __int128_t bv = cell_value( b, is_first_cell ); + __int128_t rv = av + bv + carry; - /* slightly dodgy. `MAX_INTEGER` is substantially smaller than `LONG_MAX`, and - * `LONG_MAX * LONG_MAX` =~ the maximum value for `__int128_t`. So if the carry - * is very large (which I'm not certain whether it can be and am not - * intellectually up to proving it this morning) adding the carry might - * overflow `__int128_t`. Edge-case testing required. - */ - __int128_t rv = NAN; - - switch ( op ) { - case '*': - rv = (av * bv) + carry; - break; - case '+': - rv = av + bv + carry; - break; - } - - debug_printf( DEBUG_ARITH, - L"operate_on_integers: op = '%c'; av = ", op ); + debug_print( L"add_integers: av = ", DEBUG_ARITH ); debug_print_128bit( av, DEBUG_ARITH ); debug_print( L"; bv = ", DEBUG_ARITH ); debug_print_128bit( bv, DEBUG_ARITH ); @@ -189,31 +208,9 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, debug_print_128bit( rv, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); - - if ( MAX_INTEGER >= rv ) { - carry = 0; - } else { - // \todo we're correctly detecting overflow, but not yet correctly - // handling it. - carry = rv >> 60; - debug_printf( DEBUG_ARITH, - L"operate_on_integers: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); - rv &= MAX_INTEGER; - } - - struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - - if ( nilp( cursor ) ) { - cursor = tail; - } else { - inc_ref( tail ); - /* yes, this is a destructive change - but the integer has not yet been released - * into the wild */ - struct cons_space_object *c = &pointer2cell( cursor ); - c->payload.integer.more = tail; - cursor = tail; - } + struct cons_pointer new = make_integer( 0, NIL); + carry = int128_to_integer(rv, cursor, new); + cursor = new; if ( nilp( result ) ) { result = cursor; @@ -225,30 +222,111 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, } } - debug_print( L"operate_on_integers returning:\n", DEBUG_ARITH ); - debug_dump_object( result, DEBUG_ARITH ); + debug_print( L"add_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); return result; } -/** - * Return a pointer to an integer representing the sum of the integers - * pointed to by `a` and `b`. If either isn't an integer, will return nil. - */ -struct cons_pointer add_integers( struct cons_pointer a, - struct cons_pointer b ) { +struct cons_pointer base_partial(int depth) { + struct cons_pointer result = NIL; - return operate_on_integers( a, b, '+' ); + for (int i = 0; i < depth; i++) { + result = make_integer(0, result); + } + + return result; } /** * Return a pointer to an integer representing the product of the integers * pointed to by `a` and `b`. If either isn't an integer, will return nil. + * \todo it is MUCH more complicated than this! + * + * @param a an integer; + * @param b an integer. */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { - return operate_on_integers( a, b, '*' ); + struct cons_pointer result = NIL; + bool neg = is_negative(a) != is_negative(b); + bool is_first_b = true; + int oom = 0; + + debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); + debug_print_object(a, DEBUG_ARITH); + debug_print( L"; b = ", DEBUG_ARITH ); + debug_print_object(b, DEBUG_ARITH); + debug_println(DEBUG_ARITH); + + if ( integerp( a ) && integerp( b ) ) { + while ( !nilp( b ) ) { + bool is_first_d = true; + struct cons_pointer d = a; + struct cons_pointer partial = base_partial(oom++); + __int128_t carry = 0; + + while ( !nilp(d) || carry != 0) { + struct cons_pointer old_partial = partial; + struct cons_pointer new = make_integer( 0, NIL); + __int128_t dv = cell_value( d, is_first_d ); + __int128_t bv = cell_value( b, is_first_b ); + + __int128_t rv = (dv * bv) + carry; + + debug_print( L"multiply_integers: d = ", DEBUG_ARITH); + debug_print_object( d, DEBUG_ARITH); + debug_print( L"; dv = ", DEBUG_ARITH ); + debug_print_128bit( dv, DEBUG_ARITH ); + debug_print( L"; bv = ", DEBUG_ARITH ); + debug_print_128bit( bv, DEBUG_ARITH ); + debug_print( L"; carry = ", DEBUG_ARITH ); + debug_print_128bit( carry, DEBUG_ARITH ); + debug_print( L"; rv = ", DEBUG_ARITH ); + debug_print_128bit( rv, DEBUG_ARITH ); + debug_print( L"; acc = ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH); + debug_print( L"; partial = ", DEBUG_ARITH ); + debug_print_object( partial, DEBUG_ARITH); + debug_print( L"\n", DEBUG_ARITH ); + + inc_ref(new); + carry = int128_to_integer(rv, NIL, new); + + if (nilp(d) && carry != 0) debug_print(L"THIS SHOULD NEVER HAPPEN!\n", DEBUG_ARITH); + + if (nilp(partial) || zerop(partial)) { + partial = new; + } else { + partial = add_integers(partial, new); + inc_ref(partial); + //dec_ref(new); + } + + //dec_ref(old_partial); + d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL; + is_first_d = false; + } + + if (nilp(result) || zerop(result)) { + result = partial; + } else { + struct cons_pointer old = result; + result = add_integers(partial, result); + //if (!eq(result, old)) dec_ref(old); + //if (!eq(result, partial)) dec_ref(partial); + } + b = pointer2cell( b ).payload.integer.more; + is_first_b = false; + } + } + + debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; } /** @@ -325,7 +403,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, * an unwanted comma on the front. */ struct cons_pointer tmp = result; result = pointer2cell( result ).payload.string.cdr; - dec_ref( tmp ); + //dec_ref( tmp ); } if ( is_negative ) { diff --git a/src/arith/peano.c b/src/arith/peano.c index 6666d0e..85bbd5c 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -57,6 +57,51 @@ bool zerop( struct cons_pointer arg ) { return result; } +/** + * does this `arg` point to a negative number? + */ +bool is_negative( struct cons_pointer arg) { + bool result = false; + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case INTEGERTV: + result = cell.payload.integer.value < 0; + break; + case RATIOTV: + result = is_negative( cell.payload.ratio.dividend ); + break; + case REALTV: + result = ( cell.payload.real.value < 0 ); + break; + } + + return result; +} + +struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( arg ); + + if ( is_negative( arg)) { + switch ( cell.tag.value ) { + case INTEGERTV: + result = make_integer(llabs(cell.payload.integer.value), cell.payload.integer.more); + break; + case RATIOTV: + result = make_ratio(frame_pointer, + absolute(frame_pointer, cell.payload.ratio.dividend), + cell.payload.ratio.divisor); + break; + case REALTV: + result = make_real( 0 - cell.payload.real.value ); + break; + } + } + + return result; +} + /** * Return the closest possible `binary64` representation to the value of * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` @@ -136,6 +181,22 @@ int64_t to_long_int( struct cons_pointer arg ) { } +/** + * Function: calculate the absolute value of a number. + * + * (absolute arg) + * + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return the absolute value of the number represented by the first + * argument, or NIL if it was not a number. + */ +struct cons_pointer lisp_absolute( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return absolute( frame_pointer, frame->arg[0]); +} + /** * return a cons_pointer indicating a number which is the sum of * the numbers indicated by `arg1` and `arg2`. @@ -286,7 +347,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, debug_print_object( arg1, DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH ); debug_print_object( arg2, DEBUG_ARITH ); - debug_print( L")", DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { result = arg2; @@ -316,9 +377,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: argument 2 is not a number" ), - frame_pointer ); + result = throw_exception( make_cons( + c_string_to_lisp_string( L"Cannot multiply: argument 2 is not a number: " ), + c_type(arg2)), + frame_pointer ); break; } break; @@ -342,8 +404,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: argument 1 is not a number" ), + result = throw_exception( + make_cons(c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number" ), + c_type(arg2)), frame_pointer ); } break; @@ -353,20 +417,24 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), - frame_pointer ); + result = throw_exception( + make_cons(c_string_to_lisp_string + ( L"Cannot multiply: argument 1 is not a number" ), + c_type(arg1)), + frame_pointer ); break; } } - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"multiply_2 returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); return result; } +#define multiply_one_arg(arg) {if (exceptionp(arg)){result=arg;}else{tmp = result; result = multiply_2( frame, frame_pointer, result, arg ); if ( !eq( tmp, result ) ) dec_ref( tmp );}} + /** * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; @@ -381,29 +449,31 @@ struct cons_pointer lisp_multiply( struct struct cons_pointer result = make_integer( 1, NIL ); struct cons_pointer tmp; - for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) - && !exceptionp( result ); i++ ) { - tmp = result; - result = multiply_2( frame, frame_pointer, result, frame->arg[i] ); + for ( int i = 0; + i < args_in_frame + && !nilp( frame->arg[i] ) + && !exceptionp( result ); + i++ ) { + debug_print( L"lisp_multiply: accumulator = ",DEBUG_ARITH); + debug_print_object(result, DEBUG_ARITH); + debug_print( L"; arg = ", DEBUG_ARITH); + debug_print_object(frame->arg[i], DEBUG_ARITH); + debug_println( DEBUG_ARITH); - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } + multiply_one_arg(frame->arg[i]); } struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { - tmp = result; - result = multiply_2( frame, frame_pointer, result, c_car( more ) ); - - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } - + multiply_one_arg(c_car( more )); more = c_cdr( more ); } + debug_print( L"lisp_multiply returning: ",DEBUG_ARITH); + debug_print_object(result, DEBUG_ARITH); + debug_println(DEBUG_ARITH); + return result; } @@ -445,6 +515,24 @@ struct cons_pointer negative( struct cons_pointer frame, return result; } + +/** + * Function: is this number negative? + * + * * (negative? arg) + * + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return T if the first argument was a negative number, or NIL if it + * was not. + */ +struct cons_pointer lisp_is_negative( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return is_negative(frame->arg[0]) ? TRUE : NIL; +} + + /** * return a cons_pointer indicating a number which is the result of * subtracting the number indicated by `arg2` from that indicated by `arg1`, diff --git a/src/arith/peano.h b/src/arith/peano.h index 816b147..fa03212 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -17,66 +17,40 @@ bool zerop( struct cons_pointer arg ); struct cons_pointer negative( struct cons_pointer frame, struct cons_pointer arg ); -/** - * \todo cannot throw an exception out of here, which is a problem. - * if a ratio may legally have zero as a divisor, or something which is - * not a number is passed in. - */ +bool is_negative( struct cons_pointer arg); + +struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg); + long double to_long_double( struct cons_pointer arg ); -/** - * Add an indefinite number of numbers together - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ +struct cons_pointer lisp_absolute( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ); + struct cons_pointer lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -/** - * Multiply an indefinite number of numbers together. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ +struct cons_pointer lisp_is_negative( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ); + struct cons_pointer lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -/** - * return a cons_pointer indicating a number which is the - * 0 - the number indicated by `arg`. - */ struct cons_pointer negative( struct cons_pointer frame, struct cons_pointer arg ); -/** - * return a cons_pointer indicating a number which is the result of - * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, - * in the context of this `frame`. - */ struct cons_pointer subtract_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ); -/** - * Subtract one number from another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ struct cons_pointer lisp_subtract( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -/** - * Divide one number by another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ struct cons_pointer lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/init.c b/src/init.c index 7fdad2d..e0d2b01 100644 --- a/src/init.c +++ b/src/init.c @@ -142,6 +142,7 @@ int main( int argc, char *argv[] ) { /* * primitive function operations */ + bind_function( L"absolute", &lisp_absolute ); bind_function( L"add", &lisp_add ); bind_function( L"apply", &lisp_apply ); bind_function( L"assoc", &lisp_assoc ); @@ -155,6 +156,7 @@ int main( int argc, char *argv[] ) { bind_function( L"exception", &lisp_exception ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); + bind_function( L"negative?", &lisp_is_negative); bind_function( L"read", &lisp_read ); bind_function( L"repl", &lisp_repl ); bind_function( L"oblist", &lisp_oblist ); From bf72ae379d180b4fb773bb48920e4628e55be895 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 22 Jan 2019 09:48:26 +0000 Subject: [PATCH 038/101] Getting closer. WARNING: GC disabled in this commit. --- src/arith/integer.c | 58 ++++++++---------------------------- src/arith/integer.h | 2 -- src/arith/peano.c | 19 +++++------- src/arith/peano.h | 5 ++++ src/memory/consspaceobject.c | 2 +- src/ops/equal.c | 6 ++-- 6 files changed, 30 insertions(+), 62 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 9e1a8a0..543bf0d 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -31,11 +31,6 @@ #include "lispops.h" #include "peano.h" -/* - * The maximum value we will allow in an integer cell. - */ -#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL) - /** * hexadecimal digits for printing numbers. */ @@ -46,36 +41,6 @@ const char *hex_digits = "0123456789ABCDEF"; * that integers less than 65 bits are bignums of one cell only. */ -/** - * return the numeric value of the cell indicated by this `pointer`, as a C - * primitive double, not as a cons_space_object. The indicated cell may in - * principle be any kind of number; if it is not a number, will return `NAN`. - */ -long double numeric_value( struct cons_pointer pointer ) { - long double result = NAN; - struct cons_space_object *cell = &pointer2cell( pointer ); - - switch ( cell->tag.value ) { - case INTEGERTV: - result = 1.0; - while ( cell->tag.value == INTEGERTV ) { - result = ( result * LONG_MAX * cell->payload.integer.value ); - cell = &pointer2cell( cell->payload.integer.more ); - } - break; - case RATIOTV: - result = numeric_value( cell->payload.ratio.dividend ) / - numeric_value( cell->payload.ratio.divisor ); - break; - case REALTV: - result = cell->payload.real.value; - break; - // default is NAN - } - - return result; -} - /** * Allocate an integer cell representing this `value` and return a cons_pointer to it. * @param value an integer value; @@ -100,13 +65,17 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { } /** - * Internal to `operate_on_integers`, do not use. + * Low level integer arithmetic, do not use elsewhere. + * * @param c a pointer to a cell, assumed to be an integer cell; + * @param op a character representing the operation: expectedto be either + * '+' or '*'; behaviour with other values is undefined. * @param is_first_cell true if this is the first cell in a bignum * chain, else false. - * \see operate_on_integers + * \see multiply_integers + * \see add_integers */ -__int128_t cell_value( struct cons_pointer c, bool is_first_cell ) { +__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; @@ -117,7 +86,7 @@ __int128_t cell_value( struct cons_pointer c, bool is_first_cell ) { ( val == 0 ) ? carry : val : - 0; + op == '*' ? 1 : 0; debug_printf( DEBUG_ARITH, L"cell_value: raw value is %ld, is_first_cell = %s; %4.4s; returning ", val, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); @@ -194,8 +163,8 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - __int128_t av = cell_value( a, is_first_cell ); - __int128_t bv = cell_value( b, is_first_cell ); + __int128_t av = cell_value( a, '+', is_first_cell ); + __int128_t bv = cell_value( b, '+', is_first_cell ); __int128_t rv = av + bv + carry; debug_print( L"add_integers: av = ", DEBUG_ARITH ); @@ -268,10 +237,10 @@ struct cons_pointer multiply_integers( struct cons_pointer a, __int128_t carry = 0; while ( !nilp(d) || carry != 0) { - struct cons_pointer old_partial = partial; + partial = make_integer(0, partial); struct cons_pointer new = make_integer( 0, NIL); - __int128_t dv = cell_value( d, is_first_d ); - __int128_t bv = cell_value( b, is_first_b ); + __int128_t dv = cell_value( d, '*', is_first_d ); + __int128_t bv = cell_value( b, '*', is_first_b ); __int128_t rv = (dv * bv) + carry; @@ -304,7 +273,6 @@ struct cons_pointer multiply_integers( struct cons_pointer a, //dec_ref(new); } - //dec_ref(old_partial); d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL; is_first_d = false; } diff --git a/src/arith/integer.h b/src/arith/integer.h index f9eba33..117a0bf 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -11,8 +11,6 @@ #ifndef __integer_h #define __integer_h -long double numeric_value( struct cons_pointer pointer ); - struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); struct cons_pointer add_integers( struct cons_pointer a, diff --git a/src/arith/peano.c b/src/arith/peano.c index 85bbd5c..addfed6 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -21,6 +21,7 @@ #include "integer.h" #include "intern.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" #include "read.h" @@ -119,19 +120,15 @@ long double to_long_double( struct cons_pointer arg ) { switch ( cell.tag.value ) { case INTEGERTV: - result = ( double ) cell.payload.integer.value; + result = 1.0; + while ( cell.tag.value == INTEGERTV ) { + result = ( result * (MAX_INTEGER + 1) * cell.payload.integer.value ); + cell = pointer2cell( cell.payload.integer.more ); + } break; case RATIOTV: - { - struct cons_space_object dividend = - pointer2cell( cell.payload.ratio.dividend ); - struct cons_space_object divisor = - pointer2cell( cell.payload.ratio.divisor ); - - result = - ( long double ) dividend.payload.integer.value / - divisor.payload.integer.value; - } + result = to_long_double(cell.payload.ratio.dividend) / + to_long_double(cell.payload.ratio.divisor); break; case REALTV: result = cell.payload.real.value; diff --git a/src/arith/peano.h b/src/arith/peano.h index fa03212..7164a24 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -12,6 +12,11 @@ #ifndef PEANO_H #define PEANO_H +/** + * The maximum value we will allow in an integer cell. + */ +#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL) + bool zerop( struct cons_pointer arg ); struct cons_pointer negative( struct cons_pointer frame, diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 6a7e2bd..4eefde0 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -59,7 +59,7 @@ void dec_ref( struct cons_pointer pointer ) { cell->count--; if ( cell->count == 0 ) { - free_cell( pointer ); + // free_cell( pointer ); } } } diff --git a/src/ops/equal.c b/src/ops/equal.c index 9eedd53..0c01a81 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -12,7 +12,7 @@ #include "conspage.h" #include "consspaceobject.h" -#include "integer.h" +#include "peano.h" /** * Shallow, and thus cheap, equality: true if these two objects are @@ -92,8 +92,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { break; case REALTV: { - double num_a = numeric_value( a ); - double num_b = numeric_value( b ); + double num_a = to_long_double( a ); + double num_b = to_long_double( b ); double max = fabs( num_a ) > fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); From f8c20ab3b1778606024fa86cd52067603293d07f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 24 Jan 2019 10:12:08 +0000 Subject: [PATCH 039/101] Still broken, but I believe we're moving in the right direction. --- lisp/expt.lisp | 3 +- notes/mad-software.md | 75 ++++++++++++++++++++++++++++++++++++ src/arith/integer.c | 36 +++++++++++------ src/arith/peano.c | 32 ++++++++++----- src/memory/consspaceobject.c | 2 +- 5 files changed, 124 insertions(+), 24 deletions(-) create mode 100644 notes/mad-software.md diff --git a/lisp/expt.lisp b/lisp/expt.lisp index 7ec849e..8b32252 100644 --- a/lisp/expt.lisp +++ b/lisp/expt.lisp @@ -5,5 +5,4 @@ ((= x 1) n) (t (* n (expt n (- x 1))))))) -(inspect expt) -(expt 2 59) +(inspect (expt 2 60)) diff --git a/notes/mad-software.md b/notes/mad-software.md new file mode 100644 index 0000000..bbe8092 --- /dev/null +++ b/notes/mad-software.md @@ -0,0 +1,75 @@ +# Mad software + +I was listening to [Eric Normand's podcast](https://lispcast.com/tension-between-data-and-entity/) this morning, as I was making breakfast and tidying my room; he was talking about semantics and data. It started a train of thought which I shall try to unroll. + +I have blogged a lot in the past about madness and about software, but I don't think I've ever blogged about madness and software in the same essay. But the reasons I'm mad and the reasons I'm (sometimes) very good at software are related; both have their roots in autism and dyslexia, or, to put it differently, how my brain is wired. + +I first wrote about [post scarcity software](https://blog.journeyman.cc/2006/02/post-scarcity-software.html) thirteen years ago. It was a thought about how software environments should be designed if were weren't held back by the cruft of the past, by tradition and by a lack, frankly, of anything much in the way of new creative thought. And seeing that the core of the system I described is a Lisp, which is to say it builds on a software architecture which is exactly as old as I am, perhaps it is infected by my take on tradition and my own lack of creativity, but let's, for the purposes of this essay, assume not. + +I started actually writing the [post scarcity software environment](https://github.com/simon-brooke/post-scarcity) on the second of January 2017, which is to say two years ago. It's been an extremely low priority task, because I don't have enough faith in either my vision or my skill to think that it will ever be of use to anyone. Nevertheless, it does now actually work, in as much as you can write software in it. It's not at all easy yet, and I wouldn't recommend anyone try, but you can check out the master branch from Github, compile it, and it works. + +As my mental health has deteriorated, I have been working on it more over the past couple of months, partly because I have lost faith in my ability to deliver the more practical projects I've been working on, and partly because doing something which is genuinely intellectually hard helps subdue the chaos in my mind. + +Having said that, it is hard and I am not sharp, and so progress is slow. I started work on big number arithmetic a three weeks ago, and where I'm up to at this point is: + +* addition seems to work up to at least the second bignum boundary; +* multiplication doesn't work beyond the first bignum boundary; +* subraction doesn't work, and turns out not to be as easy as just inverting addition; +* division sort of trivially works, but only in the sense that we can create a rational number out of arbitrary bignums; +* reading works beyond the first bignum boundary, but not up to the second (because multiplication doesn't work); +* printing doesn't work beyond the first bignum boundary. + +I knew bignums were going to be a challenge, and I could have studied other people's bignum code and have consciously chosen not to do so; but this is not fast progress. + +(I should point out that in those three weeks I've also done four days of customer work, which is .Net and boring but it's done, spent two days seeing my sister, spent two days so depressed I didn't actually do anything at all, and done a bit or practical work around the croft. But still!) + +In a sense, it wasn't expected to be. Writing the underpinnings of a software environment which is conceptually without limits has challenge after challenge after challenge. + +But there are ideas in post scarcity which may have wider utility than this mad idea in itself. Layering homogeneities and regularities onto Clojure maps might - perhaps would - make a useful library, might would make a very useful component for exactly the sort of data wrangling Eric Normand was talking about. Yes, you can use a map - raw data soup - to represent a company. But if this map is a member of a homogeneity, 'Companies', then we know every member of it has employees, and that every employee has a salary and an email address. Regularities and homogeneities form the building blocks of APIs; to use the example Eric discussed in his podcast, the salary is the property of the employee, but the payroll is a property of the company. So in post scarcity, you'd get the payroll figure for a company by using a method on the 'Companies' homogeneity. How it computes that value is part of the general doctrine of **'Don't Know, Don't Care'**: the principal that people writing software at any layer in the system do not need to know, and should not need to care, about how things are implemented in the layers below them. + + + +So, the user needing to find the payroll value would enter something like this: + +``` + (with ((companies . ::shared:pool:companies) + (acme . companies:acme-widgets)) + (companies:methods:payroll acme)) +``` + +In practice, in post scarcity notation, the payroll method probably looks something like this: + +``` + (lambda (company) + (reduce + (map ::shared:pool:employees:methods:salary (:employees company)))) +``` + +There are issues that I haven't resolved yet about the mutability of regularities and homogeneities; obviously, in order to provide multi-user visibility of current values of shared data, some regularities must be mutable. But mutability has potentially very serious perfomance issues for the hypercube architecture, so I think that in general they should not be. + +However, that's detail, and not what I'm trying to talk about here. + +What I'm trying to talk about here is the fact that if I were confident that these ideas were any good, and that I had the ability to persuade others that they were any good, it would make far more sense to implement them in Clojure and promote them as a library. + +But the problem with depression is that you cannot evaluate whether your ideas are any good. The black dog tells you you're shit, and that your ideas are shit, and that you don't really know enough to be worth listening to, and that you're an old tramp who lives in a hut in the woods, and probably smells, and that in any case interaction with other people quickly makes you shaky and confused, and that you can never get your act together, and you never finish anything. + +And all that is objectively true, and I know that it is true. But I also know that I can (or at least have in the past been able to) build really good software, and that I can (or have been able, in the past, to) present ideas really well. + +These two collections of statements about me are both true at the same time. But the difference is that I believe the first and I don't believe the second. + +And behind all this is the fact that bignum arithmetic is a solved problem. I could dig out the SBCL source code and crib from that. I am bashing my head against bignum arithmetic and trying to solve it myself, not because it's the most efficient way to produce good code quickly, but because what I'm really trying to do is just distract myself and waste time while I can get on with dying. + +And the reason beyond that that I'm working on a software system I know I'll never finish, which is designed to run on computers which don't even exist yet - and although I'm very confident that enormously parallel hardware will be used in future, I'm not at all sure it will look anything like what I'm envisaging - the reason I'm building this mad software is that, because it will never be finished, no-one will ever use it except me, and no-one will say how crap it is and how easily it could have been done better. + +Because the other thing that I'm doing in writing this stuff, apart from distracting from the swirling chaos and rage in my head, apart from waiting to die, the other thing I'm doing is trying to give myself a feeling of mastery, of competence, of ability to face problems and solve them. And, to an extent, it works. But I have so little confidence that I actually have that mastery, that competence, that I don't want to expose it to criticism. I don't want my few fragile rags of self worth stripped away. + +And so I work, and work, and work at something which is so arcane, so obscure, so damned pointless that no-one will ever use it. + +Not because I'm even enjoying it, but just to burn the time. + +This is mad. + +I am mad. + +I hate, hate, hate being mad. + +Postscript: just writing this essay has made me tearful, headachey, sick, shaky. It's very hard to face up to the irrationalities and self-deceptions in one's own behaviour. diff --git a/src/arith/integer.c b/src/arith/integer.c index 543bf0d..6a26126 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -137,6 +137,23 @@ __int128_t int128_to_integer( __int128_t val, return carry; } +struct cons_pointer make_integer_128(__int128_t val, + struct cons_pointer less_significant) { + struct cons_pointer result = NIL; + + do { + if ( MAX_INTEGER >= val ) { + result = make_integer( (long int) val, less_significant); + } else { + less_significant = make_integer( (long int)val & MAX_INTEGER, less_significant); + val = val >> 60; + } + + } while (nilp(result)); + + return result; +} + /** * Return a pointer to an integer representing the sum of the integers * pointed to by `a` and `b`. If either isn't an integer, will return nil. @@ -221,7 +238,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer result = NIL; bool neg = is_negative(a) != is_negative(b); bool is_first_b = true; - int oom = 0; + int oom = -1; debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); debug_print_object(a, DEBUG_ARITH); @@ -233,14 +250,14 @@ struct cons_pointer multiply_integers( struct cons_pointer a, while ( !nilp( b ) ) { bool is_first_d = true; struct cons_pointer d = a; - struct cons_pointer partial = base_partial(oom++); + struct cons_pointer partial = base_partial(++oom); __int128_t carry = 0; while ( !nilp(d) || carry != 0) { partial = make_integer(0, partial); - struct cons_pointer new = make_integer( 0, NIL); - __int128_t dv = cell_value( d, '*', is_first_d ); - __int128_t bv = cell_value( b, '*', is_first_b ); + struct cons_pointer new = NIL; + __int128_t dv = cell_value( d, '+', is_first_d ); + __int128_t bv = cell_value( b, '+', is_first_b ); __int128_t rv = (dv * bv) + carry; @@ -260,17 +277,12 @@ struct cons_pointer multiply_integers( struct cons_pointer a, debug_print_object( partial, DEBUG_ARITH); debug_print( L"\n", DEBUG_ARITH ); - inc_ref(new); - carry = int128_to_integer(rv, NIL, new); + new = make_integer_128(rv, base_partial(oom)); - if (nilp(d) && carry != 0) debug_print(L"THIS SHOULD NEVER HAPPEN!\n", DEBUG_ARITH); - - if (nilp(partial) || zerop(partial)) { + if ( zerop(partial)) { partial = new; } else { partial = add_integers(partial, new); - inc_ref(partial); - //dec_ref(new); } d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL; diff --git a/src/arith/peano.c b/src/arith/peano.c index addfed6..7db638a 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -43,9 +43,14 @@ bool zerop( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { - case INTEGERTV: - result = cell.payload.integer.value == 0 && - nilp( cell.payload.integer.more ); + case INTEGERTV: { + do { + debug_print(L"zerop: ", DEBUG_ARITH); + debug_dump_object(arg, DEBUG_ARITH); + result = (pointer2cell( arg ).payload.integer.value == 0); + arg = pointer2cell(arg).payload.integer.more; + } while (result && integerp(arg)); + } break; case RATIOTV: result = zerop( cell.payload.ratio.dividend ); @@ -115,16 +120,25 @@ struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_poi * not a number is passed in. */ long double to_long_double( struct cons_pointer arg ) { - long double result = 0; /* not a number, as a long double */ + long double result = 0; struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: - result = 1.0; - while ( cell.tag.value == INTEGERTV ) { - result = ( result * (MAX_INTEGER + 1) * cell.payload.integer.value ); - cell = pointer2cell( cell.payload.integer.more ); - } + // obviously, this doesn't work for bignums + result = (long double)cell.payload.integer.value; + // sadly, this doesn't work at all. +// result += 1.0; +// for (bool is_first = false; integerp(arg); is_first = true) { +// debug_printf(DEBUG_ARITH, L"to_long_double: accumulator = %lf, arg = ", result); +// debug_dump_object(arg, DEBUG_ARITH); +// if (!is_first) { +// result *= (long double)(MAX_INTEGER + 1); +// } +// result *= (long double)(cell.payload.integer.value); +// arg = cell.payload.integer.more; +// cell = pointer2cell( arg ); +// } break; case RATIOTV: result = to_long_double(cell.payload.ratio.dividend) / diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 4eefde0..6a7e2bd 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -59,7 +59,7 @@ void dec_ref( struct cons_pointer pointer ) { cell->count--; if ( cell->count == 0 ) { - // free_cell( pointer ); + free_cell( pointer ); } } } From a355a28ffa1f8789b13ca43ee4c62fe19a04ee2a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 24 Jan 2019 18:59:01 +0000 Subject: [PATCH 040/101] Tactical commit whilst converting to URL_FILE --- .gitignore | 2 + Makefile | 2 +- src/arith/integer.c | 10 +- src/init.c | 15 +- src/io/fopen.c | 543 +++++++++++++++++++++++++++++++++++ src/io/fopen.h | 72 +++++ src/memory/conspage.c | 2 +- src/memory/conspage.h | 2 +- src/memory/consspaceobject.c | 6 +- src/memory/consspaceobject.h | 9 +- src/memory/dump.c | 8 +- src/memory/dump.h | 2 +- src/memory/stack.c | 4 +- src/memory/stack.h | 4 +- src/ops/io.c | 8 + src/ops/lispops.c | 8 +- src/ops/print.c | 12 +- src/ops/print.h | 4 +- src/ops/read.c | 23 +- src/ops/read.h | 2 +- unit-tests/bignum-print.sh | 38 +-- unit-tests/string-cons.sh | 0 unit-tests/wide-character.sh | 12 + 23 files changed, 700 insertions(+), 88 deletions(-) create mode 100644 src/io/fopen.c create mode 100644 src/io/fopen.h create mode 100644 src/ops/io.c mode change 100644 => 100755 unit-tests/string-cons.sh create mode 100755 unit-tests/wide-character.sh diff --git a/.gitignore b/.gitignore index b428e03..6fa1cd9 100644 --- a/.gitignore +++ b/.gitignore @@ -32,3 +32,5 @@ log* utils_src/readprintwc/out *.dump + +*.bak diff --git a/Makefile b/Makefile index 7179c91..c4c4ef3 100644 --- a/Makefile +++ b/Makefile @@ -16,7 +16,7 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ -npsl -nsc -nsob -nss -nut -prs -l79 -ts2 CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG -LDFLAGS := -lm +LDFLAGS := -lm -lcurl all: $(TARGET) diff --git a/src/arith/integer.c b/src/arith/integer.c index 6a26126..679bf37 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -314,7 +314,6 @@ struct cons_pointer multiply_integers( struct cons_pointer a, */ struct cons_pointer integer_to_string_add_digit( int digit, int digits, struct cons_pointer tail ) { - digits++; wint_t character = btowc( hex_digits[digit] ); return ( digits % 3 == 0 ) ? make_string( L',', make_string( character, @@ -352,10 +351,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { if ( !nilp( integer.payload.integer.more ) ) { integer = pointer2cell( integer.payload.integer.more ); - accumulator += integer.payload.integer.value == 0 ? - MAX_INTEGER : - ( llabs( integer.payload.integer.value ) * - ( MAX_INTEGER + 1 ) ); + accumulator += integer.payload.integer.value; debug_print ( L"integer_to_string: crossing cell boundary, accumulator is: ", DEBUG_IO ); @@ -369,10 +365,12 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", offset, hex_digits[offset] ); debug_print_128bit( accumulator, DEBUG_IO ); + debug_print( L"; result is: ", DEBUG_IO); + debug_print_object( result, DEBUG_IO); debug_println( DEBUG_IO ); result = - integer_to_string_add_digit( offset, digits++, result ); + integer_to_string_add_digit( offset, ++digits, result ); accumulator = accumulator / base; } while ( accumulator > base ); } diff --git a/src/init.c b/src/init.c index e0d2b01..e8a33a9 100644 --- a/src/init.c +++ b/src/init.c @@ -9,6 +9,7 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include #include @@ -81,6 +82,8 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; + setlocale(LC_ALL, ""); + while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { case 'c': @@ -123,14 +126,14 @@ int main( int argc, char *argv[] ) { * standard input, output, error and sink streams * attempt to set wide character acceptance on all streams */ - FILE *sink = fopen( "/dev/null", "w" ); + URL_FILE *sink = url_fopen( "/dev/null", "w" ); fwide( stdin, 1 ); fwide( stdout, 1 ); fwide( stderr, 1 ); fwide( sink, 1 ); - bind_value( L"*in*", make_read_stream( stdin ) ); - bind_value( L"*out*", make_write_stream( stdout ) ); - bind_value( L"*log*", make_write_stream( stderr ) ); + bind_value( L"*in*", make_read_stream( file_to_url_file(stdin) ) ); + bind_value( L"*out*", make_write_stream( file_to_url_file(stdout) ) ); + bind_value( L"*log*", make_write_stream( file_to_url_file(stderr) ) ); bind_value( L"*sink*", make_write_stream( sink ) ); /* @@ -180,9 +183,9 @@ int main( int argc, char *argv[] ) { */ bind_special( L"cond", &lisp_cond ); bind_special( L"lambda", &lisp_lambda ); - // bind_special( L"λ", &lisp_lambda ); + bind_special( L"\u03bb", &lisp_lambda ); // λ bind_special( L"nlambda", &lisp_nlambda ); - // bind_special( L"nλ", &lisp_nlambda ); + bind_special( L"n\u03bb", &lisp_nlambda ); bind_special( L"progn", &lisp_progn ); bind_special( L"quote", &lisp_quote ); bind_special( L"set!", &lisp_set_shriek ); diff --git a/src/io/fopen.c b/src/io/fopen.c new file mode 100644 index 0000000..d13250f --- /dev/null +++ b/src/io/fopen.c @@ -0,0 +1,543 @@ +/* + * fopen.c + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2017 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + + +#include +#include +#ifndef WIN32 +# include +#endif +#include +#include + +#include +/* + * wide characters + */ +#include +#include + +#include "fopen.h" + +/* we use a global one for convenience */ +static CURLM *multi_handle; + +/* curl calls this routine to get more data */ +static size_t write_callback(char *buffer, + size_t size, + size_t nitems, + void *userp) +{ + char *newbuff; + size_t rembuff; + + URL_FILE *url = (URL_FILE *)userp; + size *= nitems; + + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + + if(size > rembuff) { + /* not enough space in buffer */ + newbuff = realloc(url->buffer, url->buffer_len + (size - rembuff)); + if(newbuff == NULL) { + fprintf(stderr, "callback buffer grow failed\n"); + size = rembuff; + } + else { + /* realloc succeeded increase buffer size*/ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } + } + + memcpy(&url->buffer[url->buffer_pos], buffer, size); + url->buffer_pos += size; + + return size; +} + +/* use to attempt to fill the read buffer up to requested number of bytes */ +static int fill_buffer(URL_FILE *file, size_t want) +{ + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ + + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if((!file->still_running) || (file->buffer_pos > want)) + return 0; + + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; + + FD_ZERO(&fdread); + FD_ZERO(&fdwrite); + FD_ZERO(&fdexcep); + + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; + + curl_multi_timeout(multi_handle, &curl_timeo); + if(curl_timeo >= 0) { + timeout.tv_sec = curl_timeo / 1000; + if(timeout.tv_sec > 1) + timeout.tv_sec = 1; + else + timeout.tv_usec = (curl_timeo % 1000) * 1000; + } + + /* get file descriptors from the transfers */ + mc = curl_multi_fdset(multi_handle, &fdread, &fdwrite, &fdexcep, &maxfd); + + if(mc != CURLM_OK) { + fprintf(stderr, "curl_multi_fdset() failed, code %d.\n", mc); + break; + } + + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ + + if(maxfd == -1) { +#ifdef _WIN32 + Sleep(100); + rc = 0; +#else + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select(0, NULL, NULL, NULL, &wait); +#endif + } + else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select(maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout); + } + + switch(rc) { + case -1: + /* select error */ + break; + + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform(multi_handle, &file->still_running); + break; + } + } while(file->still_running && (file->buffer_pos < want)); + return 1; +} + +/* use to remove want bytes from the front of a files buffer */ +static int use_buffer(URL_FILE *file, size_t want) +{ + /* sort out buffer */ + if((file->buffer_pos - want) <= 0) { + /* ditch buffer - write will recreate */ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } + else { + /* move rest down make it available for later */ + memmove(file->buffer, + &file->buffer[want], + (file->buffer_pos - want)); + + file->buffer_pos -= want; + } + return 0; +} + +URL_FILE *url_fopen(const char *url, const char *operation) +{ + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ + + URL_FILE *file; + (void)operation; + + file = calloc(1, sizeof(URL_FILE)); + if(!file) + return NULL; + + file->handle.file = fopen(url, operation); + if(file->handle.file) + file->type = CFTYPE_FILE; /* marked as URL */ + + else { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init(); + + curl_easy_setopt(file->handle.curl, CURLOPT_URL, url); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEDATA, file); + curl_easy_setopt(file->handle.curl, CURLOPT_VERBOSE, 0L); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback); + + if(!multi_handle) + multi_handle = curl_multi_init(); + + curl_multi_add_handle(multi_handle, file->handle.curl); + + /* lets start the fetch */ + curl_multi_perform(multi_handle, &file->still_running); + + if((file->buffer_pos == 0) && (!file->still_running)) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + + free(file); + + file = NULL; + } + } + return file; +} + +int url_fclose(URL_FILE *file) +{ + int ret = 0;/* default is good return */ + + switch(file->type) { + case CFTYPE_FILE: + ret = fclose(file->handle.file); /* passthrough */ + break; + + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + break; + + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; + } + + free(file->buffer);/* free any allocated buffer space */ + free(file); + + return ret; +} + +int url_feof(URL_FILE *file) +{ + int ret = 0; + + switch(file->type) { + case CFTYPE_FILE: + ret = feof(file->handle.file); + break; + + case CFTYPE_CURL: + if((file->buffer_pos == 0) && (!file->still_running)) + ret = 1; + break; + + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; +} + +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file) +{ + size_t want; + + switch(file->type) { + case CFTYPE_FILE: + want = fread(ptr, size, nmemb, file->handle.file); + break; + + case CFTYPE_CURL: + want = nmemb * size; + + fill_buffer(file, want); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if(!file->buffer_pos) + return 0; + + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + + use_buffer(file, want); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; +} + +char *url_fgets(char *ptr, size_t size, URL_FILE *file) +{ + size_t want = size - 1;/* always need to leave room for zero termination */ + size_t loop; + + switch(file->type) { + case CFTYPE_FILE: + ptr = fgets(ptr, (int)size, file->handle.file); + break; + + case CFTYPE_CURL: + fill_buffer(file, want); + + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if(!file->buffer_pos) + return NULL; + + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; + + /*buffer contains data */ + /* look for newline or eof */ + for(loop = 0; loop < want; loop++) { + if(file->buffer[loop] == '\n') { + want = loop + 1;/* include newline */ + break; + } + } + + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + ptr[want] = 0;/* always null terminate */ + + use_buffer(file, want); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr;/*success */ +} + +void url_rewind(URL_FILE *file) +{ + switch(file->type) { + case CFTYPE_FILE: + rewind(file->handle.file); /* passthrough */ + break; + + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* restart */ + curl_multi_add_handle(multi_handle, file->handle.curl); + + /* ditch buffer - write will recreate - resets stream pos*/ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + + break; + + default: /* unknown or supported type - oh dear */ + break; + } +} + +/** + * given this file handle f, return a new url_file handle wrapping it. + * + * @param f the file to be wrapped; + * @return the new handle, or null if no such handle could be allocated. + */ +URL_FILE * file_to_url_file( FILE* f) { + URL_FILE * result = (URL_FILE *)malloc(sizeof(URL_FILE)); + + if ( result != NULL) { + result->type = CFTYPE_FILE, + result->handle.file = f; + } + + return result; +} + + +wint_t url_fgetwc(URL_FILE *file) { + wint_t result = 0; + + switch(file->type) { + case CFTYPE_FILE: + fwide( file->handle.file, 1 ); /* wide characters */ + result = fgetc(file->handle.file); /* passthrough */ + break; + + case CFTYPE_CURL: + url_fread(&result, sizeof(wint_t), 1, file); + break; + } + + return result; +} + +/* #define FGETSFILE "fgets.test" */ +/* #define FREADFILE "fread.test" */ +/* #define REWINDFILE "rewind.test" */ + +/* /\* Small main program to retrieve from a url using fgets and fread saving the */ +/* * output to two test files (note the fgets method will corrupt binary files if */ +/* * they contain 0 chars *\/ */ +/* int main(int argc, char *argv[]) */ +/* { */ +/* URL_FILE *handle; */ +/* FILE *outf; */ + +/* size_t nread; */ +/* char buffer[256]; */ +/* const char *url; */ + +/* if(argc < 2) */ +/* url = "http://192.168.7.3/testfile";/\* default to testurl *\/ */ +/* else */ +/* url = argv[1];/\* use passed url *\/ */ + +/* /\* copy from url line by line with fgets *\/ */ +/* outf = fopen(FGETSFILE, "wb+"); */ +/* if(!outf) { */ +/* perror("couldn't open fgets output file\n"); */ +/* return 1; */ +/* } */ + +/* handle = url_fopen(url, "r"); */ +/* if(!handle) { */ +/* printf("couldn't url_fopen() %s\n", url); */ +/* fclose(outf); */ +/* return 2; */ +/* } */ + +/* while(!url_feof(handle)) { */ +/* url_fgets(buffer, sizeof(buffer), handle); */ +/* fwrite(buffer, 1, strlen(buffer), outf); */ +/* } */ + +/* url_fclose(handle); */ + +/* fclose(outf); */ + + +/* /\* Copy from url with fread *\/ */ +/* outf = fopen(FREADFILE, "wb+"); */ +/* if(!outf) { */ +/* perror("couldn't open fread output file\n"); */ +/* return 1; */ +/* } */ + +/* handle = url_fopen("testfile", "r"); */ +/* if(!handle) { */ +/* printf("couldn't url_fopen() testfile\n"); */ +/* fclose(outf); */ +/* return 2; */ +/* } */ + +/* do { */ +/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ +/* fwrite(buffer, 1, nread, outf); */ +/* } while(nread); */ + +/* url_fclose(handle); */ + +/* fclose(outf); */ + + +/* /\* Test rewind *\/ */ +/* outf = fopen(REWINDFILE, "wb+"); */ +/* if(!outf) { */ +/* perror("couldn't open fread output file\n"); */ +/* return 1; */ +/* } */ + +/* handle = url_fopen("testfile", "r"); */ +/* if(!handle) { */ +/* printf("couldn't url_fopen() testfile\n"); */ +/* fclose(outf); */ +/* return 2; */ +/* } */ + +/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ +/* fwrite(buffer, 1, nread, outf); */ +/* url_rewind(handle); */ + +/* buffer[0]='\n'; */ +/* fwrite(buffer, 1, 1, outf); */ + +/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ +/* fwrite(buffer, 1, nread, outf); */ + +/* url_fclose(handle); */ + +/* fclose(outf); */ + +/* return 0;/\* all done *\/ */ +/* } */ diff --git a/src/io/fopen.h b/src/io/fopen.h new file mode 100644 index 0000000..9874ac7 --- /dev/null +++ b/src/io/fopen.h @@ -0,0 +1,72 @@ +/* + * fopen.h + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2017 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + +#ifndef __fopen_h +#define __fopen_h + +enum fcurl_type_e { + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 +}; + +struct fcurl_data +{ + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ + + char *buffer; /* buffer to store cached data*/ + size_t buffer_len; /* currently allocated buffers length */ + size_t buffer_pos; /* end of data in buffer*/ + int still_running; /* Is background url fetch still in progress */ +}; + +typedef struct fcurl_data URL_FILE; + +/* exported functions */ +URL_FILE *url_fopen(const char *url, const char *operation); +int url_fclose(URL_FILE *file); +int url_feof(URL_FILE *file); +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file); +char *url_fgets(char *ptr, size_t size, URL_FILE *file); +void url_rewind(URL_FILE *file); + +wint_t url_fgetwc(URL_FILE *file); +URL_FILE * file_to_url_file( FILE* f); + + + +#endif diff --git a/src/memory/conspage.c b/src/memory/conspage.c index f3c1760..03034e4 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -115,7 +115,7 @@ void make_cons_page( ) { /** * dump the allocated pages to this `output` stream. */ -void dump_pages( FILE * output ) { +void dump_pages( URL_FILE * output ) { for ( int i = 0; i < initialised_cons_pages; i++ ) { fwprintf( output, L"\nDUMPING PAGE %d\n", i ); diff --git a/src/memory/conspage.h b/src/memory/conspage.h index ab04d6d..fa11da9 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -47,6 +47,6 @@ struct cons_pointer allocate_cell( char *tag ); void initialise_cons_pages( ); -void dump_pages( FILE * output ); +void dump_pages( URL_FILE * output ); #endif diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 6a7e2bd..9edbf66 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -95,8 +95,6 @@ struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); -// inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ - inc_ref( message ); inc_ref( frame_pointer ); cell->payload.exception.message = message; @@ -235,7 +233,7 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable ) * Construct a cell which points to a stream open for reading. * @param input the C stream to wrap. */ -struct cons_pointer make_read_stream( FILE * input ) { +struct cons_pointer make_read_stream( URL_FILE * input ) { struct cons_pointer pointer = allocate_cell( READTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -248,7 +246,7 @@ struct cons_pointer make_read_stream( FILE * input ) { * Construct a cell which points to a stream open for writing. * @param output the C stream to wrap. */ -struct cons_pointer make_write_stream( FILE * output ) { +struct cons_pointer make_write_stream( URL_FILE * output ) { struct cons_pointer pointer = allocate_cell( WRITETAG ); struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index acc36df..8db8099 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -16,6 +16,9 @@ */ #include #include +#include + +#include "fopen.h" #ifndef __consspaceobject_h #define __consspaceobject_h @@ -488,7 +491,7 @@ struct special_payload { */ struct stream_payload { /** the stream to read from or write to. */ - FILE *stream; + URL_FILE *stream; }; /** @@ -636,9 +639,9 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); -struct cons_pointer make_read_stream( FILE * input ); +struct cons_pointer make_read_stream( URL_FILE * input ); -struct cons_pointer make_write_stream( FILE * output ); +struct cons_pointer make_write_stream( URL_FILE * output ); struct cons_pointer c_string_to_lisp_string( wchar_t *string ); diff --git a/src/memory/dump.c b/src/memory/dump.c index 7ec2631..cec0dfd 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -26,7 +26,7 @@ #include "vectorspace.h" -void dump_string_cell( FILE * output, wchar_t *prefix, +void dump_string_cell( URL_FILE * output, wchar_t *prefix, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); if ( cell.payload.string.character == 0 ) { @@ -52,7 +52,7 @@ void dump_string_cell( FILE * output, wchar_t *prefix, /** * dump the object at this cons_pointer to this output stream. */ -void dump_object( FILE * output, struct cons_pointer pointer ) { +void dump_object( URL_FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); fwprintf( output, L"\t%4.4s (%d) at page %d, offset %d count %u\n", @@ -89,7 +89,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { } break; case LAMBDATV: - fwprintf( output, L"\t\tLambda cell;\n\t\t args: " ); + fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); print( output, cell.payload.lambda.args ); fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); @@ -98,7 +98,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case NILTV: break; case NLAMBDATV: - fwprintf( output, L"\t\tNlambda cell; \n\t\targs: " ); + fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); print( output, cell.payload.lambda.args ); fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); diff --git a/src/memory/dump.h b/src/memory/dump.h index ec8928e..f8ef75f 100644 --- a/src/memory/dump.h +++ b/src/memory/dump.h @@ -20,6 +20,6 @@ #define __dump_h -void dump_object( FILE * output, struct cons_pointer pointer ); +void dump_object( URL_FILE * output, struct cons_pointer pointer ); #endif diff --git a/src/memory/stack.c b/src/memory/stack.c index cf68701..b2585c7 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -241,7 +241,7 @@ void free_stack_frame( struct stack_frame *frame ) { * @param output the stream * @param frame_pointer the pointer to the frame */ -void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { +void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { struct stack_frame *frame = get_stack_frame( frame_pointer ); if ( frame != NULL ) { @@ -265,7 +265,7 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { } } -void dump_stack_trace( FILE * output, struct cons_pointer pointer ) { +void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { print( output, pointer2cell( pointer ).payload.exception.message ); fputws( L"\n", output ); diff --git a/src/memory/stack.h b/src/memory/stack.h index 11763b2..0ea903c 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -47,9 +47,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, void free_stack_frame( struct stack_frame *frame ); -void dump_frame( FILE * output, struct cons_pointer pointer ); +void dump_frame( URL_FILE * output, struct cons_pointer pointer ); -void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer ); +void dump_stack_trace( URL_FILE * output, struct cons_pointer frame_pointer ); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); diff --git a/src/ops/io.c b/src/ops/io.c new file mode 100644 index 0000000..ccd0af5 --- /dev/null +++ b/src/ops/io.c @@ -0,0 +1,8 @@ +/* + * io.c + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ diff --git a/src/ops/lispops.c b/src/ops/lispops.c index c80d965..9448c55 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -839,7 +839,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, #ifdef DEBUG debug_print( L"entering lisp_read\n", DEBUG_IO ); #endif - FILE *input = stdin; + URL_FILE *input = stdin; struct cons_pointer in_stream = readp( frame->arg[0] ) ? frame->arg[0] : get_default_stream( true, env ); @@ -922,7 +922,7 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { debug_print( L"Entering print\n", DEBUG_IO ); struct cons_pointer result = NIL; - FILE *output = stdout; + URL_FILE *output = stdout; struct cons_pointer out_stream = writep( frame->arg[1] ) ? frame->arg[1] : get_default_stream( false, env ); @@ -1148,7 +1148,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer input = get_default_stream( true, env ); struct cons_pointer output = get_default_stream( false, env ); - FILE *os = pointer2cell( output ).payload.stream.stream; + URL_FILE *os = pointer2cell( output ).payload.stream.stream; struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; @@ -1282,7 +1282,7 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { debug_print( L"Entering print\n", DEBUG_IO ); - FILE *output = stdout; + URL_FILE *output = stdout; struct cons_pointer out_stream = writep( frame->arg[1] ) ? frame->arg[1] : get_default_stream( false, env ); diff --git a/src/ops/print.c b/src/ops/print.c index 604c07c..d313960 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -34,7 +34,7 @@ int print_use_colours = 0; * onto this `output`; if `pointer` does not indicate a string or symbol, * don't print anything but just return. */ -void print_string_contents( FILE * output, struct cons_pointer pointer ) { +void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { while ( stringp( pointer ) || symbolp( pointer ) ) { struct cons_space_object *cell = &pointer2cell( pointer ); wchar_t c = cell->payload.string.character; @@ -51,7 +51,7 @@ void print_string_contents( FILE * output, struct cons_pointer pointer ) { * the stream at this `output`, prepending and appending double quote * characters. */ -void print_string( FILE * output, struct cons_pointer pointer ) { +void print_string( URL_FILE * output, struct cons_pointer pointer ) { fputwc( btowc( '"' ), output ); print_string_contents( output, pointer ); fputwc( btowc( '"' ), output ); @@ -63,7 +63,7 @@ void print_string( FILE * output, struct cons_pointer pointer ) { * a space character. */ void -print_list_contents( FILE * output, struct cons_pointer pointer, +print_list_contents( URL_FILE * output, struct cons_pointer pointer, bool initial_space ) { struct cons_space_object *cell = &pointer2cell( pointer ); @@ -84,7 +84,7 @@ print_list_contents( FILE * output, struct cons_pointer pointer, } } -void print_list( FILE * output, struct cons_pointer pointer ) { +void print_list( URL_FILE * output, struct cons_pointer pointer ) { if ( print_use_colours ) { fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); } else { @@ -104,7 +104,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) { * Print the cons-space object indicated by `pointer` to the stream indicated * by `output`. */ -struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { +struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); char *buffer; @@ -225,6 +225,6 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { return pointer; } -void println( FILE * output ) { +void println( URL_FILE * output ) { fputws( L"\n", output ); } diff --git a/src/ops/print.h b/src/ops/print.h index 2751032..f59f090 100644 --- a/src/ops/print.h +++ b/src/ops/print.h @@ -14,8 +14,8 @@ #ifndef __print_h #define __print_h -struct cons_pointer print( FILE * output, struct cons_pointer pointer ); -void println( FILE * output ); +struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ); +void println( URL_FILE * output ); extern int print_use_colours; #endif diff --git a/src/ops/read.c b/src/ops/read.c index 4006c99..d2f79c4 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -38,13 +38,13 @@ struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, wint_t initial, + URL_FILE * input, wint_t initial, bool seen_period ); struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, FILE * input, + struct cons_pointer frame_pointer, URL_FILE * input, wint_t initial ); -struct cons_pointer read_string( FILE * input, wint_t initial ); -struct cons_pointer read_symbol( FILE * input, wint_t initial ); +struct cons_pointer read_string( URL_FILE * input, wint_t initial ); +struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ); /** * quote reader macro in C (!) @@ -61,7 +61,7 @@ struct cons_pointer c_quote( struct cons_pointer arg ) { */ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, wint_t initial ) { + URL_FILE * input, wint_t initial ) { debug_print( L"entering read_continuation\n", DEBUG_IO ); struct cons_pointer result = NIL; @@ -129,6 +129,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, } } break; + //case ':': reserved for keywords and paths default: if ( iswdigit( c ) ) { result = @@ -158,7 +159,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, */ struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, + URL_FILE * input, wint_t initial, bool seen_period ) { debug_print( L"entering read_number\n", DEBUG_IO ); @@ -267,7 +268,7 @@ struct cons_pointer read_number( struct stack_frame *frame, */ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, wint_t initial ) { + URL_FILE * input, wint_t initial ) { struct cons_pointer result = NIL; if ( initial != ')' ) { debug_printf( DEBUG_IO, @@ -293,7 +294,7 @@ struct cons_pointer read_list( struct stack_frame *frame, * so delimited in which case it may not contain whitespace (unless escaped) * but may contain a double quote character (probably not a good idea!) */ -struct cons_pointer read_string( FILE * input, wint_t initial ) { +struct cons_pointer read_string( URL_FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; switch ( initial ) { @@ -315,7 +316,7 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { return result; } -struct cons_pointer read_symbol( FILE * input, wint_t initial ) { +struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; switch ( initial ) { @@ -331,7 +332,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { break; case ')': /* - * symbols may not include right-parenthesis + * symbols may not include right-parenthesis; */ result = NIL; /* @@ -367,6 +368,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input ) { + URL_FILE * input ) { return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); } diff --git a/src/ops/read.h b/src/ops/read.h index c6dbba3..a1674d6 100644 --- a/src/ops/read.h +++ b/src/ops/read.h @@ -15,6 +15,6 @@ * read the next object on this input stream and return a cons_pointer to it. */ struct cons_pointer read( struct stack_frame *frame, - struct cons_pointer frame_pointer, FILE * input ); + struct cons_pointer frame_pointer, URL_FILE * input ); #endif diff --git a/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh index 5615871..d556e71 100755 --- a/unit-tests/bignum-print.sh +++ b/unit-tests/bignum-print.sh @@ -18,17 +18,6 @@ else exit 1 fi -echo -n "checking no bignum was created: " -grep -v 'BIGNUM!' psse.log > /dev/null -if [ $? -eq "0" ] -then - echo "OK" -else - echo "Fail" - exit 1 -fi - - ##################################################################### # right on the boundary @@ -48,17 +37,6 @@ else exit 1 fi -echo -n "checking no bignum was created: " -grep -v 'BIGNUM!' psse.log > /dev/null -if [ $? -eq "0" ] -then - echo "OK" -else - echo "Fail" - exit 1 -fi - - ##################################################################### # definitely a bignum @@ -79,16 +57,10 @@ else fi -echo -n "checking a bignum was created: " -grep 'BIGNUM!' psse.log > /dev/null -if [ $? -eq "0" ] -then - echo "OK" -else - echo "Fail" - exit 1 -fi - +# Currently failing from here on, but it's failing in read because of +# the multiply bug. We know printing blows up at the 3 cell boundary +# because `lisp/scratchpad2.lisp` constructs a 3 cell bignum by +# repeated addition. ##################################################################### # Just on the three cell boundary expected='1329227995784915872903807060280344576' @@ -103,7 +75,7 @@ if [ "${expected}" = "${actual}" ] then echo "OK" else - echo "Fail: expected '${expected}', got '${actual}'" + echo "Fail: expected '${expected}', \n got '${actual}'" exit 1 fi diff --git a/unit-tests/string-cons.sh b/unit-tests/string-cons.sh old mode 100644 new mode 100755 diff --git a/unit-tests/wide-character.sh b/unit-tests/wide-character.sh new file mode 100755 index 0000000..d56544e --- /dev/null +++ b/unit-tests/wide-character.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +expected='"λάμ(β)δα"' +actual=`echo $expected | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From b8f241c2c51ca00f981e42a3539da3a65dbcbd7d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 27 Jan 2019 12:23:51 +0000 Subject: [PATCH 041/101] Progress, not working --- src/init.c | 4 +-- src/io/fopen.c | 48 +++++++++++++++++++++++++++--------- src/io/fopen.h | 16 ++++++++++-- src/memory/consspaceobject.h | 1 - 4 files changed, 52 insertions(+), 17 deletions(-) diff --git a/src/init.c b/src/init.c index e8a33a9..8f278bf 100644 --- a/src/init.c +++ b/src/init.c @@ -130,7 +130,7 @@ int main( int argc, char *argv[] ) { fwide( stdin, 1 ); fwide( stdout, 1 ); fwide( stderr, 1 ); - fwide( sink, 1 ); + fwide( sink->handle.file, 1 ); bind_value( L"*in*", make_read_stream( file_to_url_file(stdin) ) ); bind_value( L"*out*", make_write_stream( file_to_url_file(stdout) ) ); bind_value( L"*log*", make_write_stream( file_to_url_file(stderr) ) ); @@ -200,7 +200,7 @@ int main( int argc, char *argv[] ) { debug_dump_object( oblist, DEBUG_BOOTSTRAP ); if ( dump_at_end ) { - dump_pages( stdout ); + dump_pages( file_to_url_file(stdout) ); } return ( 0 ); diff --git a/src/io/fopen.c b/src/io/fopen.c index d13250f..14c95e8 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -3,8 +3,11 @@ * * adapted from https://curl.haxx.se/libcurl/c/fopen.html. * + * Modifications to read/write wide character streams by + * Simon Brooke. + * * Copyright (c) 2003, 2017 Simtec Electronics - * Some portions (c) 2017 Simon Brooke + * Some portions (c) 2019 Simon Brooke * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions @@ -41,11 +44,6 @@ #include #include -/* - * wide characters - */ -#include -#include #include "fopen.h" @@ -177,8 +175,11 @@ static int use_buffer(URL_FILE *file, size_t want) /* ditch buffer - write will recreate */ free(file->buffer); file->buffer = NULL; + free(file->wide_buffer); + file->wide_buffer = NULL; file->buffer_pos = 0; file->buffer_len = 0; + file->wide_cursor = 0; } else { /* move rest down make it available for later */ @@ -187,6 +188,7 @@ static int use_buffer(URL_FILE *file, size_t want) (file->buffer_pos - want)); file->buffer_pos -= want; + // TODO: something to adjust the wide_cursor } return 0; } @@ -424,18 +426,40 @@ URL_FILE * file_to_url_file( FILE* f) { return result; } - -wint_t url_fgetwc(URL_FILE *file) { +/** + * get one wide character from the buffer. + * + * @param file the stream to read from; + * @return the next wide character on the stream, or zero if no more. + */ +wint_t url_fgetwc(URL_FILE *input) { wint_t result = 0; - switch(file->type) { + switch(input->type) { case CFTYPE_FILE: - fwide( file->handle.file, 1 ); /* wide characters */ - result = fgetc(file->handle.file); /* passthrough */ + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetc(input->handle.file); /* passthrough */ break; case CFTYPE_CURL: - url_fread(&result, sizeof(wint_t), 1, file); + if (input.buffer_len != 0) { + if ( input.wide_buffer == NULL) { + /* not initialised */ + input.wide_buffer = calloc( input.buffer_len, sizeof(wint_t)); + } + + size_t len = wcslen(input.wide_buffer); + if (input.still_running || + len == 0 || + len >= input.wide_cursor) { + /* refresh the wide buffer */ + mbstowcs(input.wide_buffer, input.buffer, input.buffer_pos); + } + + result = input.wide_buffer[input.wide_cursor] ++; + + /* do something to fread (advance) one utf character */ + } break; } diff --git a/src/io/fopen.h b/src/io/fopen.h index 9874ac7..83ea5a8 100644 --- a/src/io/fopen.h +++ b/src/io/fopen.h @@ -3,8 +3,12 @@ * * adapted from https://curl.haxx.se/libcurl/c/fopen.html. * + * + * Modifications to read/write wide character streams by + * Simon Brooke. + * * Copyright (c) 2003, 2017 Simtec Electronics - * Some portions (c) 2017 Simon Brooke + * Some portions (c) 2019 Simon Brooke * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions @@ -33,6 +37,12 @@ #ifndef __fopen_h #define __fopen_h +#include +/* + * wide characters + */ +#include +#include enum fcurl_type_e { CFTYPE_NONE = 0, @@ -49,8 +59,10 @@ struct fcurl_data } handle; /* handle */ char *buffer; /* buffer to store cached data*/ - size_t buffer_len; /* currently allocated buffers length */ + wchar_t *wide_buffer; /* wide character buffer */ + size_t buffer_len; /* currently allocated buffer's length */ size_t buffer_pos; /* end of data in buffer*/ + size_t wide_cursor; /* cursor into the wide buffer */ int still_running; /* Is background url fetch still in progress */ }; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 8db8099..b3f587c 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -16,7 +16,6 @@ */ #include #include -#include #include "fopen.h" From 0e11adea1cfdafe97f4b0ebe5e8ce74e956132a5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 27 Jan 2019 17:22:13 +0000 Subject: [PATCH 042/101] Compiles, most tests break --- src/arith/peano.c | 129 +++--- src/arith/peano.h | 14 +- src/arith/ratio.c | 16 +- src/debug.c | 9 +- src/init.c | 19 +- src/io/fopen.c | 832 ++++++++++++++++------------------- src/io/fopen.h | 55 +-- src/io/io.c | 177 ++++++++ src/io/io.h | 28 ++ src/memory/conspage.c | 2 +- src/memory/consspaceobject.h | 4 + src/memory/dump.c | 113 ++--- src/memory/stack.c | 24 +- src/memory/vectorspace.c | 5 +- src/ops/equal.c | 4 +- src/ops/intern.c | 8 +- src/ops/intern.h | 6 +- src/ops/io.c | 8 - src/ops/lispops.c | 56 ++- src/ops/print.c | 50 +-- src/ops/read.c | 54 ++- src/ops/read.h | 3 +- 22 files changed, 902 insertions(+), 714 deletions(-) create mode 100644 src/io/io.c create mode 100644 src/io/io.h delete mode 100644 src/ops/io.c diff --git a/src/arith/peano.c b/src/arith/peano.c index 7db638a..8e4cb43 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -43,13 +43,14 @@ bool zerop( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { - case INTEGERTV: { + case INTEGERTV:{ do { - debug_print(L"zerop: ", DEBUG_ARITH); - debug_dump_object(arg, DEBUG_ARITH); - result = (pointer2cell( arg ).payload.integer.value == 0); - arg = pointer2cell(arg).payload.integer.more; - } while (result && integerp(arg)); + debug_print( L"zerop: ", DEBUG_ARITH ); + debug_dump_object( arg, DEBUG_ARITH ); + result = + ( pointer2cell( arg ).payload.integer.value == 0 ); + arg = pointer2cell( arg ).payload.integer.more; + } while ( result && integerp( arg ) ); } break; case RATIOTV: @@ -66,7 +67,7 @@ bool zerop( struct cons_pointer arg ) { /** * does this `arg` point to a negative number? */ -bool is_negative( struct cons_pointer arg) { +bool is_negative( struct cons_pointer arg ) { bool result = false; struct cons_space_object cell = pointer2cell( arg ); @@ -85,27 +86,31 @@ bool is_negative( struct cons_pointer arg) { return result; } -struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg) { - struct cons_pointer result = NIL; +struct cons_pointer absolute( struct cons_pointer frame_pointer, + struct cons_pointer arg ) { + struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); - if ( is_negative( arg)) { - switch ( cell.tag.value ) { - case INTEGERTV: - result = make_integer(llabs(cell.payload.integer.value), cell.payload.integer.more); - break; - case RATIOTV: - result = make_ratio(frame_pointer, - absolute(frame_pointer, cell.payload.ratio.dividend), - cell.payload.ratio.divisor); - break; - case REALTV: - result = make_real( 0 - cell.payload.real.value ); - break; + if ( is_negative( arg ) ) { + switch ( cell.tag.value ) { + case INTEGERTV: + result = + make_integer( llabs( cell.payload.integer.value ), + cell.payload.integer.more ); + break; + case RATIOTV: + result = make_ratio( frame_pointer, + absolute( frame_pointer, + cell.payload.ratio.dividend ), + cell.payload.ratio.divisor ); + break; + case REALTV: + result = make_real( 0 - cell.payload.real.value ); + break; + } } - } - return result; + return result; } /** @@ -126,7 +131,7 @@ long double to_long_double( struct cons_pointer arg ) { switch ( cell.tag.value ) { case INTEGERTV: // obviously, this doesn't work for bignums - result = (long double)cell.payload.integer.value; + result = ( long double ) cell.payload.integer.value; // sadly, this doesn't work at all. // result += 1.0; // for (bool is_first = false; integerp(arg); is_first = true) { @@ -141,8 +146,8 @@ long double to_long_double( struct cons_pointer arg ) { // } break; case RATIOTV: - result = to_long_double(cell.payload.ratio.dividend) / - to_long_double(cell.payload.ratio.divisor); + result = to_long_double( cell.payload.ratio.dividend ) / + to_long_double( cell.payload.ratio.divisor ); break; case REALTV: result = cell.payload.real.value; @@ -203,9 +208,9 @@ int64_t to_long_int( struct cons_pointer arg ) { * argument, or NIL if it was not a number. */ struct cons_pointer lisp_absolute( struct stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { - return absolute( frame_pointer, frame->arg[0]); + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return absolute( frame_pointer, frame->arg[0] ); } /** @@ -388,10 +393,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( make_cons( - c_string_to_lisp_string( L"Cannot multiply: argument 2 is not a number: " ), - c_type(arg2)), - frame_pointer ); + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number: " ), + c_type( arg2 ) ), + frame_pointer ); break; } break; @@ -415,11 +422,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( - make_cons(c_string_to_lisp_string - ( L"Cannot multiply: argument 2 is not a number" ), - c_type(arg2)), - frame_pointer ); + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number" ), + c_type( arg2 ) ), + frame_pointer ); } break; case REALTV: @@ -428,11 +436,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( - make_cons(c_string_to_lisp_string - ( L"Cannot multiply: argument 1 is not a number" ), - c_type(arg1)), - frame_pointer ); + result = throw_exception( make_cons( c_string_to_lisp_string + ( L"Cannot multiply: argument 1 is not a number" ), + c_type( arg1 ) ), + frame_pointer ); break; } } @@ -460,30 +467,27 @@ struct cons_pointer lisp_multiply( struct struct cons_pointer result = make_integer( 1, NIL ); struct cons_pointer tmp; - for ( int i = 0; - i < args_in_frame - && !nilp( frame->arg[i] ) - && !exceptionp( result ); - i++ ) { - debug_print( L"lisp_multiply: accumulator = ",DEBUG_ARITH); - debug_print_object(result, DEBUG_ARITH); - debug_print( L"; arg = ", DEBUG_ARITH); - debug_print_object(frame->arg[i], DEBUG_ARITH); - debug_println( DEBUG_ARITH); + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) + && !exceptionp( result ); i++ ) { + debug_print( L"lisp_multiply: accumulator = ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"; arg = ", DEBUG_ARITH ); + debug_print_object( frame->arg[i], DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); - multiply_one_arg(frame->arg[i]); + multiply_one_arg( frame->arg[i] ); } struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { - multiply_one_arg(c_car( more )); + multiply_one_arg( c_car( more ) ); more = c_cdr( more ); } - debug_print( L"lisp_multiply returning: ",DEBUG_ARITH); - debug_print_object(result, DEBUG_ARITH); - debug_println(DEBUG_ARITH); + debug_print( L"lisp_multiply returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); return result; } @@ -538,9 +542,10 @@ struct cons_pointer negative( struct cons_pointer frame, * was not. */ struct cons_pointer lisp_is_negative( struct stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { - return is_negative(frame->arg[0]) ? TRUE : NIL; + *frame, + struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return is_negative( frame->arg[0] ) ? TRUE : NIL; } diff --git a/src/arith/peano.h b/src/arith/peano.h index 7164a24..7ad7662 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -22,23 +22,25 @@ bool zerop( struct cons_pointer arg ); struct cons_pointer negative( struct cons_pointer frame, struct cons_pointer arg ); -bool is_negative( struct cons_pointer arg); +bool is_negative( struct cons_pointer arg ); -struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg); +struct cons_pointer absolute( struct cons_pointer frame_pointer, + struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg ); struct cons_pointer lisp_absolute( struct stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ); + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ); struct cons_pointer lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_is_negative( struct stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ); + *frame, + struct cons_pointer frame_pointer, struct + cons_pointer env ); struct cons_pointer lisp_multiply( struct stack_frame *frame, diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 784e71e..65b09da 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -55,10 +55,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg ) ) { int64_t ddrv = - pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload. - integer.value, drrv = - pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload. - integer.value, gcd = greatest_common_divisor( ddrv, drrv ); + pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). + payload.integer.value, drrv = + pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). + payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); if ( gcd > 1 ) { if ( drrv / gcd == 1 ) { @@ -199,10 +199,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload.ratio. - divisor, - pointer2cell( arg2 ).payload.ratio. - dividend ), result = + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), result = multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); diff --git a/src/debug.c b/src/debug.c index d694827..14881f9 100644 --- a/src/debug.c +++ b/src/debug.c @@ -19,6 +19,7 @@ #include #include "consspaceobject.h" +#include "fopen.h" #include "debug.h" #include "dump.h" #include "print.h" @@ -104,8 +105,10 @@ void debug_printf( int level, wchar_t *format, ... ) { void debug_print_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG if ( level & verbosity ) { + URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - print( stderr, pointer ); + print( ustderr, pointer ); + free( ustderr ); } #endif } @@ -116,8 +119,10 @@ 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 ) { + URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - dump_object( stderr, pointer ); + dump_object( ustderr, pointer ); + free( ustderr ); } #endif } diff --git a/src/init.c b/src/init.c index 8f278bf..a45e685 100644 --- a/src/init.c +++ b/src/init.c @@ -21,6 +21,7 @@ #include "consspaceobject.h" #include "debug.h" #include "intern.h" +#include "io.h" #include "lispops.h" #include "peano.h" #include "print.h" @@ -82,7 +83,7 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; - setlocale(LC_ALL, ""); + setlocale( LC_ALL, "" ); while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { @@ -131,9 +132,9 @@ int main( int argc, char *argv[] ) { fwide( stdout, 1 ); fwide( stderr, 1 ); fwide( sink->handle.file, 1 ); - bind_value( L"*in*", make_read_stream( file_to_url_file(stdin) ) ); - bind_value( L"*out*", make_write_stream( file_to_url_file(stdout) ) ); - bind_value( L"*log*", make_write_stream( file_to_url_file(stderr) ) ); + bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ) ) ); + bind_value( L"*out*", make_write_stream( file_to_url_file( stdout ) ) ); + bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ) ) ); bind_value( L"*sink*", make_write_stream( sink ) ); /* @@ -151,6 +152,7 @@ int main( int argc, char *argv[] ) { bind_function( L"assoc", &lisp_assoc ); bind_function( L"car", &lisp_car ); bind_function( L"cdr", &lisp_cdr ); + bind_function( L"close", &lisp_close ); bind_function( L"cons", &lisp_cons ); bind_function( L"divide", &lisp_divide ); bind_function( L"eq", &lisp_eq ); @@ -159,12 +161,15 @@ int main( int argc, char *argv[] ) { bind_function( L"exception", &lisp_exception ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); - bind_function( L"negative?", &lisp_is_negative); + bind_function( L"negative?", &lisp_is_negative ); bind_function( L"read", &lisp_read ); bind_function( L"repl", &lisp_repl ); bind_function( L"oblist", &lisp_oblist ); + bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); + bind_function( L"read", &lisp_read ); + bind_function( L"read_char", &lisp_read_char ); bind_function( L"reverse", &lisp_reverse ); bind_function( L"set", &lisp_set ); bind_function( L"source", &lisp_source ); @@ -183,7 +188,7 @@ int main( int argc, char *argv[] ) { */ bind_special( L"cond", &lisp_cond ); bind_special( L"lambda", &lisp_lambda ); - bind_special( L"\u03bb", &lisp_lambda ); // λ + bind_special( L"\u03bb", &lisp_lambda ); // λ bind_special( L"nlambda", &lisp_nlambda ); bind_special( L"n\u03bb", &lisp_nlambda ); bind_special( L"progn", &lisp_progn ); @@ -200,7 +205,7 @@ int main( int argc, char *argv[] ) { debug_dump_object( oblist, DEBUG_BOOTSTRAP ); if ( dump_at_end ) { - dump_pages( file_to_url_file(stdout) ); + dump_pages( file_to_url_file( stdout ) ); } return ( 0 ); diff --git a/src/io/fopen.c b/src/io/fopen.c index 14c95e8..499fada 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -6,6 +6,9 @@ * Modifications to read/write wide character streams by * Simon Brooke. * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * * Copyright (c) 2003, 2017 Simtec Electronics * Some portions (c) 2019 Simon Brooke * @@ -34,14 +37,13 @@ * This example requires libcurl 7.9.7 or later. */ - +#include #include +#include #include #ifndef WIN32 -# include +#include #endif -#include -#include #include @@ -51,362 +53,376 @@ static CURLM *multi_handle; /* curl calls this routine to get more data */ -static size_t write_callback(char *buffer, - size_t size, - size_t nitems, - void *userp) -{ - char *newbuff; - size_t rembuff; +static size_t write_callback( char *buffer, + size_t size, size_t nitems, void *userp ) { + char *newbuff; + size_t rembuff; - URL_FILE *url = (URL_FILE *)userp; - size *= nitems; + URL_FILE *url = ( URL_FILE * ) userp; + size *= nitems; - rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ - if(size > rembuff) { - /* not enough space in buffer */ - newbuff = realloc(url->buffer, url->buffer_len + (size - rembuff)); - if(newbuff == NULL) { - fprintf(stderr, "callback buffer grow failed\n"); - size = rembuff; + if ( size > rembuff ) { + /* not enough space in buffer */ + newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) ); + if ( newbuff == NULL ) { + fprintf( stderr, "callback buffer grow failed\n" ); + size = rembuff; + } else { + /* realloc succeeded increase buffer size */ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } } - else { - /* realloc succeeded increase buffer size*/ - url->buffer_len += size - rembuff; - url->buffer = newbuff; - } - } - memcpy(&url->buffer[url->buffer_pos], buffer, size); - url->buffer_pos += size; + memcpy( &url->buffer[url->buffer_pos], buffer, size ); + url->buffer_pos += size; - return size; + return size; } /* use to attempt to fill the read buffer up to requested number of bytes */ -static int fill_buffer(URL_FILE *file, size_t want) -{ - fd_set fdread; - fd_set fdwrite; - fd_set fdexcep; - struct timeval timeout; - int rc; - CURLMcode mc; /* curl_multi_fdset() return code */ +static int fill_buffer( URL_FILE * file, size_t want ) { + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ - /* only attempt to fill buffer if transactions still running and buffer - * doesn't exceed required size already - */ - if((!file->still_running) || (file->buffer_pos > want)) - return 0; + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if ( ( !file->still_running ) || ( file->buffer_pos > want ) ) + return 0; - /* attempt to fill buffer */ - do { - int maxfd = -1; - long curl_timeo = -1; + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; - FD_ZERO(&fdread); - FD_ZERO(&fdwrite); - FD_ZERO(&fdexcep); + FD_ZERO( &fdread ); + FD_ZERO( &fdwrite ); + FD_ZERO( &fdexcep ); - /* set a suitable timeout to fail on */ - timeout.tv_sec = 60; /* 1 minute */ - timeout.tv_usec = 0; + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; - curl_multi_timeout(multi_handle, &curl_timeo); - if(curl_timeo >= 0) { - timeout.tv_sec = curl_timeo / 1000; - if(timeout.tv_sec > 1) - timeout.tv_sec = 1; - else - timeout.tv_usec = (curl_timeo % 1000) * 1000; - } + curl_multi_timeout( multi_handle, &curl_timeo ); + if ( curl_timeo >= 0 ) { + timeout.tv_sec = curl_timeo / 1000; + if ( timeout.tv_sec > 1 ) + timeout.tv_sec = 1; + else + timeout.tv_usec = ( curl_timeo % 1000 ) * 1000; + } - /* get file descriptors from the transfers */ - mc = curl_multi_fdset(multi_handle, &fdread, &fdwrite, &fdexcep, &maxfd); + /* get file descriptors from the transfers */ + mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep, + &maxfd ); - if(mc != CURLM_OK) { - fprintf(stderr, "curl_multi_fdset() failed, code %d.\n", mc); - break; - } + if ( mc != CURLM_OK ) { + fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc ); + break; + } - /* On success the value of maxfd is guaranteed to be >= -1. We call - select(maxfd + 1, ...); specially in case of (maxfd == -1) there are - no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- - to sleep 100ms, which is the minimum suggested value in the - curl_multi_fdset() doc. */ + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ - if(maxfd == -1) { + if ( maxfd == -1 ) { #ifdef _WIN32 - Sleep(100); - rc = 0; + Sleep( 100 ); + rc = 0; #else - /* Portable sleep for platforms other than Windows. */ - struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ - rc = select(0, NULL, NULL, NULL, &wait); + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select( 0, NULL, NULL, NULL, &wait ); #endif - } - else { - /* Note that on some platforms 'timeout' may be modified by select(). - If you need access to the original value save a copy beforehand. */ - rc = select(maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout); - } + } else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout ); + } - switch(rc) { - case -1: - /* select error */ - break; + switch ( rc ) { + case -1: + /* select error */ + break; - case 0: - default: - /* timeout or readable/writable sockets */ - curl_multi_perform(multi_handle, &file->still_running); - break; - } - } while(file->still_running && (file->buffer_pos < want)); - return 1; + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform( multi_handle, &file->still_running ); + break; + } + } while ( file->still_running && ( file->buffer_pos < want ) ); + + return 1; } /* use to remove want bytes from the front of a files buffer */ -static int use_buffer(URL_FILE *file, size_t want) -{ - /* sort out buffer */ - if((file->buffer_pos - want) <= 0) { - /* ditch buffer - write will recreate */ - free(file->buffer); - file->buffer = NULL; - free(file->wide_buffer); - file->wide_buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; - file->wide_cursor = 0; - } - else { - /* move rest down make it available for later */ - memmove(file->buffer, - &file->buffer[want], - (file->buffer_pos - want)); +static int use_buffer( URL_FILE * file, size_t want ) { + /* sort out buffer */ + if ( ( file->buffer_pos - want ) <= 0 ) { + /* ditch buffer - write will recreate */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } else { + /* move rest down make it available for later */ + memmove( file->buffer, + &file->buffer[want], ( file->buffer_pos - want ) ); - file->buffer_pos -= want; - // TODO: something to adjust the wide_cursor - } - return 0; -} - -URL_FILE *url_fopen(const char *url, const char *operation) -{ - /* this code could check for URLs or types in the 'url' and - basically use the real fopen() for standard files */ - - URL_FILE *file; - (void)operation; - - file = calloc(1, sizeof(URL_FILE)); - if(!file) - return NULL; - - file->handle.file = fopen(url, operation); - if(file->handle.file) - file->type = CFTYPE_FILE; /* marked as URL */ - - else { - file->type = CFTYPE_CURL; /* marked as URL */ - file->handle.curl = curl_easy_init(); - - curl_easy_setopt(file->handle.curl, CURLOPT_URL, url); - curl_easy_setopt(file->handle.curl, CURLOPT_WRITEDATA, file); - curl_easy_setopt(file->handle.curl, CURLOPT_VERBOSE, 0L); - curl_easy_setopt(file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback); - - if(!multi_handle) - multi_handle = curl_multi_init(); - - curl_multi_add_handle(multi_handle, file->handle.curl); - - /* lets start the fetch */ - curl_multi_perform(multi_handle, &file->still_running); - - if((file->buffer_pos == 0) && (!file->still_running)) { - /* if still_running is 0 now, we should return NULL */ - - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle(multi_handle, file->handle.curl); - - /* cleanup */ - curl_easy_cleanup(file->handle.curl); - - free(file); - - file = NULL; + file->buffer_pos -= want; } - } - return file; + return 0; } -int url_fclose(URL_FILE *file) -{ - int ret = 0;/* default is good return */ +/** + * consume one wide character on the buffer of this file. + * + * @param file the url or file from which the character is consumed. + */ +static int use_one_wide( URL_FILE * file ) { + int c = ( int ) file->buffer[file->buffer_pos]; + size_t count = 0; - switch(file->type) { - case CFTYPE_FILE: - ret = fclose(file->handle.file); /* passthrough */ - break; - - case CFTYPE_CURL: - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle(multi_handle, file->handle.curl); - - /* cleanup */ - curl_easy_cleanup(file->handle.curl); - break; - - default: /* unknown or supported type - oh dear */ - ret = EOF; - errno = EBADF; - break; - } - - free(file->buffer);/* free any allocated buffer space */ - free(file); - - return ret; -} - -int url_feof(URL_FILE *file) -{ - int ret = 0; - - switch(file->type) { - case CFTYPE_FILE: - ret = feof(file->handle.file); - break; - - case CFTYPE_CURL: - if((file->buffer_pos == 0) && (!file->still_running)) - ret = 1; - break; - - default: /* unknown or supported type - oh dear */ - ret = -1; - errno = EBADF; - break; - } - return ret; -} - -size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file) -{ - size_t want; - - switch(file->type) { - case CFTYPE_FILE: - want = fread(ptr, size, nmemb, file->handle.file); - break; - - case CFTYPE_CURL: - want = nmemb * size; - - fill_buffer(file, want); - - /* check if there's data in the buffer - if not fill_buffer() - * either errored or EOF */ - if(!file->buffer_pos) - return 0; - - /* ensure only available data is considered */ - if(file->buffer_pos < want) - want = file->buffer_pos; - - /* xfer data to caller */ - memcpy(ptr, file->buffer, want); - - use_buffer(file, want); - - want = want / size; /* number of items */ - break; - - default: /* unknown or supported type - oh dear */ - want = 0; - errno = EBADF; - break; - - } - return want; -} - -char *url_fgets(char *ptr, size_t size, URL_FILE *file) -{ - size_t want = size - 1;/* always need to leave room for zero termination */ - size_t loop; - - switch(file->type) { - case CFTYPE_FILE: - ptr = fgets(ptr, (int)size, file->handle.file); - break; - - case CFTYPE_CURL: - fill_buffer(file, want); - - /* check if there's data in the buffer - if not fill either errored or - * EOF */ - if(!file->buffer_pos) - return NULL; - - /* ensure only available data is considered */ - if(file->buffer_pos < want) - want = file->buffer_pos; - - /*buffer contains data */ - /* look for newline or eof */ - for(loop = 0; loop < want; loop++) { - if(file->buffer[loop] == '\n') { - want = loop + 1;/* include newline */ - break; - } + /* The value of each individual byte indicates its UTF-8 function, as follows: + * + * 00 to 7F hex (0 to 127): first and only byte of a sequence. + * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. + * C2 to DF hex (194 to 223): first byte of a two-byte sequence. + * E0 to EF hex (224 to 239): first byte of a three-byte sequence. + * F0 to FF hex (240 to 255): first byte of a four-byte sequence. + */ + if ( c <= '0x07' ) { + count = 1; + } else if ( c >= '0xc2' && c <= '0xdf' ) { + count = 2; + } else if ( c >= '0xe0' && c <= '0xef' ) { + count = 3; + } else if ( c >= '0xf0' && c <= '0xff' ) { + count = 4; } - /* xfer data to caller */ - memcpy(ptr, file->buffer, want); - ptr[want] = 0;/* always null terminate */ - - use_buffer(file, want); - - break; - - default: /* unknown or supported type - oh dear */ - ptr = NULL; - errno = EBADF; - break; - } - - return ptr;/*success */ + return use_buffer( file, c ); } -void url_rewind(URL_FILE *file) -{ - switch(file->type) { - case CFTYPE_FILE: - rewind(file->handle.file); /* passthrough */ - break; +URL_FILE *url_fopen( const char *url, const char *operation ) { + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ - case CFTYPE_CURL: - /* halt transaction */ - curl_multi_remove_handle(multi_handle, file->handle.curl); + URL_FILE *file; + ( void ) operation; - /* restart */ - curl_multi_add_handle(multi_handle, file->handle.curl); + file = calloc( 1, sizeof( URL_FILE ) ); + if ( !file ) + return NULL; - /* ditch buffer - write will recreate - resets stream pos*/ - free(file->buffer); - file->buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; + file->handle.file = fopen( url, operation ); + if ( file->handle.file ) + file->type = CFTYPE_FILE; /* marked as URL */ - break; + else { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init( ); - default: /* unknown or supported type - oh dear */ - break; - } + curl_easy_setopt( file->handle.curl, CURLOPT_URL, url ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file ); + curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION, + write_callback ); + + if ( !multi_handle ) + multi_handle = curl_multi_init( ); + + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* lets start the fetch */ + curl_multi_perform( multi_handle, &file->still_running ); + + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + + free( file ); + + file = NULL; + } + } + return file; +} + +int url_fclose( URL_FILE * file ) { + int ret = 0; /* default is good return */ + + switch ( file->type ) { + case CFTYPE_FILE: + ret = fclose( file->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + break; + + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; + } + + free( file->buffer ); /* free any allocated buffer space */ + free( file ); + + return ret; +} + +int url_feof( URL_FILE * file ) { + int ret = 0; + + switch ( file->type ) { + case CFTYPE_FILE: + ret = feof( file->handle.file ); + break; + + case CFTYPE_CURL: + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) + ret = 1; + break; + + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; +} + +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) { + size_t want; + + switch ( file->type ) { + case CFTYPE_FILE: + want = fread( ptr, size, nmemb, file->handle.file ); + break; + + case CFTYPE_CURL: + want = nmemb * size; + + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if ( !file->buffer_pos ) + return 0; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + + use_buffer( file, want ); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; +} + +char *url_fgets( char *ptr, size_t size, URL_FILE * file ) { + size_t want = size - 1; /* always need to leave room for zero termination */ + size_t loop; + + switch ( file->type ) { + case CFTYPE_FILE: + ptr = fgets( ptr, ( int ) size, file->handle.file ); + break; + + case CFTYPE_CURL: + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if ( !file->buffer_pos ) + return NULL; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /*buffer contains data */ + /* look for newline or eof */ + for ( loop = 0; loop < want; loop++ ) { + if ( file->buffer[loop] == '\n' ) { + want = loop + 1; /* include newline */ + break; + } + } + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + ptr[want] = 0; /* always null terminate */ + + use_buffer( file, want ); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr; /*success */ +} + +void url_rewind( URL_FILE * file ) { + switch ( file->type ) { + case CFTYPE_FILE: + rewind( file->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* restart */ + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* ditch buffer - write will recreate - resets stream pos */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + + break; + + default: /* unknown or supported type - oh dear */ + break; + } } /** @@ -415,153 +431,79 @@ void url_rewind(URL_FILE *file) * @param f the file to be wrapped; * @return the new handle, or null if no such handle could be allocated. */ -URL_FILE * file_to_url_file( FILE* f) { - URL_FILE * result = (URL_FILE *)malloc(sizeof(URL_FILE)); +URL_FILE *file_to_url_file( FILE * f ) { + URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) ); - if ( result != NULL) { - result->type = CFTYPE_FILE, - result->handle.file = f; - } + if ( result != NULL ) { + result->type = CFTYPE_FILE, result->handle.file = f; + } - return result; + return result; } + /** * get one wide character from the buffer. * * @param file the stream to read from; * @return the next wide character on the stream, or zero if no more. */ -wint_t url_fgetwc(URL_FILE *input) { - wint_t result = 0; +wint_t url_fgetwc( URL_FILE * input ) { + wint_t result = -1; - switch(input->type) { - case CFTYPE_FILE: - fwide( input->handle.file, 1 ); /* wide characters */ - result = fgetc(input->handle.file); /* passthrough */ - break; + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; - case CFTYPE_CURL: - if (input.buffer_len != 0) { - if ( input.wide_buffer == NULL) { - /* not initialised */ - input.wide_buffer = calloc( input.buffer_len, sizeof(wint_t)); - } + case CFTYPE_CURL:{ + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + char *cbuff = calloc( 5, sizeof( char ) ); - size_t len = wcslen(input.wide_buffer); - if (input.still_running || - len == 0 || - len >= input.wide_cursor) { - /* refresh the wide buffer */ - mbstowcs(input.wide_buffer, input.buffer, input.buffer_pos); - } + url_fread( cbuff, sizeof( char ), 4, input ); + mbstowcs( wbuff, cbuff, 1 ); + result = wbuff[0]; + use_one_wide( input ); - result = input.wide_buffer[input.wide_cursor] ++; - - /* do something to fread (advance) one utf character */ + free( cbuff ); + free( wbuff ); + } + break; + case CFTYPE_NONE: + break; } - break; - } - return result; + return result; } -/* #define FGETSFILE "fgets.test" */ -/* #define FREADFILE "fread.test" */ -/* #define REWINDFILE "rewind.test" */ +wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { + wint_t result = -1; -/* /\* Small main program to retrieve from a url using fgets and fread saving the */ -/* * output to two test files (note the fgets method will corrupt binary files if */ -/* * they contain 0 chars *\/ */ -/* int main(int argc, char *argv[]) */ -/* { */ -/* URL_FILE *handle; */ -/* FILE *outf; */ + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; -/* size_t nread; */ -/* char buffer[256]; */ -/* const char *url; */ + case CFTYPE_CURL:{ + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + char *cbuff = calloc( 5, sizeof( char ) ); -/* if(argc < 2) */ -/* url = "http://192.168.7.3/testfile";/\* default to testurl *\/ */ -/* else */ -/* url = argv[1];/\* use passed url *\/ */ + wbuff[0] = wc; + result = wcstombs( cbuff, wbuff, 1 ); -/* /\* copy from url line by line with fgets *\/ */ -/* outf = fopen(FGETSFILE, "wb+"); */ -/* if(!outf) { */ -/* perror("couldn't open fgets output file\n"); */ -/* return 1; */ -/* } */ + input->buffer_pos -= strlen( cbuff ); -/* handle = url_fopen(url, "r"); */ -/* if(!handle) { */ -/* printf("couldn't url_fopen() %s\n", url); */ -/* fclose(outf); */ -/* return 2; */ -/* } */ + free( cbuff ); + free( wbuff ); -/* while(!url_feof(handle)) { */ -/* url_fgets(buffer, sizeof(buffer), handle); */ -/* fwrite(buffer, 1, strlen(buffer), outf); */ -/* } */ + result = result > 0 ? wc : result; + break; + case CFTYPE_NONE: + break; + } + } -/* url_fclose(handle); */ - -/* fclose(outf); */ - - -/* /\* Copy from url with fread *\/ */ -/* outf = fopen(FREADFILE, "wb+"); */ -/* if(!outf) { */ -/* perror("couldn't open fread output file\n"); */ -/* return 1; */ -/* } */ - -/* handle = url_fopen("testfile", "r"); */ -/* if(!handle) { */ -/* printf("couldn't url_fopen() testfile\n"); */ -/* fclose(outf); */ -/* return 2; */ -/* } */ - -/* do { */ -/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ -/* fwrite(buffer, 1, nread, outf); */ -/* } while(nread); */ - -/* url_fclose(handle); */ - -/* fclose(outf); */ - - -/* /\* Test rewind *\/ */ -/* outf = fopen(REWINDFILE, "wb+"); */ -/* if(!outf) { */ -/* perror("couldn't open fread output file\n"); */ -/* return 1; */ -/* } */ - -/* handle = url_fopen("testfile", "r"); */ -/* if(!handle) { */ -/* printf("couldn't url_fopen() testfile\n"); */ -/* fclose(outf); */ -/* return 2; */ -/* } */ - -/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ -/* fwrite(buffer, 1, nread, outf); */ -/* url_rewind(handle); */ - -/* buffer[0]='\n'; */ -/* fwrite(buffer, 1, 1, outf); */ - -/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ -/* fwrite(buffer, 1, nread, outf); */ - -/* url_fclose(handle); */ - -/* fclose(outf); */ - -/* return 0;/\* all done *\/ */ -/* } */ + return result; +} diff --git a/src/io/fopen.h b/src/io/fopen.h index 83ea5a8..f952a65 100644 --- a/src/io/fopen.h +++ b/src/io/fopen.h @@ -7,6 +7,9 @@ * Modifications to read/write wide character streams by * Simon Brooke. * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * * Copyright (c) 2003, 2017 Simtec Electronics * Some portions (c) 2019 Simon Brooke * @@ -44,41 +47,41 @@ #include #include +#define url_fwprintf(f, ...) ((f->type = CFTYPE_FILE) ? fwprintf( f->handle.file, __VA_ARGS__) : -1) +#define url_fputws(ws, f) ((f->type = CFTYPE_FILE) ? fputws(ws, f->handle.file) : 0) +#define url_fputwc(wc, f) ((f->type = CFTYPE_FILE) ? fputwc(wc, f->handle.file) : 0) + enum fcurl_type_e { - CFTYPE_NONE = 0, - CFTYPE_FILE = 1, - CFTYPE_CURL = 2 + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 }; -struct fcurl_data -{ - enum fcurl_type_e type; /* type of handle */ - union { - CURL *curl; - FILE *file; - } handle; /* handle */ +struct fcurl_data { + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ - char *buffer; /* buffer to store cached data*/ - wchar_t *wide_buffer; /* wide character buffer */ - size_t buffer_len; /* currently allocated buffer's length */ - size_t buffer_pos; /* end of data in buffer*/ - size_t wide_cursor; /* cursor into the wide buffer */ - int still_running; /* Is background url fetch still in progress */ + char *buffer; /* buffer to store cached data */ + size_t buffer_len; /* currently allocated buffer's length */ + size_t buffer_pos; /* cursor into in buffer */ + int still_running; /* Is background url fetch still in progress */ }; typedef struct fcurl_data URL_FILE; /* exported functions */ -URL_FILE *url_fopen(const char *url, const char *operation); -int url_fclose(URL_FILE *file); -int url_feof(URL_FILE *file); -size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file); -char *url_fgets(char *ptr, size_t size, URL_FILE *file); -void url_rewind(URL_FILE *file); - -wint_t url_fgetwc(URL_FILE *file); -URL_FILE * file_to_url_file( FILE* f); - +URL_FILE *url_fopen( const char *url, const char *operation ); +int url_fclose( URL_FILE * file ); +int url_feof( URL_FILE * file ); +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); +char *url_fgets( char *ptr, size_t size, URL_FILE * file ); +void url_rewind( URL_FILE * file ); +wint_t url_fgetwc( URL_FILE * file ); +wint_t url_ungetwc( wint_t wc, URL_FILE * input ); +URL_FILE *file_to_url_file( FILE * f ); #endif diff --git a/src/io/io.c b/src/io/io.c new file mode 100644 index 0000000..5d2c652 --- /dev/null +++ b/src/io/io.c @@ -0,0 +1,177 @@ +/* + * io.c + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "debug.h" +#include "fopen.h" +#include "lispops.h" + +/** + * Convert this lisp string-like-thing (also works for symbols, and, later + * keywords) into a UTF-8 string. NOTE that the returned value has been + * malloced and must be freed. TODO: candidate to moving into a utilities + * file. + * + * @param s the lisp string or symbol; + * @return the c string. + */ +char *lisp_string_to_c_string( struct cons_pointer s ) { + char *result = NULL; + + if ( stringp( s ) || symbolp( s ) ) { + int len = 0; + + for ( struct cons_pointer c = s; !nilp( c ); + c = pointer2cell( c ).payload.string.cdr ) { + len++; + } + + wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) ); + /* worst case, one wide char = four utf bytes */ + result = calloc( ( len * 4 ) + 1, sizeof( char ) ); + + int i = 0; + for ( struct cons_pointer c = s; !nilp( c ); + c = pointer2cell( c ).payload.string.cdr ) { + buffer[i++] = pointer2cell( c ).payload.string.character; + } + + wcstombs( result, buffer, len ); + free( buffer ); + } + + return result; +} + +/** + * Function, sort-of: close the file indicated by my first arg, and return + * nil. If the first arg is not a stream, does nothing. All other args are + * ignored. + * + * * (close stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return T if the stream was successfully closed, else NIL. + */ +struct cons_pointer +lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) || writep( frame->arg[0] ) ) { + if ( url_fclose( pointer2cell( frame->arg[0] ).payload.stream.stream ) + == 0 ) { + result = TRUE; + } + } + + return result; +} + +/** + * Function: return a stream open on the URL indicated by the first argument; + * if a second argument is present and is non-nil, open it for reading. At + * present, further arguments are ignored and there is no mechanism to open + * to append, or error if the URL is faulty or indicates an unavailable + * resource. + * + * * (read-char stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( stringp( frame->arg[0] ) ) { + char *url = lisp_string_to_c_string( frame->arg[0] ); + + if ( nilp( frame->arg[1] ) ) { + result = make_read_stream( url_fopen( url, "r" ) ); + } else { + // TODO: anything more complex is a problem for another day. + result = make_write_stream( url_fopen( url, "w" ) ); + } + + free( url ); + } + + return result; +} + +/** + * Function: return the next character from the stream indicated by arg 0; + * further arguments are ignored. + * + * * (read-char stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) ) { + result = + make_string( url_fgetwc + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); + } + + return result; +} + +/** + * Function: return a string representing all characters from the stream + * indicated by arg 0; further arguments are ignored. + * + * * (slurp stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer cdr = NIL; + + if ( readp( frame->arg[0] ) ) { + URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream; + + for ( wint_t c = url_fgetwc( stream ); c != -1; + c = url_fgetwc( stream ) ) { + cdr = make_string( ( ( wchar_t ) c ), cdr ); + + if ( nilp( result ) ) { + result = cdr; + } + } + } + + return result; +} diff --git a/src/io/io.h b/src/io/io.h new file mode 100644 index 0000000..06dcaed --- /dev/null +++ b/src/io/io.h @@ -0,0 +1,28 @@ + +/* + * io.h + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_io_h +#define __psse_io_h + +struct cons_pointer +lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + + +#endif diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 03034e4..7a1a0d8 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -117,7 +117,7 @@ void make_cons_page( ) { */ void dump_pages( URL_FILE * output ) { for ( int i = 0; i < initialised_cons_pages; i++ ) { - fwprintf( output, L"\nDUMPING PAGE %d\n", i ); + url_fwprintf( output, L"\nDUMPING PAGE %d\n", i ); for ( int j = 0; j < CONSPAGESIZE; j++ ) { dump_object( output, ( struct cons_pointer ) { diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index b3f587c..6230e64 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -491,6 +491,10 @@ struct special_payload { struct stream_payload { /** the stream to read from or write to. */ URL_FILE *stream; + /** metadata on the stream (e.g. its file attributes if a file, its HTTP + * headers if a URL, etc). Expected to be an association, or nil. Not yet + * implemented. */ + struct cons_pointer meta; }; /** diff --git a/src/memory/dump.c b/src/memory/dump.c index cec0dfd..e99d306 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -30,22 +30,22 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); if ( cell.payload.string.character == 0 ) { - fwprintf( output, - L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", - prefix, - cell.payload.string.cdr.page, cell.payload.string.cdr.offset, - cell.count ); + url_fwprintf( output, + L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", + prefix, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset, cell.count ); } else { - fwprintf( output, - L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", - prefix, - ( wint_t ) cell.payload.string.character, - cell.payload.string.character, - cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, cell.count ); - fwprintf( output, L"\t\t value: " ); + url_fwprintf( output, + L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", + prefix, + ( wint_t ) cell.payload.string.character, + cell.payload.string.character, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset, cell.count ); + url_fwprintf( output, L"\t\t value: " ); print( output, pointer ); - fwprintf( output, L"\n" ); + url_fwprintf( output, L"\n" ); } } @@ -54,70 +54,71 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, */ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); - fwprintf( output, - 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 ); + url_fwprintf( output, + 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 ) { case CONSTV: - fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :", - cell.payload.cons.car.page, - cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset, cell.count ); + url_fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :", + cell.payload.cons.car.page, + cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); print( output, pointer ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); break; case EXCEPTIONTV: - fwprintf( output, L"\t\tException cell: " ); + url_fwprintf( output, L"\t\tException cell: " ); dump_stack_trace( output, pointer ); break; case FREETV: - fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset ); + url_fwprintf( output, + L"\t\tFree cell: next at page %d offset %d\n", + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset ); break; case INTEGERTV: - fwprintf( output, - L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); + url_fwprintf( output, + L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); if ( !nilp( cell.payload.integer.more ) ) { - fputws( L"\t\tBIGNUM! More at:\n", output ); + url_fputws( L"\t\tBIGNUM! More at:\n", output ); dump_object( output, cell.payload.integer.more ); } break; case LAMBDATV: - fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); print( output, cell.payload.lambda.args ); - fwprintf( output, L";\n\t\t\tbody: " ); + url_fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); break; case NILTV: break; case NLAMBDATV: - fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); print( output, cell.payload.lambda.args ); - fwprintf( output, L";\n\t\t\tbody: " ); + url_fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); break; case RATIOTV: - fwprintf( output, - L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload. - integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload. - integer.value, cell.count ); + url_fwprintf( output, + L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer2cell( cell.payload.ratio.dividend ). + payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ). + payload.integer.value, cell.count ); break; case READTV: - fwprintf( output, L"\t\tInput stream\n" ); + url_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 ); + url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); break; case STRINGTV: dump_string_cell( output, L"String", pointer ); @@ -128,14 +129,14 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { case TRUETV: break; case VECTORPOINTTV:{ - fwprintf( output, - L"\t\tPointer to vector-space object at %p\n", - cell.payload.vectorp.address ); + url_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 (%d), payload size %d bytes\n", - &vso->header.tag.bytes, vso->header.tag.value, - vso->header.size ); + url_fwprintf( output, + 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 ); } @@ -147,7 +148,7 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { } break; case WRITETV: - fwprintf( output, L"\t\tOutput stream\n" ); + url_fwprintf( output, L"\t\tOutput stream\n" ); break; } } diff --git a/src/memory/stack.c b/src/memory/stack.c index b2585c7..3f4a271 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -34,9 +34,9 @@ void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) { debug_printf( DEBUG_STACK, L"Setting register %d to ", reg ); debug_print_object( value, DEBUG_STACK ); debug_println( DEBUG_STACK ); - dec_ref(frame->arg[reg]); /* if there was anything in that slot - * previously other than NIL, we need to decrement it; - * NIL won't be decremented as it is locked. */ + dec_ref( frame->arg[reg] ); /* if there was anything in that slot + * previously other than NIL, we need to decrement it; + * NIL won't be decremented as it is locked. */ frame->arg[reg] = value; inc_ref( value ); @@ -245,22 +245,22 @@ void dump_frame( URL_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 ); + url_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] ); - fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg, - cell.tag.bytes[0], - cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3], - cell.count ); + url_fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", + arg, cell.tag.bytes[0], cell.tag.bytes[1], + cell.tag.bytes[2], cell.tag.bytes[3], cell.count ); print( output, frame->arg[arg] ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); } if ( !nilp( frame->more ) ) { - fputws( L"More: \t", output ); + url_fputws( L"More: \t", output ); print( output, frame->more ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); } } } @@ -268,7 +268,7 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { print( output, pointer2cell( pointer ).payload.exception.message ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); } else { diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 9d98a77..480effb 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -36,7 +36,8 @@ * @return a cons_pointer to the object, or NIL if the object could not be * allocated due to memory exhaustion. */ -struct cons_pointer make_vec_pointer( struct vector_space_object *address, char *tag ) { +struct cons_pointer make_vec_pointer( struct vector_space_object *address, + char *tag ) { debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -46,7 +47,7 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address, char address ); cell->payload.vectorp.address = address; - strncpy(&cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH); + strncpy( &cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", diff --git a/src/ops/equal.c b/src/ops/equal.c index 0c01a81..2775218 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload.string. - cdr ) ) ); + && end_of_string( cell_b->payload. + string.cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/ops/intern.c b/src/ops/intern.c index 1e32a36..87d116e 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -110,8 +110,8 @@ struct cons_pointer c_assoc( struct cons_pointer key, * with this key/value pair added to the front. */ struct cons_pointer -bind( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { +set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { debug_print( L"Binding ", DEBUG_BIND ); debug_print_object( key, DEBUG_BIND ); debug_print( L" to ", DEBUG_BIND ); @@ -131,7 +131,7 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { debug_print( L"Entering deep_bind\n", DEBUG_BIND ); struct cons_pointer old = oblist; - oblist = bind( key, value, oblist ); + oblist = set( key, value, oblist ); inc_ref( oblist ); dec_ref( old ); @@ -153,7 +153,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { /* * not currently bound */ - result = bind( key, NIL, environment ); + result = set( key, NIL, environment ); } return result; diff --git a/src/ops/intern.h b/src/ops/intern.h index b261242..fa17563 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -28,9 +28,9 @@ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer environment ); -struct cons_pointer bind( struct cons_pointer key, - struct cons_pointer value, - struct cons_pointer store ); +struct cons_pointer set( struct cons_pointer key, + struct cons_pointer value, + struct cons_pointer store ); struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ); diff --git a/src/ops/io.c b/src/ops/io.c deleted file mode 100644 index ccd0af5..0000000 --- a/src/ops/io.c +++ /dev/null @@ -1,8 +0,0 @@ -/* - * io.c - * - * Communication between PSSE and the outside world, via libcurl. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 9448c55..4bfe6f0 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -29,6 +29,7 @@ #include "debug.h" #include "dump.h" #include "equal.h" +#include "fopen.h" #include "integer.h" #include "intern.h" #include "lispops.h" @@ -231,7 +232,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer name = c_car( names ); struct cons_pointer val = frame->arg[i]; - new_env = bind( name, val, new_env ); + new_env = set( name, val, new_env ); log_binding( name, val ); names = c_cdr( names ); @@ -256,7 +257,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } } - new_env = bind( names, vals, new_env ); + new_env = set( names, vals, new_env ); inc_ref( new_env ); } @@ -377,10 +378,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload. - special.executable ) ( get_stack_frame - ( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -627,10 +627,10 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, * @return true if `arg` represents an end of string, else false. * \todo candidate for moving to a memory/string.c file */ -bool end_of_stringp(struct cons_pointer arg) { - return nilp(arg) || - ( stringp( arg ) && - pointer2cell(arg).payload.string.character == (wint_t)'\0'); +bool end_of_stringp( struct cons_pointer arg ) { + return nilp( arg ) || + ( stringp( arg ) && + pointer2cell( arg ).payload.string.character == ( wint_t ) '\0' ); } /** @@ -656,8 +656,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( car ) && nilp( cdr ) ) { return NIL; } else if ( stringp( car ) && stringp( cdr ) && - end_of_stringp( c_cdr( car)) ) { - // \todo check that car is of length 1 + end_of_stringp( c_cdr( car ) ) ) { + // \todo check that car is of length 1 result = make_string( pointer2cell( car ).payload.string.character, cdr ); } else { @@ -691,7 +691,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, result = cell.payload.cons.car; break; case READTV: - result = make_string( fgetwc( cell.payload.stream.stream ), NIL ); + result = + make_string( url_fgetwc( cell.payload.stream.stream ), NIL ); break; case NILTV: break; @@ -734,7 +735,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, result = cell.payload.cons.cdr; break; case READTV: - fgetwc( cell.payload.stream.stream ); + url_fgetwc( cell.payload.stream.stream ); result = frame->arg[0]; break; case STRINGTV: @@ -839,7 +840,8 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, #ifdef DEBUG debug_print( L"entering lisp_read\n", DEBUG_IO ); #endif - URL_FILE *input = stdin; + URL_FILE *input; + struct cons_pointer in_stream = readp( frame->arg[0] ) ? frame->arg[0] : get_default_stream( true, env ); @@ -848,6 +850,8 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_dump_object( in_stream, DEBUG_IO ); input = pointer2cell( in_stream ).payload.stream.stream; inc_ref( in_stream ); + } else { + input = file_to_url_file( stdin ); } struct cons_pointer result = read( frame, frame_pointer, input ); @@ -856,8 +860,11 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( in_stream ) ) { dec_ref( in_stream ); + } else { + free( input ); } + return result; } @@ -922,7 +929,7 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { debug_print( L"Entering print\n", DEBUG_IO ); struct cons_pointer result = NIL; - URL_FILE *output = stdout; + URL_FILE *output; struct cons_pointer out_stream = writep( frame->arg[1] ) ? frame->arg[1] : get_default_stream( false, env ); @@ -931,6 +938,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_dump_object( out_stream, DEBUG_IO ); output = pointer2cell( out_stream ).payload.stream.stream; inc_ref( out_stream ); + } else { + output = file_to_url_file( stderr ); } debug_print( L"lisp_print: about to print\n", DEBUG_IO ); @@ -943,6 +952,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( writep( out_stream ) ) { dec_ref( out_stream ); + } else { + free( output ); } return result; @@ -1035,7 +1046,7 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, * @return the value of the last expression of the first successful `clause`. */ struct cons_pointer - lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; bool done = false; @@ -1165,7 +1176,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * print as parent. */ while ( readp( input ) && writep( output ) - && !feof( pointer2cell( input ).payload.stream.stream ) ) { + && !url_feof( pointer2cell( input ).payload.stream.stream ) ) { /* OK, here's a really subtle problem: because lists are immutable, anything * bound in the oblist subsequent to this function being invoked isn't in the * environment. So, for example, changes to *prompt* or *log* made in the oblist @@ -1203,7 +1214,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, inc_ref( expr ); if ( exceptionp( expr ) - && feof( pointer2cell( input ).payload.stream.stream ) ) { + && url_feof( pointer2cell( input ).payload.stream.stream ) ) { /* suppress printing end of stream exception */ break; } @@ -1282,7 +1293,7 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { debug_print( L"Entering print\n", DEBUG_IO ); - URL_FILE *output = stdout; + URL_FILE *output; struct cons_pointer out_stream = writep( frame->arg[1] ) ? frame->arg[1] : get_default_stream( false, env ); @@ -1291,11 +1302,16 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame, debug_dump_object( out_stream, DEBUG_IO ); output = pointer2cell( out_stream ).payload.stream.stream; inc_ref( out_stream ); + } else { + output = file_to_url_file( stdout ); } + dump_object( output, frame->arg[0] ); if ( writep( out_stream ) ) { dec_ref( out_stream ); + } else { + free( output ); } return frame->arg[0]; diff --git a/src/ops/print.c b/src/ops/print.c index d313960..8cb137e 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -40,7 +40,7 @@ void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { wchar_t c = cell->payload.string.character; if ( c != '\0' ) { - fputwc( c, output ); + url_fputwc( c, output ); } pointer = cell->payload.string.cdr; } @@ -52,9 +52,9 @@ void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { * characters. */ void print_string( URL_FILE * output, struct cons_pointer pointer ) { - fputwc( btowc( '"' ), output ); + url_fputwc( btowc( '"' ), output ); print_string_contents( output, pointer ); - fputwc( btowc( '"' ), output ); + url_fputwc( btowc( '"' ), output ); } /** @@ -70,7 +70,7 @@ print_list_contents( URL_FILE * output, struct cons_pointer pointer, switch ( cell->tag.value ) { case CONSTV: if ( initial_space ) { - fputwc( btowc( ' ' ), output ); + url_fputwc( btowc( ' ' ), output ); } print( output, cell->payload.cons.car ); @@ -79,23 +79,23 @@ print_list_contents( URL_FILE * output, struct cons_pointer pointer, case NILTV: break; default: - fwprintf( output, L" . " ); + url_fwprintf( output, L" . " ); print( output, pointer ); } } void print_list( URL_FILE * output, struct cons_pointer pointer ) { if ( print_use_colours ) { - fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); + url_fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); } else { - fputws( L"(", output ); + url_fputws( L"(", output ); }; print_list_contents( output, pointer, false ); if ( print_use_colours ) { - fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); + url_fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); } else { - fputws( L")", output ); + url_fputws( L")", output ); } } @@ -117,18 +117,18 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_list( output, pointer ); break; case EXCEPTIONTV: - fwprintf( output, L"\n%sException: ", - print_use_colours ? "\x1B[31m" : "" ); + url_fwprintf( output, L"\n%sException: ", + print_use_colours ? "\x1B[31m" : "" ); dump_stack_trace( output, pointer ); break; case FUNCTIONTV: - fwprintf( output, L"" ); + url_fwprintf( output, L"" ); break; case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); inc_ref( s ); if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); + url_fputws( L"\x1B[34m", output ); } print_string_contents( output, s ); dec_ref( s ); @@ -147,7 +147,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { } break; case NILTV: - fwprintf( output, L"nil" ); + url_fwprintf( output, L"nil" ); break; case NLAMBDATV:{ struct cons_pointer to_print = @@ -163,11 +163,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; case RATIOTV: print( output, cell.payload.ratio.dividend ); - fputws( L"/", output ); + url_fputws( L"/", output ); print( output, cell.payload.ratio.divisor ); break; case READTV: - fwprintf( output, L"" ); + url_fwprintf( output, L"" ); break; case REALTV: /* \todo using the C heap is a bad plan because it will fragment. @@ -183,31 +183,31 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { } } if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); + url_fputws( L"\x1B[34m", output ); } - fwprintf( output, L"%s", buffer ); + url_fwprintf( output, L"%s", buffer ); free( buffer ); break; case STRINGTV: if ( print_use_colours ) { - fputws( L"\x1B[36m", output ); + url_fputws( L"\x1B[36m", output ); } print_string( output, pointer ); break; case SYMBOLTV: if ( print_use_colours ) { - fputws( L"\x1B[1;33m", output ); + url_fputws( L"\x1B[1;33m", output ); } print_string_contents( output, pointer ); break; case SPECIALTV: - fwprintf( output, L"" ); + url_fwprintf( output, L"" ); break; case TRUETV: - fwprintf( output, L"t" ); + url_fwprintf( output, L"t" ); break; case WRITETV: - fwprintf( output, L"" ); + url_fwprintf( output, L"" ); break; default: fwprintf( stderr, @@ -219,12 +219,12 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { } if ( print_use_colours ) { - fputws( L"\x1B[39m", output ); + url_fputws( L"\x1B[39m", output ); } return pointer; } void println( URL_FILE * output ) { - fputws( L"\n", output ); + url_fputws( L"\n", output ); } diff --git a/src/ops/read.c b/src/ops/read.c index d2f79c4..989aa67 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -41,8 +41,8 @@ struct cons_pointer read_number( struct stack_frame *frame, URL_FILE * input, wint_t initial, bool seen_period ); struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, URL_FILE * input, - wint_t initial ); + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ); @@ -68,16 +68,18 @@ struct cons_pointer read_continuation( struct stack_frame *frame, wint_t c; for ( c = initial; - c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); + c == '\0' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ); - if ( feof( input ) ) { + if ( url_feof( input ) ) { result = throw_exception( c_string_to_lisp_string ( L"End of file while reading" ), frame_pointer ); } else { switch ( c ) { case ';': - for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) ); + for ( c = url_fgetwc( input ); c != '\n'; + c = url_fgetwc( input ) ); /* skip all characters from semi-colon to the end of the line */ break; case EOF: @@ -89,18 +91,19 @@ struct cons_pointer read_continuation( struct stack_frame *frame, result = c_quote( read_continuation ( frame, frame_pointer, input, - fgetwc( input ) ) ); + url_fgetwc( input ) ) ); break; case '(': result = - read_list( frame, frame_pointer, input, fgetwc( input ) ); + read_list( frame, frame_pointer, input, + url_fgetwc( input ) ); break; case '"': - result = read_string( input, fgetwc( input ) ); + result = read_string( input, url_fgetwc( input ) ); break; case '-':{ - wint_t next = fgetwc( input ); - ungetwc( next, input ); + wint_t next = url_fgetwc( input ); + url_ungetwc( next, input ); if ( iswdigit( next ) ) { result = read_number( frame, frame_pointer, input, c, @@ -112,9 +115,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, break; case '.': { - wint_t next = fgetwc( input ); + wint_t next = url_fgetwc( input ); if ( iswdigit( next ) ) { - ungetwc( next, input ); + url_ungetwc( next, input ); result = read_number( frame, frame_pointer, input, c, true ); @@ -123,13 +126,13 @@ struct cons_pointer read_continuation( struct stack_frame *frame, * really need to backtrack up a level. */ result = read_continuation( frame, frame_pointer, input, - fgetwc( input ) ); + url_fgetwc( input ) ); } else { read_symbol( input, c ); } } break; - //case ':': reserved for keywords and paths + //case ':': reserved for keywords and paths default: if ( iswdigit( c ) ) { result = @@ -173,14 +176,14 @@ struct cons_pointer read_number( struct stack_frame *frame, bool neg = initial == btowc( '-' ); if ( neg ) { - initial = fgetwc( input ); + initial = url_fgetwc( input ); } debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial ); for ( c = initial; iswdigit( c ) - || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { + || c == L'.' || c == L'/' || c == L','; c = url_fgetwc( input ) ) { switch ( c ) { case L'.': if ( seen_period || !nilp( dividend ) ) { @@ -229,7 +232,7 @@ struct cons_pointer read_number( struct stack_frame *frame, /* * push back the character read which was not a digit */ - ungetwc( c, input ); + url_ungetwc( c, input ); if ( seen_period ) { debug_print( L"read_number: converting result to real\n", DEBUG_IO ); @@ -279,7 +282,7 @@ struct cons_pointer read_list( struct stack_frame *frame, result = make_cons( car, read_list( frame, frame_pointer, input, - fgetwc( input ) ) ); + url_fgetwc( input ) ) ); } else { debug_print( L"End of list detected\n", DEBUG_IO ); } @@ -309,7 +312,8 @@ struct cons_pointer read_string( URL_FILE * input, wint_t initial ) { break; default: result = - make_string( initial, read_string( input, fgetwc( input ) ) ); + make_string( initial, + read_string( input, url_fgetwc( input ) ) ); break; } @@ -328,7 +332,8 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { * THIS IS NOT A GOOD IDEA, but is legal */ result = - make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); + make_symbol( initial, + read_symbol( input, url_fgetwc( input ) ) ); break; case ')': /* @@ -338,20 +343,20 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { /* * push back the character read */ - ungetwc( initial, input ); + url_ungetwc( initial, input ); break; default: if ( iswprint( initial ) && !iswblank( initial ) ) { result = make_symbol( initial, - read_symbol( input, fgetwc( input ) ) ); + read_symbol( input, url_fgetwc( input ) ) ); } else { result = NIL; /* * push back the character read */ - ungetwc( initial, input ); + url_ungetwc( initial, input ); } break; } @@ -369,5 +374,6 @@ struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE * input ) { - return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); + return read_continuation( frame, frame_pointer, input, + url_fgetwc( input ) ); } diff --git a/src/ops/read.h b/src/ops/read.h index a1674d6..64f36b0 100644 --- a/src/ops/read.h +++ b/src/ops/read.h @@ -15,6 +15,7 @@ * read the next object on this input stream and return a cons_pointer to it. */ struct cons_pointer read( struct stack_frame *frame, - struct cons_pointer frame_pointer, URL_FILE * input ); + struct cons_pointer frame_pointer, + URL_FILE * input ); #endif From d9acb277bf463ef959744f66d60fb74bbf9cde48 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 27 Jan 2019 17:51:28 +0000 Subject: [PATCH 043/101] Tests now pass at least, all the ones that did before! --- src/init.c | 6 +++--- src/io/fopen.c | 4 +++- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/init.c b/src/init.c index a45e685..2814f1d 100644 --- a/src/init.c +++ b/src/init.c @@ -162,16 +162,16 @@ int main( int argc, char *argv[] ) { bind_function( L"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); bind_function( L"negative?", &lisp_is_negative ); - bind_function( L"read", &lisp_read ); - bind_function( L"repl", &lisp_repl ); bind_function( L"oblist", &lisp_oblist ); bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); bind_function( L"read", &lisp_read ); - bind_function( L"read_char", &lisp_read_char ); + bind_function( L"read-char", &lisp_read_char ); + bind_function( L"repl", &lisp_repl ); bind_function( L"reverse", &lisp_reverse ); bind_function( L"set", &lisp_set ); + bind_function( L"slurp", &lisp_slurp ); bind_function( L"source", &lisp_source ); bind_function( L"subtract", &lisp_subtract ); bind_function( L"throw", &lisp_exception ); diff --git a/src/io/fopen.c b/src/io/fopen.c index 499fada..3b09957 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -47,6 +47,7 @@ #include +#include "debug.h" #include "fopen.h" /* we use a global one for convenience */ @@ -474,6 +475,7 @@ wint_t url_fgetwc( URL_FILE * input ) { break; } + debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, result); return result; } @@ -483,7 +485,7 @@ wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { switch ( input->type ) { case CFTYPE_FILE: fwide( input->handle.file, 1 ); /* wide characters */ - result = fgetwc( input->handle.file ); /* passthrough */ + result = ungetwc( wc, input->handle.file ); /* passthrough */ break; case CFTYPE_CURL:{ From 3470f27585f20db741cf498b616d08c34dd5a1c4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 27 Jan 2019 18:54:23 +0000 Subject: [PATCH 044/101] Can now read files from the filesystem. --- hi | 1 + src/io/io.c | 27 ++++++++++++++++++++------- unit-tests/slurp.sh | 13 +++++++++++++ 3 files changed, 34 insertions(+), 7 deletions(-) create mode 100644 hi create mode 100755 unit-tests/slurp.sh diff --git a/hi b/hi new file mode 100644 index 0000000..cf57f2a --- /dev/null +++ b/hi @@ -0,0 +1 @@ +Hello, this is used by `slurp.sh` test, please do not remove. diff --git a/src/io/io.c b/src/io/io.c index 5d2c652..e510580 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -31,7 +31,7 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { int len = 0; for ( struct cons_pointer c = s; !nilp( c ); - c = pointer2cell( c ).payload.string.cdr ) { + c = pointer2cell( c ).payload.string.cdr ) { len++; } @@ -49,6 +49,10 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { free( buffer ); } + debug_print(L"lisp_string_to_c_string( ", DEBUG_IO); + debug_print_object( s, DEBUG_IO); + debug_printf( DEBUG_IO, L") => '%s'\n", result); + return result; } @@ -110,6 +114,10 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, } free( url ); + + if ( pointer2cell(result).payload.stream.stream == NULL) { + result = NIL; + } } return result; @@ -158,18 +166,23 @@ struct cons_pointer lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_pointer cdr = NIL; if ( readp( frame->arg[0] ) ) { URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream; + struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL); + result = cursor; - for ( wint_t c = url_fgetwc( stream ); c != -1; + for ( wint_t c = url_fgetwc( stream ); !url_feof(stream); c = url_fgetwc( stream ) ) { - cdr = make_string( ( ( wchar_t ) c ), cdr ); + debug_print(L"slurp: cursor is: ", DEBUG_IO); + debug_dump_object( cursor, DEBUG_IO); + debug_print(L"; result is: ", DEBUG_IO); + debug_dump_object( result, DEBUG_IO); + debug_println( DEBUG_IO); - if ( nilp( result ) ) { - result = cdr; - } + struct cons_space_object * cell = &pointer2cell(cursor); + cursor = make_string( ( wchar_t ) c , NIL); + cell->payload.string.cdr = cursor; } } diff --git a/unit-tests/slurp.sh b/unit-tests/slurp.sh new file mode 100755 index 0000000..e285988 --- /dev/null +++ b/unit-tests/slurp.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +expected='"Hello, this is used by `slurp.sh` test, please do not remove.' +actual=`echo '(slurp (open "hi"))' | target/psse | tail -2 | head -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi From 8334e2bf1f3a92ff7af37adfb15fc977a361f772 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 28 Jan 2019 10:32:34 +0000 Subject: [PATCH 045/101] Still segfaults on read from URL. --- src/init.c | 4 ++++ src/io/fopen.c | 5 +---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/init.c b/src/init.c index 2814f1d..1fba3f2 100644 --- a/src/init.c +++ b/src/init.c @@ -16,6 +16,9 @@ #include #include +/* libcurl, used for io */ +#include + #include "version.h" #include "conspage.h" #include "consspaceobject.h" @@ -84,6 +87,7 @@ int main( int argc, char *argv[] ) { bool show_prompt = false; setlocale( LC_ALL, "" ); + curl_global_init(CURL_GLOBAL_DEFAULT); while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { diff --git a/src/io/fopen.c b/src/io/fopen.c index 3b09957..a2eddab 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -460,14 +460,11 @@ wint_t url_fgetwc( URL_FILE * input ) { case CFTYPE_CURL:{ wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); - char *cbuff = calloc( 5, sizeof( char ) ); - url_fread( cbuff, sizeof( char ), 4, input ); - mbstowcs( wbuff, cbuff, 1 ); + mbstowcs( wbuff, (char *)&input->buffer[input->buffer_pos], 1 ); result = wbuff[0]; use_one_wide( input ); - free( cbuff ); free( wbuff ); } break; From b15c0e8f892283802f668d13ff9ec43f61f387d8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 28 Jan 2019 15:02:46 +0000 Subject: [PATCH 046/101] Tactical commit --- src/arith/integer.c | 158 ++++++++++++++++++++++---------------------- src/init.c | 2 +- src/io/fopen.c | 103 +++++++++++++++++++++-------- src/io/io.c | 28 ++++---- 4 files changed, 167 insertions(+), 124 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 679bf37..1195c53 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -76,20 +76,16 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { * \see add_integers */ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { - long int val = nilp( c ) ? - 0 : - pointer2cell( c ).payload.integer.value; + long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 ); __int128_t result = ( __int128_t ) integerp( c ) ? - ( val == 0 ) ? - carry : - val : - op == '*' ? 1 : 0; + ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; debug_printf( DEBUG_ARITH, L"cell_value: raw value is %ld, is_first_cell = %s; %4.4s; returning ", - val, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); + val, is_first_cell ? "true" : "false", + pointer2cell( c ).tag.bytes ); debug_print_128bit( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); @@ -109,9 +105,8 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { * @return carry, if any, else 0. */ __int128_t int128_to_integer( __int128_t val, - struct cons_pointer less_significant, - struct cons_pointer new) -{ + struct cons_pointer less_significant, + struct cons_pointer new ) { struct cons_pointer cursor = NIL; __int128_t carry = 0; @@ -120,12 +115,12 @@ __int128_t int128_to_integer( __int128_t val, } else { carry = val >> 60; debug_printf( DEBUG_ARITH, - L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); + L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); val &= MAX_INTEGER; } - struct cons_space_object * newc = &pointer2cell( new); + struct cons_space_object *newc = &pointer2cell( new ); newc->payload.integer.value = val; if ( integerp( less_significant ) ) { @@ -137,19 +132,21 @@ __int128_t int128_to_integer( __int128_t val, return carry; } -struct cons_pointer make_integer_128(__int128_t val, - struct cons_pointer less_significant) { +struct cons_pointer make_integer_128( __int128_t val, + struct cons_pointer less_significant ) { struct cons_pointer result = NIL; do { if ( MAX_INTEGER >= val ) { - result = make_integer( (long int) val, less_significant); + result = make_integer( ( long int ) val, less_significant ); } else { - less_significant = make_integer( (long int)val & MAX_INTEGER, less_significant); + less_significant = + make_integer( ( long int ) val & MAX_INTEGER, + less_significant ); val = val >> 60; } - } while (nilp(result)); + } while ( nilp( result ) ); return result; } @@ -164,10 +161,10 @@ struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer cursor = NIL; debug_print( L"add_integers: a = ", DEBUG_ARITH ); - debug_print_object(a, DEBUG_ARITH); + debug_print_object( a, DEBUG_ARITH ); debug_print( L"; b = ", DEBUG_ARITH ); - debug_print_object(b, DEBUG_ARITH); - debug_println(DEBUG_ARITH); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); __int128_t carry = 0; bool is_first_cell = true; @@ -194,8 +191,8 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_print_128bit( rv, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); - struct cons_pointer new = make_integer( 0, NIL); - carry = int128_to_integer(rv, cursor, new); + struct cons_pointer new = make_integer( 0, NIL ); + carry = int128_to_integer( rv, cursor, new ); cursor = new; if ( nilp( result ) ) { @@ -215,14 +212,14 @@ struct cons_pointer add_integers( struct cons_pointer a, return result; } -struct cons_pointer base_partial(int depth) { - struct cons_pointer result = NIL; +struct cons_pointer base_partial( int depth ) { + struct cons_pointer result = NIL; - for (int i = 0; i < depth; i++) { - result = make_integer(0, result); - } + for ( int i = 0; i < depth; i++ ) { + result = make_integer( 0, result ); + } - return result; + return result; } /** @@ -236,69 +233,70 @@ struct cons_pointer base_partial(int depth) { struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { struct cons_pointer result = NIL; - bool neg = is_negative(a) != is_negative(b); + bool neg = is_negative( a ) != is_negative( b ); bool is_first_b = true; int oom = -1; debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); - debug_print_object(a, DEBUG_ARITH); + debug_print_object( a, DEBUG_ARITH ); debug_print( L"; b = ", DEBUG_ARITH ); - debug_print_object(b, DEBUG_ARITH); - debug_println(DEBUG_ARITH); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); if ( integerp( a ) && integerp( b ) ) { while ( !nilp( b ) ) { - bool is_first_d = true; - struct cons_pointer d = a; - struct cons_pointer partial = base_partial(++oom); - __int128_t carry = 0; + bool is_first_d = true; + struct cons_pointer d = a; + struct cons_pointer partial = base_partial( ++oom ); + __int128_t carry = 0; - while ( !nilp(d) || carry != 0) { - partial = make_integer(0, partial); - struct cons_pointer new = NIL; - __int128_t dv = cell_value( d, '+', is_first_d ); - __int128_t bv = cell_value( b, '+', is_first_b ); + while ( !nilp( d ) || carry != 0 ) { + partial = make_integer( 0, partial ); + struct cons_pointer new = NIL; + __int128_t dv = cell_value( d, '+', is_first_d ); + __int128_t bv = cell_value( b, '+', is_first_b ); - __int128_t rv = (dv * bv) + carry; + __int128_t rv = ( dv * bv ) + carry; - debug_print( L"multiply_integers: d = ", DEBUG_ARITH); - debug_print_object( d, DEBUG_ARITH); - debug_print( L"; dv = ", DEBUG_ARITH ); - debug_print_128bit( dv, DEBUG_ARITH ); - debug_print( L"; bv = ", DEBUG_ARITH ); - debug_print_128bit( bv, DEBUG_ARITH ); - debug_print( L"; carry = ", DEBUG_ARITH ); - debug_print_128bit( carry, DEBUG_ARITH ); - debug_print( L"; rv = ", DEBUG_ARITH ); - debug_print_128bit( rv, DEBUG_ARITH ); - debug_print( L"; acc = ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH); - debug_print( L"; partial = ", DEBUG_ARITH ); - debug_print_object( partial, DEBUG_ARITH); - debug_print( L"\n", DEBUG_ARITH ); + debug_print( L"multiply_integers: d = ", DEBUG_ARITH ); + debug_print_object( d, DEBUG_ARITH ); + debug_print( L"; dv = ", DEBUG_ARITH ); + debug_print_128bit( dv, DEBUG_ARITH ); + debug_print( L"; bv = ", DEBUG_ARITH ); + debug_print_128bit( bv, DEBUG_ARITH ); + debug_print( L"; carry = ", DEBUG_ARITH ); + debug_print_128bit( carry, DEBUG_ARITH ); + debug_print( L"; rv = ", DEBUG_ARITH ); + debug_print_128bit( rv, DEBUG_ARITH ); + debug_print( L"; acc = ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"; partial = ", DEBUG_ARITH ); + debug_print_object( partial, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); - new = make_integer_128(rv, base_partial(oom)); + new = make_integer_128( rv, base_partial( oom ) ); - if ( zerop(partial)) { - partial = new; - } else { - partial = add_integers(partial, new); + if ( zerop( partial ) ) { + partial = new; + } else { + partial = add_integers( partial, new ); + } + + d = integerp( d ) ? pointer2cell( d ).payload.integer. + more : NIL; + is_first_d = false; } - d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL; - is_first_d = false; - } - - if (nilp(result) || zerop(result)) { - result = partial; - } else { - struct cons_pointer old = result; - result = add_integers(partial, result); - //if (!eq(result, old)) dec_ref(old); - //if (!eq(result, partial)) dec_ref(partial); - } - b = pointer2cell( b ).payload.integer.more; - is_first_b = false; + if ( nilp( result ) || zerop( result ) ) { + result = partial; + } else { + struct cons_pointer old = result; + result = add_integers( partial, result ); + //if (!eq(result, old)) dec_ref(old); + //if (!eq(result, partial)) dec_ref(partial); + } + b = pointer2cell( b ).payload.integer.more; + is_first_b = false; } } @@ -365,8 +363,8 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", offset, hex_digits[offset] ); debug_print_128bit( accumulator, DEBUG_IO ); - debug_print( L"; result is: ", DEBUG_IO); - debug_print_object( result, DEBUG_IO); + debug_print( L"; result is: ", DEBUG_IO ); + debug_print_object( result, DEBUG_IO ); debug_println( DEBUG_IO ); result = diff --git a/src/init.c b/src/init.c index 1fba3f2..c180b10 100644 --- a/src/init.c +++ b/src/init.c @@ -87,7 +87,7 @@ int main( int argc, char *argv[] ) { bool show_prompt = false; setlocale( LC_ALL, "" ); - curl_global_init(CURL_GLOBAL_DEFAULT); + curl_global_init( CURL_GLOBAL_DEFAULT ); while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { diff --git a/src/io/fopen.c b/src/io/fopen.c index a2eddab..3c26cd9 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -53,6 +53,8 @@ /* we use a global one for convenience */ static CURLM *multi_handle; +wint_t ungotten = 0; + /* curl calls this routine to get more data */ static size_t write_callback( char *buffer, size_t size, size_t nitems, void *userp ) { @@ -452,27 +454,69 @@ URL_FILE *file_to_url_file( FILE * f ) { wint_t url_fgetwc( URL_FILE * input ) { wint_t result = -1; - switch ( input->type ) { - case CFTYPE_FILE: - fwide( input->handle.file, 1 ); /* wide characters */ - result = fgetwc( input->handle.file ); /* passthrough */ - break; + debug_printf( DEBUG_IO, L"url_fgetwc: ungotten = %d\n", ungotten ); - case CFTYPE_CURL:{ - wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + if ( ungotten != 0 ) { + /* TODO: not thread safe */ + result = ungotten; + ungotten = 0; + } else { + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; - mbstowcs( wbuff, (char *)&input->buffer[input->buffer_pos], 1 ); - result = wbuff[0]; - use_one_wide( input ); + case CFTYPE_CURL:{ + debug_print( L"url_fgetwc: stream is URL\n", DEBUG_IO ); - free( wbuff ); - } - break; - case CFTYPE_NONE: - break; + char *cbuff = + calloc( sizeof( wchar_t ) + 1, sizeof( char ) ); + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + + size_t count = 0; + + debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO ); + url_fgets( cbuff, 1, input ); + debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); + int c = ( int ) cbuff[0]; + debug_printf( DEBUG_IO, L"url_fgetwc: (first) character = %d (%c)\n", c, c & 0xf7 ); + /* The value of each individual byte indicates its UTF-8 function, as follows: + * + * 00 to 7F hex (0 to 127): first and only byte of a sequence. + * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. + * C2 to DF hex (194 to 223): first byte of a two-byte sequence. + * E0 to EF hex (224 to 239): first byte of a three-byte sequence. + * F0 to FF hex (240 to 255): first byte of a four-byte sequence. + */ + if ( c <= 0x07 ) { + count = 1; + } else if ( c >= '0xc2' && c <= '0xdf' ) { + count = 2; + } else if ( c >= '0xe0' && c <= '0xef' ) { + count = 3; + } else if ( c >= '0xf0' && c <= '0xff' ) { + count = 4; + } + + if ( count > 1 ) { + url_fgets( cbuff, --count, input ); + } + mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); + result = wbuff[0]; + use_one_wide( input ); + + free( wbuff ); + free( cbuff ); + } + break; + case CFTYPE_NONE: + break; + } } - debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, result); + debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, + result ); return result; } @@ -482,22 +526,23 @@ wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { switch ( input->type ) { case CFTYPE_FILE: fwide( input->handle.file, 1 ); /* wide characters */ - result = ungetwc( wc, input->handle.file ); /* passthrough */ + result = ungetwc( wc, input->handle.file ); /* passthrough */ break; case CFTYPE_CURL:{ - wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); - char *cbuff = calloc( 5, sizeof( char ) ); - - wbuff[0] = wc; - result = wcstombs( cbuff, wbuff, 1 ); - - input->buffer_pos -= strlen( cbuff ); - - free( cbuff ); - free( wbuff ); - - result = result > 0 ? wc : result; + ungotten = wc; +// wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); +// char *cbuff = calloc( 5, sizeof( char ) ); +// +// wbuff[0] = wc; +// result = wcstombs( cbuff, wbuff, 1 ); +// +// input->buffer_pos -= strlen( cbuff ); +// +// free( cbuff ); +// free( wbuff ); +// +// result = result > 0 ? wc : result; break; case CFTYPE_NONE: break; diff --git a/src/io/io.c b/src/io/io.c index e510580..4577a11 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -31,7 +31,7 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { int len = 0; for ( struct cons_pointer c = s; !nilp( c ); - c = pointer2cell( c ).payload.string.cdr ) { + c = pointer2cell( c ).payload.string.cdr ) { len++; } @@ -49,9 +49,9 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { free( buffer ); } - debug_print(L"lisp_string_to_c_string( ", DEBUG_IO); - debug_print_object( s, DEBUG_IO); - debug_printf( DEBUG_IO, L") => '%s'\n", result); + debug_print( L"lisp_string_to_c_string( ", DEBUG_IO ); + debug_print_object( s, DEBUG_IO ); + debug_printf( DEBUG_IO, L") => '%s'\n", result ); return result; } @@ -115,7 +115,7 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, free( url ); - if ( pointer2cell(result).payload.stream.stream == NULL) { + if ( pointer2cell( result ).payload.stream.stream == NULL ) { result = NIL; } } @@ -169,19 +169,19 @@ lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream; - struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL); + struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL ); result = cursor; - for ( wint_t c = url_fgetwc( stream ); !url_feof(stream); + for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ); c = url_fgetwc( stream ) ) { - debug_print(L"slurp: cursor is: ", DEBUG_IO); - debug_dump_object( cursor, DEBUG_IO); - debug_print(L"; result is: ", DEBUG_IO); - debug_dump_object( result, DEBUG_IO); - debug_println( DEBUG_IO); + debug_print( L"slurp: cursor is: ", DEBUG_IO ); + debug_dump_object( cursor, DEBUG_IO ); + debug_print( L"; result is: ", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + debug_println( DEBUG_IO ); - struct cons_space_object * cell = &pointer2cell(cursor); - cursor = make_string( ( wchar_t ) c , NIL); + struct cons_space_object *cell = &pointer2cell( cursor ); + cursor = make_string( ( wchar_t ) c, NIL ); cell->payload.string.cdr = cursor; } } From a640c9dff9c076190a7e83cea9ecb84aba35aaa5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 28 Jan 2019 18:46:24 +0000 Subject: [PATCH 047/101] It works! --- .gitignore | 2 + lisp/slurp.lisp | 1 + src/debug.c | 2 +- src/io/fopen.c | 855 +++++++++++++++++++++--------------------- src/io/fopen.h | 4 - src/io/io.c | 131 ++++++- src/io/io.h | 4 + src/memory/conspage.c | 4 + src/ops/lispops.c | 2 +- src/ops/read.c | 1 + 10 files changed, 568 insertions(+), 438 deletions(-) create mode 100644 lisp/slurp.lisp diff --git a/.gitignore b/.gitignore index 6fa1cd9..ec1281e 100644 --- a/.gitignore +++ b/.gitignore @@ -34,3 +34,5 @@ utils_src/readprintwc/out *.dump *.bak + +src/io/fopen diff --git a/lisp/slurp.lisp b/lisp/slurp.lisp new file mode 100644 index 0000000..e927bcb --- /dev/null +++ b/lisp/slurp.lisp @@ -0,0 +1 @@ +(slurp (set! f (open "http://www.journeyman.cc/"))) diff --git a/src/debug.c b/src/debug.c index 14881f9..c8b9771 100644 --- a/src/debug.c +++ b/src/debug.c @@ -19,9 +19,9 @@ #include #include "consspaceobject.h" -#include "fopen.h" #include "debug.h" #include "dump.h" +#include "io.h" #include "print.h" /** diff --git a/src/io/fopen.c b/src/io/fopen.c index 3c26cd9..f0ea012 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -37,517 +37,510 @@ * This example requires libcurl 7.9.7 or later. */ -#include #include -#include #include #ifndef WIN32 #include #endif +#include +#include #include -#include "debug.h" -#include "fopen.h" +enum fcurl_type_e { + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 +}; + +struct fcurl_data +{ + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ + + char *buffer; /* buffer to store cached data*/ + size_t buffer_len; /* currently allocated buffers length */ + size_t buffer_pos; /* end of data in buffer*/ + int still_running; /* Is background url fetch still in progress */ +}; + +typedef struct fcurl_data URL_FILE; + +/* exported functions */ +URL_FILE *url_fopen(const char *url, const char *operation); +int url_fclose(URL_FILE *file); +int url_feof(URL_FILE *file); +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file); +char *url_fgets(char *ptr, size_t size, URL_FILE *file); +void url_rewind(URL_FILE *file); /* we use a global one for convenience */ static CURLM *multi_handle; -wint_t ungotten = 0; - /* curl calls this routine to get more data */ -static size_t write_callback( char *buffer, - size_t size, size_t nitems, void *userp ) { - char *newbuff; - size_t rembuff; +static size_t write_callback(char *buffer, + size_t size, + size_t nitems, + void *userp) +{ + char *newbuff; + size_t rembuff; - URL_FILE *url = ( URL_FILE * ) userp; - size *= nitems; + URL_FILE *url = (URL_FILE *)userp; + size *= nitems; - rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ - if ( size > rembuff ) { - /* not enough space in buffer */ - newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) ); - if ( newbuff == NULL ) { - fprintf( stderr, "callback buffer grow failed\n" ); - size = rembuff; - } else { - /* realloc succeeded increase buffer size */ - url->buffer_len += size - rembuff; - url->buffer = newbuff; - } + if(size > rembuff) { + /* not enough space in buffer */ + newbuff = realloc(url->buffer, url->buffer_len + (size - rembuff)); + if(newbuff == NULL) { + fprintf(stderr, "callback buffer grow failed\n"); + size = rembuff; } + else { + /* realloc succeeded increase buffer size*/ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } + } - memcpy( &url->buffer[url->buffer_pos], buffer, size ); - url->buffer_pos += size; + memcpy(&url->buffer[url->buffer_pos], buffer, size); + url->buffer_pos += size; - return size; + return size; } /* use to attempt to fill the read buffer up to requested number of bytes */ -static int fill_buffer( URL_FILE * file, size_t want ) { - fd_set fdread; - fd_set fdwrite; - fd_set fdexcep; - struct timeval timeout; - int rc; - CURLMcode mc; /* curl_multi_fdset() return code */ +static int fill_buffer(URL_FILE *file, size_t want) +{ + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ - /* only attempt to fill buffer if transactions still running and buffer - * doesn't exceed required size already - */ - if ( ( !file->still_running ) || ( file->buffer_pos > want ) ) - return 0; + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if((!file->still_running) || (file->buffer_pos > want)) + return 0; - /* attempt to fill buffer */ - do { - int maxfd = -1; - long curl_timeo = -1; + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; - FD_ZERO( &fdread ); - FD_ZERO( &fdwrite ); - FD_ZERO( &fdexcep ); + FD_ZERO(&fdread); + FD_ZERO(&fdwrite); + FD_ZERO(&fdexcep); - /* set a suitable timeout to fail on */ - timeout.tv_sec = 60; /* 1 minute */ - timeout.tv_usec = 0; + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; - curl_multi_timeout( multi_handle, &curl_timeo ); - if ( curl_timeo >= 0 ) { - timeout.tv_sec = curl_timeo / 1000; - if ( timeout.tv_sec > 1 ) - timeout.tv_sec = 1; - else - timeout.tv_usec = ( curl_timeo % 1000 ) * 1000; - } + curl_multi_timeout(multi_handle, &curl_timeo); + if(curl_timeo >= 0) { + timeout.tv_sec = curl_timeo / 1000; + if(timeout.tv_sec > 1) + timeout.tv_sec = 1; + else + timeout.tv_usec = (curl_timeo % 1000) * 1000; + } - /* get file descriptors from the transfers */ - mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep, - &maxfd ); + /* get file descriptors from the transfers */ + mc = curl_multi_fdset(multi_handle, &fdread, &fdwrite, &fdexcep, &maxfd); - if ( mc != CURLM_OK ) { - fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc ); - break; - } + if(mc != CURLM_OK) { + fprintf(stderr, "curl_multi_fdset() failed, code %d.\n", mc); + break; + } - /* On success the value of maxfd is guaranteed to be >= -1. We call - select(maxfd + 1, ...); specially in case of (maxfd == -1) there are - no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- - to sleep 100ms, which is the minimum suggested value in the - curl_multi_fdset() doc. */ + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ - if ( maxfd == -1 ) { + if(maxfd == -1) { #ifdef _WIN32 - Sleep( 100 ); - rc = 0; + Sleep(100); + rc = 0; #else - /* Portable sleep for platforms other than Windows. */ - struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ - rc = select( 0, NULL, NULL, NULL, &wait ); + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select(0, NULL, NULL, NULL, &wait); #endif - } else { - /* Note that on some platforms 'timeout' may be modified by select(). - If you need access to the original value save a copy beforehand. */ - rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout ); - } + } + else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select(maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout); + } - switch ( rc ) { - case -1: - /* select error */ - break; + switch(rc) { + case -1: + /* select error */ + break; - case 0: - default: - /* timeout or readable/writable sockets */ - curl_multi_perform( multi_handle, &file->still_running ); - break; - } - } while ( file->still_running && ( file->buffer_pos < want ) ); - - return 1; + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform(multi_handle, &file->still_running); + break; + } + } while(file->still_running && (file->buffer_pos < want)); + return 1; } /* use to remove want bytes from the front of a files buffer */ -static int use_buffer( URL_FILE * file, size_t want ) { - /* sort out buffer */ - if ( ( file->buffer_pos - want ) <= 0 ) { - /* ditch buffer - write will recreate */ - free( file->buffer ); - file->buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; - } else { - /* move rest down make it available for later */ - memmove( file->buffer, - &file->buffer[want], ( file->buffer_pos - want ) ); +static int use_buffer(URL_FILE *file, size_t want) +{ + /* sort out buffer */ + if((file->buffer_pos - want) <= 0) { + /* ditch buffer - write will recreate */ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } + else { + /* move rest down make it available for later */ + memmove(file->buffer, + &file->buffer[want], + (file->buffer_pos - want)); - file->buffer_pos -= want; - } - return 0; + file->buffer_pos -= want; + } + return 0; } -/** - * consume one wide character on the buffer of this file. - * - * @param file the url or file from which the character is consumed. - */ -static int use_one_wide( URL_FILE * file ) { - int c = ( int ) file->buffer[file->buffer_pos]; - size_t count = 0; +URL_FILE *url_fopen(const char *url, const char *operation) +{ + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ - /* The value of each individual byte indicates its UTF-8 function, as follows: - * - * 00 to 7F hex (0 to 127): first and only byte of a sequence. - * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. - * C2 to DF hex (194 to 223): first byte of a two-byte sequence. - * E0 to EF hex (224 to 239): first byte of a three-byte sequence. - * F0 to FF hex (240 to 255): first byte of a four-byte sequence. - */ - if ( c <= '0x07' ) { - count = 1; - } else if ( c >= '0xc2' && c <= '0xdf' ) { - count = 2; - } else if ( c >= '0xe0' && c <= '0xef' ) { - count = 3; - } else if ( c >= '0xf0' && c <= '0xff' ) { - count = 4; + URL_FILE *file; + (void)operation; + + file = calloc(1, sizeof(URL_FILE)); + if(!file) + return NULL; + + file->handle.file = fopen(url, operation); + if(file->handle.file) + file->type = CFTYPE_FILE; /* marked as URL */ + + else { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init(); + + curl_easy_setopt(file->handle.curl, CURLOPT_URL, url); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEDATA, file); + curl_easy_setopt(file->handle.curl, CURLOPT_VERBOSE, 0L); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback); + + if(!multi_handle) + multi_handle = curl_multi_init(); + + curl_multi_add_handle(multi_handle, file->handle.curl); + + /* lets start the fetch */ + curl_multi_perform(multi_handle, &file->still_running); + + if((file->buffer_pos == 0) && (!file->still_running)) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + + free(file); + + file = NULL; } - - return use_buffer( file, c ); + } + return file; } -URL_FILE *url_fopen( const char *url, const char *operation ) { - /* this code could check for URLs or types in the 'url' and - basically use the real fopen() for standard files */ +int url_fclose(URL_FILE *file) +{ + int ret = 0;/* default is good return */ - URL_FILE *file; - ( void ) operation; + switch(file->type) { + case CFTYPE_FILE: + ret = fclose(file->handle.file); /* passthrough */ + break; - file = calloc( 1, sizeof( URL_FILE ) ); - if ( !file ) - return NULL; + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); - file->handle.file = fopen( url, operation ); - if ( file->handle.file ) - file->type = CFTYPE_FILE; /* marked as URL */ + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + break; - else { - file->type = CFTYPE_CURL; /* marked as URL */ - file->handle.curl = curl_easy_init( ); + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; + } - curl_easy_setopt( file->handle.curl, CURLOPT_URL, url ); - curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file ); - curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L ); - curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION, - write_callback ); + free(file->buffer);/* free any allocated buffer space */ + free(file); - if ( !multi_handle ) - multi_handle = curl_multi_init( ); - - curl_multi_add_handle( multi_handle, file->handle.curl ); - - /* lets start the fetch */ - curl_multi_perform( multi_handle, &file->still_running ); - - if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) { - /* if still_running is 0 now, we should return NULL */ - - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle( multi_handle, file->handle.curl ); - - /* cleanup */ - curl_easy_cleanup( file->handle.curl ); - - free( file ); - - file = NULL; - } - } - return file; + return ret; } -int url_fclose( URL_FILE * file ) { - int ret = 0; /* default is good return */ +int url_feof(URL_FILE *file) +{ + int ret = 0; - switch ( file->type ) { - case CFTYPE_FILE: - ret = fclose( file->handle.file ); /* passthrough */ - break; + switch(file->type) { + case CFTYPE_FILE: + ret = feof(file->handle.file); + break; - case CFTYPE_CURL: - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle( multi_handle, file->handle.curl ); + case CFTYPE_CURL: + if((file->buffer_pos == 0) && (!file->still_running)) + ret = 1; + break; - /* cleanup */ - curl_easy_cleanup( file->handle.curl ); - break; - - default: /* unknown or supported type - oh dear */ - ret = EOF; - errno = EBADF; - break; - } - - free( file->buffer ); /* free any allocated buffer space */ - free( file ); - - return ret; + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; } -int url_feof( URL_FILE * file ) { - int ret = 0; +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file) +{ + size_t want; - switch ( file->type ) { - case CFTYPE_FILE: - ret = feof( file->handle.file ); - break; + switch(file->type) { + case CFTYPE_FILE: + want = fread(ptr, size, nmemb, file->handle.file); + break; - case CFTYPE_CURL: - if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) - ret = 1; - break; + case CFTYPE_CURL: + want = nmemb * size; - default: /* unknown or supported type - oh dear */ - ret = -1; - errno = EBADF; - break; - } - return ret; + fill_buffer(file, want); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if(!file->buffer_pos) + return 0; + + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + + use_buffer(file, want); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; } -size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) { - size_t want; +char *url_fgets(char *ptr, size_t size, URL_FILE *file) +{ + size_t want = size - 1;/* always need to leave room for zero termination */ + size_t loop; - switch ( file->type ) { - case CFTYPE_FILE: - want = fread( ptr, size, nmemb, file->handle.file ); - break; + switch(file->type) { + case CFTYPE_FILE: + ptr = fgets(ptr, (int)size, file->handle.file); + break; - case CFTYPE_CURL: - want = nmemb * size; + case CFTYPE_CURL: + fill_buffer(file, want); - fill_buffer( file, want ); + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if(!file->buffer_pos) + return NULL; - /* check if there's data in the buffer - if not fill_buffer() - * either errored or EOF */ - if ( !file->buffer_pos ) - return 0; + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; - /* ensure only available data is considered */ - if ( file->buffer_pos < want ) - want = file->buffer_pos; - - /* xfer data to caller */ - memcpy( ptr, file->buffer, want ); - - use_buffer( file, want ); - - want = want / size; /* number of items */ - break; - - default: /* unknown or supported type - oh dear */ - want = 0; - errno = EBADF; - break; - - } - return want; -} - -char *url_fgets( char *ptr, size_t size, URL_FILE * file ) { - size_t want = size - 1; /* always need to leave room for zero termination */ - size_t loop; - - switch ( file->type ) { - case CFTYPE_FILE: - ptr = fgets( ptr, ( int ) size, file->handle.file ); - break; - - case CFTYPE_CURL: - fill_buffer( file, want ); - - /* check if there's data in the buffer - if not fill either errored or - * EOF */ - if ( !file->buffer_pos ) - return NULL; - - /* ensure only available data is considered */ - if ( file->buffer_pos < want ) - want = file->buffer_pos; - - /*buffer contains data */ - /* look for newline or eof */ - for ( loop = 0; loop < want; loop++ ) { - if ( file->buffer[loop] == '\n' ) { - want = loop + 1; /* include newline */ - break; - } - } - - /* xfer data to caller */ - memcpy( ptr, file->buffer, want ); - ptr[want] = 0; /* always null terminate */ - - use_buffer( file, want ); - - break; - - default: /* unknown or supported type - oh dear */ - ptr = NULL; - errno = EBADF; - break; + /*buffer contains data */ + /* look for newline or eof */ + for(loop = 0; loop < want; loop++) { + if(file->buffer[loop] == '\n') { + want = loop + 1;/* include newline */ + break; + } } - return ptr; /*success */ + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + ptr[want] = 0;/* always null terminate */ + + use_buffer(file, want); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr;/*success */ } -void url_rewind( URL_FILE * file ) { - switch ( file->type ) { - case CFTYPE_FILE: - rewind( file->handle.file ); /* passthrough */ - break; +void url_rewind(URL_FILE *file) +{ + switch(file->type) { + case CFTYPE_FILE: + rewind(file->handle.file); /* passthrough */ + break; - case CFTYPE_CURL: - /* halt transaction */ - curl_multi_remove_handle( multi_handle, file->handle.curl ); + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle(multi_handle, file->handle.curl); - /* restart */ - curl_multi_add_handle( multi_handle, file->handle.curl ); + /* restart */ + curl_multi_add_handle(multi_handle, file->handle.curl); - /* ditch buffer - write will recreate - resets stream pos */ - free( file->buffer ); - file->buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; + /* ditch buffer - write will recreate - resets stream pos*/ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; - break; + break; - default: /* unknown or supported type - oh dear */ - break; - } + default: /* unknown or supported type - oh dear */ + break; + } } -/** - * given this file handle f, return a new url_file handle wrapping it. - * - * @param f the file to be wrapped; - * @return the new handle, or null if no such handle could be allocated. - */ -URL_FILE *file_to_url_file( FILE * f ) { - URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) ); +#ifdef FOPEN_STANDALONE +#define FGETSFILE "fgets.test" +#define FREADFILE "fread.test" +#define REWINDFILE "rewind.test" - if ( result != NULL ) { - result->type = CFTYPE_FILE, result->handle.file = f; - } +/* Small main program to retrieve from a url using fgets and fread saving the + * output to two test files (note the fgets method will corrupt binary files if + * they contain 0 chars */ +int main(int argc, char *argv[]) +{ + URL_FILE *handle; + FILE *outf; - return result; -} - - -/** - * get one wide character from the buffer. - * - * @param file the stream to read from; - * @return the next wide character on the stream, or zero if no more. - */ -wint_t url_fgetwc( URL_FILE * input ) { - wint_t result = -1; - - debug_printf( DEBUG_IO, L"url_fgetwc: ungotten = %d\n", ungotten ); - - if ( ungotten != 0 ) { - /* TODO: not thread safe */ - result = ungotten; - ungotten = 0; - } else { - switch ( input->type ) { - case CFTYPE_FILE: - fwide( input->handle.file, 1 ); /* wide characters */ - result = fgetwc( input->handle.file ); /* passthrough */ - break; - - case CFTYPE_CURL:{ - debug_print( L"url_fgetwc: stream is URL\n", DEBUG_IO ); - - char *cbuff = - calloc( sizeof( wchar_t ) + 1, sizeof( char ) ); - wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); - - size_t count = 0; - - debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO ); - url_fgets( cbuff, 1, input ); - debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); - int c = ( int ) cbuff[0]; - debug_printf( DEBUG_IO, L"url_fgetwc: (first) character = %d (%c)\n", c, c & 0xf7 ); - /* The value of each individual byte indicates its UTF-8 function, as follows: - * - * 00 to 7F hex (0 to 127): first and only byte of a sequence. - * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. - * C2 to DF hex (194 to 223): first byte of a two-byte sequence. - * E0 to EF hex (224 to 239): first byte of a three-byte sequence. - * F0 to FF hex (240 to 255): first byte of a four-byte sequence. - */ - if ( c <= 0x07 ) { - count = 1; - } else if ( c >= '0xc2' && c <= '0xdf' ) { - count = 2; - } else if ( c >= '0xe0' && c <= '0xef' ) { - count = 3; - } else if ( c >= '0xf0' && c <= '0xff' ) { - count = 4; - } - - if ( count > 1 ) { - url_fgets( cbuff, --count, input ); - } - mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); - result = wbuff[0]; - use_one_wide( input ); - - free( wbuff ); - free( cbuff ); - } - break; - case CFTYPE_NONE: - break; - } - } - - debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, - result ); - return result; -} - -wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { - wint_t result = -1; - - switch ( input->type ) { - case CFTYPE_FILE: - fwide( input->handle.file, 1 ); /* wide characters */ - result = ungetwc( wc, input->handle.file ); /* passthrough */ - break; - - case CFTYPE_CURL:{ - ungotten = wc; -// wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); -// char *cbuff = calloc( 5, sizeof( char ) ); -// -// wbuff[0] = wc; -// result = wcstombs( cbuff, wbuff, 1 ); -// -// input->buffer_pos -= strlen( cbuff ); -// -// free( cbuff ); -// free( wbuff ); -// -// result = result > 0 ? wc : result; - break; - case CFTYPE_NONE: - break; - } - } - - return result; + size_t nread; + char buffer[256]; + const char *url; + + CURL *curl; + CURLcode res; + + curl_global_init(CURL_GLOBAL_DEFAULT); + + curl = curl_easy_init(); + + + if(argc < 2) + url = "http://192.168.7.3/testfile";/* default to testurl */ + else + url = argv[1];/* use passed url */ + + /* copy from url line by line with fgets */ + outf = fopen(FGETSFILE, "wb+"); + if(!outf) { + perror("couldn't open fgets output file\n"); + return 1; + } + + handle = url_fopen(url, "r"); + if(!handle) { + printf("couldn't url_fopen() %s\n", url); + fclose(outf); + return 2; + } + + while(!url_feof(handle)) { + url_fgets(buffer, sizeof(buffer), handle); + fwrite(buffer, 1, strlen(buffer), outf); + } + + url_fclose(handle); + + fclose(outf); + + + /* Copy from url with fread */ + outf = fopen(FREADFILE, "wb+"); + if(!outf) { + perror("couldn't open fread output file\n"); + return 1; + } + + handle = url_fopen("testfile", "r"); + if(!handle) { + printf("couldn't url_fopen() testfile\n"); + fclose(outf); + return 2; + } + + do { + nread = url_fread(buffer, 1, sizeof(buffer), handle); + fwrite(buffer, 1, nread, outf); + } while(nread); + + url_fclose(handle); + + fclose(outf); + + + /* Test rewind */ + outf = fopen(REWINDFILE, "wb+"); + if(!outf) { + perror("couldn't open fread output file\n"); + return 1; + } + + handle = url_fopen("testfile", "r"); + if(!handle) { + printf("couldn't url_fopen() testfile\n"); + fclose(outf); + return 2; + } + + nread = url_fread(buffer, 1, sizeof(buffer), handle); + fwrite(buffer, 1, nread, outf); + url_rewind(handle); + + buffer[0]='\n'; + fwrite(buffer, 1, 1, outf); + + nread = url_fread(buffer, 1, sizeof(buffer), handle); + fwrite(buffer, 1, nread, outf); + + url_fclose(handle); + + fclose(outf); + + return 0;/* all done */ } +#endif diff --git a/src/io/fopen.h b/src/io/fopen.h index f952a65..5f87bd2 100644 --- a/src/io/fopen.h +++ b/src/io/fopen.h @@ -80,8 +80,4 @@ size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); char *url_fgets( char *ptr, size_t size, URL_FILE * file ); void url_rewind( URL_FILE * file ); -wint_t url_fgetwc( URL_FILE * file ); -wint_t url_ungetwc( wint_t wc, URL_FILE * input ); -URL_FILE *file_to_url_file( FILE * f ); - #endif diff --git a/src/io/io.c b/src/io/io.c index 4577a11..d7c2024 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -15,6 +15,12 @@ #include "fopen.h" #include "lispops.h" +/** + * Allow a one-character unget facility. This may not be enough - we may need + * to allocate a buffer. + */ +wint_t ungotten = 0; + /** * Convert this lisp string-like-thing (also works for symbols, and, later * keywords) into a UTF-8 string. NOTE that the returned value has been @@ -56,6 +62,129 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { return result; } + +/** + * given this file handle f, return a new url_file handle wrapping it. + * + * @param f the file to be wrapped; + * @return the new handle, or null if no such handle could be allocated. + */ +URL_FILE *file_to_url_file( FILE * f ) { + URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) ); + + if ( result != NULL ) { + result->type = CFTYPE_FILE, result->handle.file = f; + } + + return result; +} + + +/** + * get one wide character from the buffer. + * + * @param file the stream to read from; + * @return the next wide character on the stream, or zero if no more. + */ +wint_t url_fgetwc( URL_FILE * input ) { + wint_t result = -1; + + if ( ungotten != 0 ) { + /* TODO: not thread safe */ + result = ungotten; + ungotten = 0; + } else { + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + char *cbuff = + calloc( sizeof( wchar_t ) + 2, sizeof( char ) ); + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + + size_t count = 0; + + debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO ); + url_fgets( cbuff, 2, input ); + debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); + int c = ( int ) cbuff[0]; + debug_printf( DEBUG_IO, + L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", + cbuff, c, c & 0xf7 ); + /* The value of each individual byte indicates its UTF-8 function, as follows: + * + * 00 to 7F hex (0 to 127): first and only byte of a sequence. + * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. + * C2 to DF hex (194 to 223): first byte of a two-byte sequence. + * E0 to EF hex (224 to 239): first byte of a three-byte sequence. + * F0 to FF hex (240 to 255): first byte of a four-byte sequence. + */ + if ( c <= 0x07 ) { + count = 1; + } else if ( c >= '0xc2' && c <= '0xdf' ) { + count = 2; + } else if ( c >= '0xe0' && c <= '0xef' ) { + count = 3; + } else if ( c >= '0xf0' && c <= '0xff' ) { + count = 4; + } + + if ( count > 1 ) { + url_fgets( (char *)&cbuff[1], count, input ); + } + mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); + result = wbuff[0]; + + free( wbuff ); + free( cbuff ); + } + break; + case CFTYPE_NONE: + break; + } + } + + debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, + result ); + return result; +} + +wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { + wint_t result = -1; + + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = ungetwc( wc, input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + ungotten = wc; +// wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); +// char *cbuff = calloc( 5, sizeof( char ) ); +// +// wbuff[0] = wc; +// result = wcstombs( cbuff, wbuff, 1 ); +// +// input->buffer_pos -= strlen( cbuff ); +// +// free( cbuff ); +// free( wbuff ); +// +// result = result > 0 ? wc : result; + break; + case CFTYPE_NONE: + break; + } + } + + return result; +} + + /** * Function, sort-of: close the file indicated by my first arg, and return * nil. If the first arg is not a stream, does nothing. All other args are @@ -172,7 +301,7 @@ lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL ); result = cursor; - for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ); + for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0; c = url_fgetwc( stream ) ) { debug_print( L"slurp: cursor is: ", DEBUG_IO ); debug_dump_object( cursor, DEBUG_IO ); diff --git a/src/io/io.h b/src/io/io.h index 06dcaed..d46f8b1 100644 --- a/src/io/io.h +++ b/src/io/io.h @@ -11,6 +11,10 @@ #ifndef __psse_io_h #define __psse_io_h +URL_FILE *file_to_url_file( FILE * f ); +wint_t url_fgetwc( URL_FILE * input ); +wint_t url_ungetwc( wint_t wc, URL_FILE * input ); + struct cons_pointer lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 7a1a0d8..54d14e9 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -166,6 +166,10 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.ratio.dividend ); dec_ref( cell->payload.ratio.divisor ); break; + case READTV: + case WRITETV: + url_fclose( cell->payload.stream.stream); + break; case SPECIALTV: dec_ref( cell->payload.special.source ); break; diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 4bfe6f0..1220835 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -29,9 +29,9 @@ #include "debug.h" #include "dump.h" #include "equal.h" -#include "fopen.h" #include "integer.h" #include "intern.h" +#include "io.h" #include "lispops.h" #include "print.h" #include "read.h" diff --git a/src/ops/read.c b/src/ops/read.c index 989aa67..69899c0 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -22,6 +22,7 @@ #include "dump.h" #include "integer.h" #include "intern.h" +#include "io.h" #include "lispops.h" #include "peano.h" #include "print.h" From 10098a83bf8d9e1e21ab8ee1d68c1f912f38e236 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 28 Jan 2019 19:00:29 +0000 Subject: [PATCH 048/101] Made the slurp unit test more robust. --- hi | 1 - unit-tests/slurp.sh | 7 +++++-- 2 files changed, 5 insertions(+), 3 deletions(-) delete mode 100644 hi diff --git a/hi b/hi deleted file mode 100644 index cf57f2a..0000000 --- a/hi +++ /dev/null @@ -1 +0,0 @@ -Hello, this is used by `slurp.sh` test, please do not remove. diff --git a/unit-tests/slurp.sh b/unit-tests/slurp.sh index e285988..b389143 100755 --- a/unit-tests/slurp.sh +++ b/unit-tests/slurp.sh @@ -1,11 +1,14 @@ #!/bin/bash -expected='"Hello, this is used by `slurp.sh` test, please do not remove.' -actual=`echo '(slurp (open "hi"))' | target/psse | tail -2 | head -1` +tmp=hi$$ +echo "Hello, there." > ${tmp} +expected='"Hello, there.' +actual=`echo "(slurp (open \"${tmp}\"))" | target/psse | tail -2 | head -1` if [ "${expected}" = "${actual}" ] then echo "OK" + rm ${tmp} exit 0 else echo "Fail: expected '$expected', got '$actual'" From eb394d153f6a4e586d5f975d89114fbb6668ab8b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 29 Jan 2019 18:31:30 +0000 Subject: [PATCH 049/101] Setting up medatata works... And the `inspect` function correctly shows it. However, the `metadata` function segfaults. --- src/init.c | 76 ++-- src/io/fopen.c | 774 +++++++++++++++++------------------ src/io/io.c | 192 +++++++-- src/io/io.h | 6 + src/memory/conspage.c | 7 +- src/memory/conspage.h | 18 +- src/memory/consspaceobject.c | 102 ++++- src/memory/consspaceobject.h | 56 ++- src/memory/dump.c | 16 +- src/ops/equal.c | 5 +- src/ops/lispops.c | 59 +-- src/ops/lispops.h | 21 +- src/ops/meta.c | 47 +++ src/ops/meta.h | 17 + src/ops/print.c | 9 +- src/ops/read.c | 41 +- 16 files changed, 866 insertions(+), 580 deletions(-) create mode 100644 src/ops/meta.c create mode 100644 src/ops/meta.h diff --git a/src/init.c b/src/init.c index c180b10..6cceadd 100644 --- a/src/init.c +++ b/src/init.c @@ -26,6 +26,7 @@ #include "intern.h" #include "io.h" #include "lispops.h" +#include "meta.h" #include "peano.h" #include "print.h" #include "repl.h" @@ -40,14 +41,17 @@ * more readable and aid debugging generally. */ void bind_function( wchar_t *name, struct cons_pointer ( *executable ) - ( struct stack_frame *, - struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref( n ); + ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ) { + struct cons_pointer n = c_string_to_lisp_symbol( name ); + struct cons_pointer meta = make_cons( + make_cons(c_string_to_lisp_keyword(L"primitive"), TRUE), + make_cons( make_cons( + c_string_to_lisp_keyword(L"name"), + n), + NIL)); - deep_bind( n, make_function( NIL, executable ) ); - - dec_ref( n ); + deep_bind( n, make_function( meta, executable ) ); } /** @@ -58,11 +62,14 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref( n ); + struct cons_pointer meta = make_cons( + make_cons(c_string_to_lisp_keyword(L"primitive"), TRUE), + make_cons( make_cons( + c_string_to_lisp_keyword(L"name"), + n), + NIL)); deep_bind( n, make_special( NIL, executable ) ); - - dec_ref( n ); } /** @@ -87,7 +94,10 @@ int main( int argc, char *argv[] ) { bool show_prompt = false; setlocale( LC_ALL, "" ); - curl_global_init( CURL_GLOBAL_DEFAULT ); + if (io_init() != 0) { + fputs("Failed to initialise I/O subsystem\n", stderr); + exit(1); + } while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { @@ -136,17 +146,40 @@ int main( int argc, char *argv[] ) { fwide( stdout, 1 ); fwide( stderr, 1 ); fwide( sink->handle.file, 1 ); - bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ) ) ); - bind_value( L"*out*", make_write_stream( file_to_url_file( stdout ) ) ); - bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ) ) ); - bind_value( L"*sink*", make_write_stream( sink ) ); - + bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ), + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard input" ) ), + NIL ) ) ); + bind_value( L"*out*", + make_write_stream( file_to_url_file( stdout ), + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard output]" ) ), + NIL ) ) ); + bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ), + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard log" ) ), + NIL ) ) ); + bind_value( L"*sink*", make_write_stream( sink, + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard sink" ) ), + NIL ) ) ); /* * the default prompt */ bind_value( L"*prompt*", show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL ); - /* * primitive function operations */ @@ -164,6 +197,8 @@ int main( int argc, char *argv[] ) { bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); bind_function( L"inspect", &lisp_inspect ); + bind_function( L"meta", &lisp_metadata ); + bind_function( L"metadata", &lisp_metadata ); bind_function( L"multiply", &lisp_multiply ); bind_function( L"negative?", &lisp_is_negative ); bind_function( L"oblist", &lisp_oblist ); @@ -180,13 +215,11 @@ int main( int argc, char *argv[] ) { bind_function( L"subtract", &lisp_subtract ); bind_function( L"throw", &lisp_exception ); bind_function( L"type", &lisp_type ); - 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 */ @@ -198,19 +231,16 @@ int main( int argc, char *argv[] ) { bind_special( L"progn", &lisp_progn ); bind_special( L"quote", &lisp_quote ); bind_special( L"set!", &lisp_set_shriek ); - debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); - repl( show_prompt ); - debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); dec_ref( oblist ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); - if ( dump_at_end ) { dump_pages( file_to_url_file( stdout ) ); } + curl_global_cleanup( ); return ( 0 ); } diff --git a/src/io/fopen.c b/src/io/fopen.c index f0ea012..50c09b5 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -47,392 +47,369 @@ #include -enum fcurl_type_e { - CFTYPE_NONE = 0, - CFTYPE_FILE = 1, - CFTYPE_CURL = 2 -}; +#include "fopen.h" +#ifdef FOPEN_STANDALONE +CURLSH *io_share; +#else +#include "io.h" +#include "consspaceobject.h" +#endif -struct fcurl_data -{ - enum fcurl_type_e type; /* type of handle */ - union { - CURL *curl; - FILE *file; - } handle; /* handle */ - - char *buffer; /* buffer to store cached data*/ - size_t buffer_len; /* currently allocated buffers length */ - size_t buffer_pos; /* end of data in buffer*/ - int still_running; /* Is background url fetch still in progress */ -}; - -typedef struct fcurl_data URL_FILE; /* exported functions */ -URL_FILE *url_fopen(const char *url, const char *operation); -int url_fclose(URL_FILE *file); -int url_feof(URL_FILE *file); -size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file); -char *url_fgets(char *ptr, size_t size, URL_FILE *file); -void url_rewind(URL_FILE *file); +URL_FILE *url_fopen( const char *url, const char *operation ); +int url_fclose( URL_FILE * file ); +int url_feof( URL_FILE * file ); +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); +char *url_fgets( char *ptr, size_t size, URL_FILE * file ); +void url_rewind( URL_FILE * file ); /* we use a global one for convenience */ static CURLM *multi_handle; /* curl calls this routine to get more data */ -static size_t write_callback(char *buffer, - size_t size, - size_t nitems, - void *userp) -{ - char *newbuff; - size_t rembuff; +static size_t write_callback( char *buffer, + size_t size, size_t nitems, void *userp ) { + char *newbuff; + size_t rembuff; - URL_FILE *url = (URL_FILE *)userp; - size *= nitems; + URL_FILE *url = ( URL_FILE * ) userp; + size *= nitems; - rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ - if(size > rembuff) { - /* not enough space in buffer */ - newbuff = realloc(url->buffer, url->buffer_len + (size - rembuff)); - if(newbuff == NULL) { - fprintf(stderr, "callback buffer grow failed\n"); - size = rembuff; + if ( size > rembuff ) { + /* not enough space in buffer */ + newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) ); + if ( newbuff == NULL ) { + fprintf( stderr, "callback buffer grow failed\n" ); + size = rembuff; + } else { + /* realloc succeeded increase buffer size */ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } } - else { - /* realloc succeeded increase buffer size*/ - url->buffer_len += size - rembuff; - url->buffer = newbuff; - } - } - memcpy(&url->buffer[url->buffer_pos], buffer, size); - url->buffer_pos += size; + memcpy( &url->buffer[url->buffer_pos], buffer, size ); + url->buffer_pos += size; - return size; + return size; } /* use to attempt to fill the read buffer up to requested number of bytes */ -static int fill_buffer(URL_FILE *file, size_t want) -{ - fd_set fdread; - fd_set fdwrite; - fd_set fdexcep; - struct timeval timeout; - int rc; - CURLMcode mc; /* curl_multi_fdset() return code */ +static int fill_buffer( URL_FILE * file, size_t want ) { + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ - /* only attempt to fill buffer if transactions still running and buffer - * doesn't exceed required size already - */ - if((!file->still_running) || (file->buffer_pos > want)) - return 0; + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if ( ( !file->still_running ) || ( file->buffer_pos > want ) ) + return 0; - /* attempt to fill buffer */ - do { - int maxfd = -1; - long curl_timeo = -1; + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; - FD_ZERO(&fdread); - FD_ZERO(&fdwrite); - FD_ZERO(&fdexcep); + FD_ZERO( &fdread ); + FD_ZERO( &fdwrite ); + FD_ZERO( &fdexcep ); - /* set a suitable timeout to fail on */ - timeout.tv_sec = 60; /* 1 minute */ - timeout.tv_usec = 0; + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; - curl_multi_timeout(multi_handle, &curl_timeo); - if(curl_timeo >= 0) { - timeout.tv_sec = curl_timeo / 1000; - if(timeout.tv_sec > 1) - timeout.tv_sec = 1; - else - timeout.tv_usec = (curl_timeo % 1000) * 1000; - } + curl_multi_timeout( multi_handle, &curl_timeo ); + if ( curl_timeo >= 0 ) { + timeout.tv_sec = curl_timeo / 1000; + if ( timeout.tv_sec > 1 ) + timeout.tv_sec = 1; + else + timeout.tv_usec = ( curl_timeo % 1000 ) * 1000; + } - /* get file descriptors from the transfers */ - mc = curl_multi_fdset(multi_handle, &fdread, &fdwrite, &fdexcep, &maxfd); + /* get file descriptors from the transfers */ + mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep, + &maxfd ); - if(mc != CURLM_OK) { - fprintf(stderr, "curl_multi_fdset() failed, code %d.\n", mc); - break; - } + if ( mc != CURLM_OK ) { + fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc ); + break; + } - /* On success the value of maxfd is guaranteed to be >= -1. We call - select(maxfd + 1, ...); specially in case of (maxfd == -1) there are - no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- - to sleep 100ms, which is the minimum suggested value in the - curl_multi_fdset() doc. */ + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ - if(maxfd == -1) { + if ( maxfd == -1 ) { #ifdef _WIN32 - Sleep(100); - rc = 0; + Sleep( 100 ); + rc = 0; #else - /* Portable sleep for platforms other than Windows. */ - struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ - rc = select(0, NULL, NULL, NULL, &wait); + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select( 0, NULL, NULL, NULL, &wait ); #endif - } - else { - /* Note that on some platforms 'timeout' may be modified by select(). - If you need access to the original value save a copy beforehand. */ - rc = select(maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout); - } + } else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout ); + } - switch(rc) { - case -1: - /* select error */ - break; + switch ( rc ) { + case -1: + /* select error */ + break; - case 0: - default: - /* timeout or readable/writable sockets */ - curl_multi_perform(multi_handle, &file->still_running); - break; - } - } while(file->still_running && (file->buffer_pos < want)); - return 1; + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform( multi_handle, &file->still_running ); + break; + } + } while ( file->still_running && ( file->buffer_pos < want ) ); + return 1; } /* use to remove want bytes from the front of a files buffer */ -static int use_buffer(URL_FILE *file, size_t want) -{ - /* sort out buffer */ - if((file->buffer_pos - want) <= 0) { - /* ditch buffer - write will recreate */ - free(file->buffer); - file->buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; - } - else { - /* move rest down make it available for later */ - memmove(file->buffer, - &file->buffer[want], - (file->buffer_pos - want)); +static int use_buffer( URL_FILE * file, size_t want ) { + /* sort out buffer */ + if ( ( file->buffer_pos - want ) <= 0 ) { + /* ditch buffer - write will recreate */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } else { + /* move rest down make it available for later */ + memmove( file->buffer, + &file->buffer[want], ( file->buffer_pos - want ) ); - file->buffer_pos -= want; - } - return 0; -} - -URL_FILE *url_fopen(const char *url, const char *operation) -{ - /* this code could check for URLs or types in the 'url' and - basically use the real fopen() for standard files */ - - URL_FILE *file; - (void)operation; - - file = calloc(1, sizeof(URL_FILE)); - if(!file) - return NULL; - - file->handle.file = fopen(url, operation); - if(file->handle.file) - file->type = CFTYPE_FILE; /* marked as URL */ - - else { - file->type = CFTYPE_CURL; /* marked as URL */ - file->handle.curl = curl_easy_init(); - - curl_easy_setopt(file->handle.curl, CURLOPT_URL, url); - curl_easy_setopt(file->handle.curl, CURLOPT_WRITEDATA, file); - curl_easy_setopt(file->handle.curl, CURLOPT_VERBOSE, 0L); - curl_easy_setopt(file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback); - - if(!multi_handle) - multi_handle = curl_multi_init(); - - curl_multi_add_handle(multi_handle, file->handle.curl); - - /* lets start the fetch */ - curl_multi_perform(multi_handle, &file->still_running); - - if((file->buffer_pos == 0) && (!file->still_running)) { - /* if still_running is 0 now, we should return NULL */ - - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle(multi_handle, file->handle.curl); - - /* cleanup */ - curl_easy_cleanup(file->handle.curl); - - free(file); - - file = NULL; + file->buffer_pos -= want; } - } - return file; + return 0; } -int url_fclose(URL_FILE *file) -{ - int ret = 0;/* default is good return */ +URL_FILE *url_fopen( const char *url, const char *operation ) { + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ - switch(file->type) { - case CFTYPE_FILE: - ret = fclose(file->handle.file); /* passthrough */ - break; + URL_FILE *file; + ( void ) operation; - case CFTYPE_CURL: - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle(multi_handle, file->handle.curl); + file = calloc( 1, sizeof( URL_FILE ) ); + if ( !file ) + return NULL; - /* cleanup */ - curl_easy_cleanup(file->handle.curl); - break; + file->handle.file = fopen( url, operation ); + if ( file->handle.file ) + file->type = CFTYPE_FILE; /* marked as URL */ - default: /* unknown or supported type - oh dear */ - ret = EOF; - errno = EBADF; - break; - } + else { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init( ); - free(file->buffer);/* free any allocated buffer space */ - free(file); + curl_easy_setopt( file->handle.curl, CURLOPT_URL, url ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file ); + curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION, + write_callback ); + /* use the share object */ + curl_easy_setopt(file->handle.curl, CURLOPT_SHARE, io_share); - return ret; + + if ( !multi_handle ) + multi_handle = curl_multi_init( ); + + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* lets start the fetch */ + curl_multi_perform( multi_handle, &file->still_running ); + + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + + free( file ); + + file = NULL; + } + } + return file; } -int url_feof(URL_FILE *file) -{ - int ret = 0; +int url_fclose( URL_FILE * file ) { + int ret = 0; /* default is good return */ - switch(file->type) { - case CFTYPE_FILE: - ret = feof(file->handle.file); - break; + switch ( file->type ) { + case CFTYPE_FILE: + ret = fclose( file->handle.file ); /* passthrough */ + break; - case CFTYPE_CURL: - if((file->buffer_pos == 0) && (!file->still_running)) - ret = 1; - break; + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); - default: /* unknown or supported type - oh dear */ - ret = -1; - errno = EBADF; - break; - } - return ret; -} + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + break; -size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file) -{ - size_t want; - - switch(file->type) { - case CFTYPE_FILE: - want = fread(ptr, size, nmemb, file->handle.file); - break; - - case CFTYPE_CURL: - want = nmemb * size; - - fill_buffer(file, want); - - /* check if there's data in the buffer - if not fill_buffer() - * either errored or EOF */ - if(!file->buffer_pos) - return 0; - - /* ensure only available data is considered */ - if(file->buffer_pos < want) - want = file->buffer_pos; - - /* xfer data to caller */ - memcpy(ptr, file->buffer, want); - - use_buffer(file, want); - - want = want / size; /* number of items */ - break; - - default: /* unknown or supported type - oh dear */ - want = 0; - errno = EBADF; - break; - - } - return want; -} - -char *url_fgets(char *ptr, size_t size, URL_FILE *file) -{ - size_t want = size - 1;/* always need to leave room for zero termination */ - size_t loop; - - switch(file->type) { - case CFTYPE_FILE: - ptr = fgets(ptr, (int)size, file->handle.file); - break; - - case CFTYPE_CURL: - fill_buffer(file, want); - - /* check if there's data in the buffer - if not fill either errored or - * EOF */ - if(!file->buffer_pos) - return NULL; - - /* ensure only available data is considered */ - if(file->buffer_pos < want) - want = file->buffer_pos; - - /*buffer contains data */ - /* look for newline or eof */ - for(loop = 0; loop < want; loop++) { - if(file->buffer[loop] == '\n') { - want = loop + 1;/* include newline */ - break; - } + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; } - /* xfer data to caller */ - memcpy(ptr, file->buffer, want); - ptr[want] = 0;/* always null terminate */ + free( file->buffer ); /* free any allocated buffer space */ + free( file ); - use_buffer(file, want); - - break; - - default: /* unknown or supported type - oh dear */ - ptr = NULL; - errno = EBADF; - break; - } - - return ptr;/*success */ + return ret; } -void url_rewind(URL_FILE *file) -{ - switch(file->type) { - case CFTYPE_FILE: - rewind(file->handle.file); /* passthrough */ - break; +int url_feof( URL_FILE * file ) { + int ret = 0; - case CFTYPE_CURL: - /* halt transaction */ - curl_multi_remove_handle(multi_handle, file->handle.curl); + switch ( file->type ) { + case CFTYPE_FILE: + ret = feof( file->handle.file ); + break; - /* restart */ - curl_multi_add_handle(multi_handle, file->handle.curl); + case CFTYPE_CURL: + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) + ret = 1; + break; - /* ditch buffer - write will recreate - resets stream pos*/ - free(file->buffer); - file->buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; +} - break; +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) { + size_t want; - default: /* unknown or supported type - oh dear */ - break; - } + switch ( file->type ) { + case CFTYPE_FILE: + want = fread( ptr, size, nmemb, file->handle.file ); + break; + + case CFTYPE_CURL: + want = nmemb * size; + + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if ( !file->buffer_pos ) + return 0; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + + use_buffer( file, want ); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; +} + +char *url_fgets( char *ptr, size_t size, URL_FILE * file ) { + size_t want = size - 1; /* always need to leave room for zero termination */ + size_t loop; + + switch ( file->type ) { + case CFTYPE_FILE: + ptr = fgets( ptr, ( int ) size, file->handle.file ); + break; + + case CFTYPE_CURL: + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if ( !file->buffer_pos ) + return NULL; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /*buffer contains data */ + /* look for newline or eof */ + for ( loop = 0; loop < want; loop++ ) { + if ( file->buffer[loop] == '\n' ) { + want = loop + 1; /* include newline */ + break; + } + } + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + ptr[want] = 0; /* always null terminate */ + + use_buffer( file, want ); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr; /*success */ +} + +void url_rewind( URL_FILE * file ) { + switch ( file->type ) { + case CFTYPE_FILE: + rewind( file->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* restart */ + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* ditch buffer - write will recreate - resets stream pos */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + + break; + + default: /* unknown or supported type - oh dear */ + break; + } } #ifdef FOPEN_STANDALONE @@ -443,104 +420,103 @@ void url_rewind(URL_FILE *file) /* Small main program to retrieve from a url using fgets and fread saving the * output to two test files (note the fgets method will corrupt binary files if * they contain 0 chars */ -int main(int argc, char *argv[]) -{ - URL_FILE *handle; - FILE *outf; +int main( int argc, char *argv[] ) { + URL_FILE *handle; + FILE *outf; - size_t nread; - char buffer[256]; - const char *url; + size_t nread; + char buffer[256]; + const char *url; - CURL *curl; - CURLcode res; + CURL *curl; + CURLcode res; - curl_global_init(CURL_GLOBAL_DEFAULT); + curl_global_init( CURL_GLOBAL_DEFAULT ); - curl = curl_easy_init(); + curl = curl_easy_init( ); - if(argc < 2) - url = "http://192.168.7.3/testfile";/* default to testurl */ - else - url = argv[1];/* use passed url */ + if ( argc < 2 ) + url = "http://192.168.7.3/testfile"; /* default to testurl */ + else + url = argv[1]; /* use passed url */ - /* copy from url line by line with fgets */ - outf = fopen(FGETSFILE, "wb+"); - if(!outf) { - perror("couldn't open fgets output file\n"); - return 1; - } + /* copy from url line by line with fgets */ + outf = fopen( FGETSFILE, "wb+" ); + if ( !outf ) { + perror( "couldn't open fgets output file\n" ); + return 1; + } - handle = url_fopen(url, "r"); - if(!handle) { - printf("couldn't url_fopen() %s\n", url); - fclose(outf); - return 2; - } + handle = url_fopen( url, "r" ); + if ( !handle ) { + printf( "couldn't url_fopen() %s\n", url ); + fclose( outf ); + return 2; + } - while(!url_feof(handle)) { - url_fgets(buffer, sizeof(buffer), handle); - fwrite(buffer, 1, strlen(buffer), outf); - } + while ( !url_feof( handle ) ) { + url_fgets( buffer, sizeof( buffer ), handle ); + fwrite( buffer, 1, strlen( buffer ), outf ); + } - url_fclose(handle); + url_fclose( handle ); - fclose(outf); + fclose( outf ); - /* Copy from url with fread */ - outf = fopen(FREADFILE, "wb+"); - if(!outf) { - perror("couldn't open fread output file\n"); - return 1; - } + /* Copy from url with fread */ + outf = fopen( FREADFILE, "wb+" ); + if ( !outf ) { + perror( "couldn't open fread output file\n" ); + return 1; + } - handle = url_fopen("testfile", "r"); - if(!handle) { - printf("couldn't url_fopen() testfile\n"); - fclose(outf); - return 2; - } + handle = url_fopen( "testfile", "r" ); + if ( !handle ) { + printf( "couldn't url_fopen() testfile\n" ); + fclose( outf ); + return 2; + } - do { - nread = url_fread(buffer, 1, sizeof(buffer), handle); - fwrite(buffer, 1, nread, outf); - } while(nread); + do { + nread = url_fread( buffer, 1, sizeof( buffer ), handle ); + fwrite( buffer, 1, nread, outf ); + } while ( nread ); - url_fclose(handle); + url_fclose( handle ); - fclose(outf); + fclose( outf ); - /* Test rewind */ - outf = fopen(REWINDFILE, "wb+"); - if(!outf) { - perror("couldn't open fread output file\n"); - return 1; - } + /* Test rewind */ + outf = fopen( REWINDFILE, "wb+" ); + if ( !outf ) { + perror( "couldn't open fread output file\n" ); + return 1; + } - handle = url_fopen("testfile", "r"); - if(!handle) { - printf("couldn't url_fopen() testfile\n"); - fclose(outf); - return 2; - } + handle = url_fopen( "testfile", "r" ); + if ( !handle ) { + printf( "couldn't url_fopen() testfile\n" ); + fclose( outf ); + return 2; + } - nread = url_fread(buffer, 1, sizeof(buffer), handle); - fwrite(buffer, 1, nread, outf); - url_rewind(handle); + nread = url_fread( buffer, 1, sizeof( buffer ), handle ); + fwrite( buffer, 1, nread, outf ); + url_rewind( handle ); - buffer[0]='\n'; - fwrite(buffer, 1, 1, outf); + buffer[0] = '\n'; + fwrite( buffer, 1, 1, outf ); - nread = url_fread(buffer, 1, sizeof(buffer), handle); - fwrite(buffer, 1, nread, outf); + nread = url_fread( buffer, 1, sizeof( buffer ), handle ); + fwrite( buffer, 1, nread, outf ); - url_fclose(handle); + url_fclose( handle ); - fclose(outf); + fclose( outf ); - return 0;/* all done */ + return 0; /* all done */ } #endif diff --git a/src/io/io.c b/src/io/io.c index d7c2024..3d9eb36 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -8,6 +8,17 @@ */ #include +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include #include "conspage.h" #include "consspaceobject.h" @@ -15,12 +26,42 @@ #include "fopen.h" #include "lispops.h" +/** + * The sharing hub for all connections. TODO: Ultimately this probably doesn't + * work for a multi-user environment and we will need one sharing hub for each + * user, or else we will need to not share at least cookies and ssl sessions. + */ +CURLSH *io_share; + /** * Allow a one-character unget facility. This may not be enough - we may need * to allocate a buffer. */ wint_t ungotten = 0; +/** + * Initialise the I/O subsystem. + * + * @return 0 on success; any other value means failure. + */ +int io_init() { + CURL *curl; + CURLcode res; + int result = curl_global_init( CURL_GLOBAL_SSL ); + + io_share = curl_share_init(); + + if (result == 0) { + curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_CONNECT); + curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE ); + curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS ); + curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_SSL_SESSION ); + curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL ); + } + + return result; +} + /** * Convert this lisp string-like-thing (also works for symbols, and, later * keywords) into a UTF-8 string. NOTE that the returned value has been @@ -107,13 +148,15 @@ wint_t url_fgetwc( URL_FILE * input ) { size_t count = 0; - debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO ); + debug_print( L"url_fgetwc: about to call url_fgets\n", + DEBUG_IO ); url_fgets( cbuff, 2, input ); - debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); + debug_print( L"url_fgetwc: back from url_fgets\n", + DEBUG_IO ); int c = ( int ) cbuff[0]; debug_printf( DEBUG_IO, - L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", - cbuff, c, c & 0xf7 ); + L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", + cbuff, c, c & 0xf7 ); /* The value of each individual byte indicates its UTF-8 function, as follows: * * 00 to 7F hex (0 to 127): first and only byte of a sequence. @@ -133,7 +176,7 @@ wint_t url_fgetwc( URL_FILE * input ) { } if ( count > 1 ) { - url_fgets( (char *)&cbuff[1], count, input ); + url_fgets( ( char * ) &cbuff[1], count, input ); } mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); result = wbuff[0]; @@ -163,18 +206,6 @@ wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { case CFTYPE_CURL:{ ungotten = wc; -// wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); -// char *cbuff = calloc( 5, sizeof( char ) ); -// -// wbuff[0] = wc; -// result = wcstombs( cbuff, wbuff, 1 ); -// -// input->buffer_pos -= strlen( cbuff ); -// -// free( cbuff ); -// free( wbuff ); -// -// result = result > 0 ? wc : result; break; case CFTYPE_NONE: break; @@ -212,6 +243,85 @@ lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, return result; } +int index_of( char c, char * s) { + int i; + + for (i = 0; s[i] != c && s[i] != 0; i++); + + return s[i] == c ? i : -1; +} + +char * trim(char *s) { + int i; + + for (i = strlen(s); (isblank(s[i]) || iscntrl(s[i])) && i > -1; i--) { + s[i] = (char) 0; + } + for (i = 0; isblank(s[i]) && s[i] != 0; i++); + + return (char *)&s[i]; +} + +/** + * Callback to assemble metadata for a URL stream. This is naughty because + * it modifies data, but it's really the only way to create metadata. + */ +static size_t write_meta_callback(void *ptr, size_t size, size_t nmemb, struct cons_pointer stream) +{ + struct cons_space_object * cell = &pointer2cell(stream); + + if (strncmp(&cell->tag.bytes[0], READTAG, 4) || + strncmp(&cell->tag.bytes[0], WRITETAG, 4)) { + char * s = (char *)ptr; + int offset = index_of (':', ptr); + + if (offset != -1) { + s[offset] = (char)0; + char * name = s; + char * value = trim( &s[++offset]); + wchar_t * wname = calloc(strlen(name), sizeof(wchar_t)); + wchar_t * wvalue = calloc(strlen(value), sizeof(wchar_t)); + + mbstowcs(wname, name, strlen(name)); + mbstowcs(wvalue, value, strlen(value)); + + cell->payload.stream.meta = make_cons( + make_cons( + c_string_to_lisp_keyword( wname), + c_string_to_lisp_string(wvalue)), + cell->payload.stream.meta); + + debug_printf( DEBUG_IO, L"write_meta_callback: added header '%s': value '%s'\n", name, value); + } + } else { + debug_print( L"Pointer passed to write_meta_callback did not point to a stream: ", DEBUG_IO); + debug_dump_object(stream, DEBUG_IO); + } + + return nmemb; +} + + +void collect_meta( struct cons_pointer stream, struct cons_pointer url ) { + URL_FILE * s = pointer2cell(stream).payload.stream.stream; + + switch ( s->type ) { + case CFTYPE_NONE: + break; + case CFTYPE_FILE: + /* don't know whether you can get metadata on an open stream in C, + * although we could of course get it from the URL */ + break; + case CFTYPE_CURL: + curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L ); + curl_easy_setopt( s->handle.curl, CURLOPT_HEADER, 1L ); + curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION, write_meta_callback); + curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream); + break; + } +} + + /** * Function: return a stream open on the URL indicated by the first argument; * if a second argument is present and is non-nil, open it for reading. At @@ -228,28 +338,38 @@ lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, * on my stream, if any, else NIL. */ struct cons_pointer -lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; + lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; - if ( stringp( frame->arg[0] ) ) { - char *url = lisp_string_to_c_string( frame->arg[0] ); + if ( stringp( frame->arg[0] ) ) { + struct cons_pointer meta = + make_cons( make_cons( + c_string_to_lisp_keyword( L"url" ), + frame->arg[0] ), + NIL ); - if ( nilp( frame->arg[1] ) ) { - result = make_read_stream( url_fopen( url, "r" ) ); - } else { - // TODO: anything more complex is a problem for another day. - result = make_write_stream( url_fopen( url, "w" ) ); - } + char *url = lisp_string_to_c_string( frame->arg[0] ); - free( url ); - - if ( pointer2cell( result ).payload.stream.stream == NULL ) { - result = NIL; - } + if ( nilp( frame->arg[1] ) ) { + URL_FILE *stream = url_fopen( url, "r" ); + result = make_read_stream( stream, meta ); + } else { + // TODO: anything more complex is a problem for another day. + URL_FILE *stream = url_fopen( url, "w" ); + result = make_write_stream( stream, meta); } - return result; + free( url ); + + if ( pointer2cell( result ).payload.stream.stream == NULL ) { + result = NIL; + } else { + collect_meta( result, frame->arg[0]); + } + } + + return result; } /** @@ -272,8 +392,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload.stream. - stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload. + stream.stream ), NIL ); } return result; diff --git a/src/io/io.h b/src/io/io.h index d46f8b1..167660b 100644 --- a/src/io/io.h +++ b/src/io/io.h @@ -10,6 +10,12 @@ #ifndef __psse_io_h #define __psse_io_h +#include +#include "consspaceobject.h" + +extern CURLSH *io_share; + +int io_init(); URL_FILE *file_to_url_file( FILE * f ); wint_t url_fgetwc( URL_FILE * input ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 54d14e9..5f8c3a8 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -152,7 +152,7 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.exception.frame ); break; case FUNCTIONTV: - dec_ref( cell->payload.function.source ); + dec_ref( cell->payload.function.meta ); break; case INTEGERTV: dec_ref( cell->payload.integer.more ); @@ -168,10 +168,11 @@ void free_cell( struct cons_pointer pointer ) { break; case READTV: case WRITETV: - url_fclose( cell->payload.stream.stream); + dec_ref(cell->payload.stream.meta); + url_fclose( cell->payload.stream.stream ); break; case SPECIALTV: - dec_ref( cell->payload.special.source ); + dec_ref( cell->payload.special.meta ); break; case STRINGTV: case SYMBOLTV: diff --git a/src/memory/conspage.h b/src/memory/conspage.h index fa11da9..f13a46b 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -1,7 +1,19 @@ -#include "consspaceobject.h" +/* + * conspage.h + * + * Setup and tear down cons pages, and (FOR NOW) do primitive + * allocation/deallocation of cells. + * NOTE THAT before we go multi-threaded, these functions must be + * aggressively + * thread safe. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ +#ifndef __psse_conspage_h +#define __psse_conspage_h -#ifndef __conspage_h -#define __conspage_h +#include "consspaceobject.h" /** * the number of cons cells on a cons page. The maximum value this can diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 9edbf66..f7b5ca9 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -21,6 +21,7 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "intern.h" #include "print.h" #include "stack.h" @@ -65,6 +66,48 @@ void dec_ref( struct cons_pointer pointer ) { } +/** + * Get the Lisp type of the single argument. + * @param pointer a pointer to the object whose type is requested. + * @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 result = NIL; + struct cons_space_object cell = pointer2cell( pointer ); + + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = make_string( ( wchar_t ) cell.tag.bytes[i], result ); + } + + return result; +} + +/** + * Implementation of car in C. If arg is not a cons, does not error but returns nil. + */ +struct cons_pointer c_car( struct cons_pointer arg ) { + struct cons_pointer result = NIL; + + if ( consp( arg ) ) { + result = pointer2cell( arg ).payload.cons.car; + } + + return result; +} + +/** + * Implementation of cdr in C. If arg is not a cons, does not error but returns nil. + */ +struct cons_pointer c_cdr( struct cons_pointer arg ) { + struct cons_pointer result = NIL; + + if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) { + result = pointer2cell( arg ).payload.cons.cdr; + } + + return result; +} + /** * Construct a cons cell from this pair of pointers. */ @@ -107,16 +150,17 @@ struct cons_pointer make_exception( struct cons_pointer message, /** - * Construct a cell which points to an executable Lisp special form. + * Construct a cell which points to an executable Lisp function. */ struct cons_pointer -make_function( struct cons_pointer src, struct cons_pointer ( *executable ) +make_function( struct cons_pointer meta, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); + inc_ref( meta); - cell->payload.function.source = src; + cell->payload.function.meta = meta; cell->payload.function.executable = executable; return pointer; @@ -203,27 +247,42 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { } /** - * Construct a symbol from the character `c` and this `tail`. A symbol is - * internally identical to a string except for having a different tag. + * Construct a symbol or keyword from the character `c` and this `tail`. + * Each is internally identical to a string except for having a different tag. * * @param c the character to add (prepend); * @param tail the symbol which is being built. + * @param tag the tag to use: expected to be "SYMB" or "KEYW" */ -struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { - return make_string_like_thing( c, tail, SYMBOLTAG ); +struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, + char *tag ) { + struct cons_pointer result = make_string_like_thing( c, tail, tag ); + + if ( strncmp( tag, KEYTAG, 4 ) == 0 ) { + struct cons_pointer r = internedp( result, oblist ); + + if ( nilp(r)) { + intern(result, oblist); + } else { + result = r; + } + } + + return result; } /** * Construct a cell which points to an executable Lisp special form. */ struct cons_pointer -make_special( struct cons_pointer src, struct cons_pointer ( *executable ) +make_special( struct cons_pointer meta, struct cons_pointer ( *executable ) ( struct stack_frame * frame, struct cons_pointer, struct cons_pointer env ) ) { struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); + inc_ref( meta); - cell->payload.special.source = src; + cell->payload.special.meta = meta; cell->payload.special.executable = executable; return pointer; @@ -232,12 +291,16 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable ) /** * Construct a cell which points to a stream open for reading. * @param input the C stream to wrap. + * @param metadata a pointer to an associaton containing metadata on the stream. + * @return a pointer to the new read stream. */ -struct cons_pointer make_read_stream( URL_FILE * input ) { +struct cons_pointer make_read_stream( URL_FILE * input, + struct cons_pointer metadata ) { struct cons_pointer pointer = allocate_cell( READTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = input; + cell->payload.stream.meta = metadata; return pointer; } @@ -245,16 +308,33 @@ struct cons_pointer make_read_stream( URL_FILE * input ) { /** * Construct a cell which points to a stream open for writing. * @param output the C stream to wrap. + * @param metadata a pointer to an associaton containing metadata on the stream. + * @return a pointer to the new read stream. */ -struct cons_pointer make_write_stream( URL_FILE * output ) { +struct cons_pointer make_write_stream( URL_FILE * output, + struct cons_pointer metadata ) { struct cons_pointer pointer = allocate_cell( WRITETAG ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = output; + cell->payload.stream.meta = metadata; return pointer; } +/** + * Return a lisp keyword representation of this wide character string. + */ +struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { + struct cons_pointer result = NIL; + + for ( int i = wcslen( symbol ); i > 0; i-- ) { + result = make_keyword( symbol[i - 1], result ); + } + + return result; +} + /** * Return a lisp string representation of this wide character string. */ diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 6230e64..1bbbcd1 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -8,6 +8,9 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#ifndef __psse_consspaceobject_h +#define __psse_consspaceobject_h + #include #include #include @@ -19,8 +22,6 @@ #include "fopen.h" -#ifndef __consspaceobject_h -#define __consspaceobject_h /** * The length of a tag, in bytes. @@ -39,6 +40,7 @@ /** * The string `CONS`, considered as an `unsigned int`. + * @todo tag values should be collected into an enum. */ #define CONSTV 1397641027 @@ -85,6 +87,16 @@ */ #define INTEGERTV 1381256777 +/** + * A keyword - an interned, self-evaluating string. + */ +#define KEYTAG "KEYW" + +/** + * The string `KEYW`, considered as an `unsigned int`. + */ +#define KEYTV 1465468235 + /** * A lambda cell. Lambdas are the interpretable (source) versions of functions. * \see FUNCTIONTAG. @@ -258,6 +270,11 @@ */ #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) +/** + * true if `conspoint` points to a keyword, else false + */ +#define keywordp(conspoint) (check_tag(conspoint,KEYTAG)) + /** * true if `conspoint` points to a special Lambda cell, else false */ @@ -320,6 +337,8 @@ */ #define writep(conspoint) (check_tag(conspoint,WRITETAG)) +#define streamp(conspoint) (check_tag(conspoint,READTAG)||check_tag(conspoint,WRITETAG)) + /** * true if `conspoint` points to a true cell, else false * (there should only be one of these so it's slightly redundant). @@ -397,10 +416,9 @@ struct exception_payload { */ struct function_payload { /** - * pointer to the source from which the function was compiled, or NIL - * if it is a primitive. + * pointer to metadata (e.g. the source from which the function was compiled). */ - struct cons_pointer source; + struct cons_pointer meta; /** pointer to a function which takes a cons pointer (representing * its argument list) and a cons pointer (representing its environment) and a * stack frame (representing the previous stack frame) as arguments and returns @@ -475,7 +493,7 @@ struct special_payload { * pointer to the source from which the special form was compiled, or NIL * if it is a primitive. */ - struct cons_pointer source; + struct cons_pointer meta; /** pointer to a function which takes a cons pointer (representing * its argument list) and a cons pointer (representing its environment) and a * stack frame (representing the previous stack frame) as arguments and returns @@ -500,8 +518,9 @@ struct stream_payload { /** * payload of a string cell. At least at first, only one UTF character will * be stored in each cell. The doctrine that 'a symbol is just a string' - * didn't work; however, the payload of a symbol cell is identical to the - * payload of a string cell. + * didn't work; however, the payload of a symbol or keyword cell is identical + * to the payload of a string cell, except that a keyword may store a hash + * of its own value in the padding. */ struct string_payload { /** the actual character stored in this cell */ @@ -614,6 +633,12 @@ void inc_ref( struct cons_pointer pointer ); void dec_ref( struct cons_pointer pointer ); +struct cons_pointer c_type( struct cons_pointer pointer ); + +struct cons_pointer c_car( struct cons_pointer arg ); + +struct cons_pointer c_cdr( struct cons_pointer arg ); + struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ); @@ -626,6 +651,8 @@ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer, struct cons_pointer ) ); +struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ); + struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ); @@ -640,11 +667,18 @@ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); -struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); +struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, + char *tag ); -struct cons_pointer make_read_stream( URL_FILE * input ); +#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTAG)) -struct cons_pointer make_write_stream( URL_FILE * output ); +#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTAG)) + +struct cons_pointer make_read_stream( URL_FILE * input, + struct cons_pointer metadata ); + +struct cons_pointer make_write_stream( URL_FILE * output, + struct cons_pointer metadata ); struct cons_pointer c_string_to_lisp_string( wchar_t *string ); diff --git a/src/memory/dump.c b/src/memory/dump.c index e99d306..7f7701f 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -108,13 +108,15 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { case RATIOTV: url_fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); break; case READTV: - url_fwprintf( output, L"\t\tInput stream\n" ); + url_fputws( L"\t\tInput stream; metadata: ", output ); + print(output, cell.payload.stream.meta); + url_fputws( L"\n", output ); break; case REALTV: url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", @@ -148,7 +150,9 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { } break; case WRITETV: - url_fwprintf( output, L"\t\tOutput stream\n" ); + url_fputws( L"\t\tOutput stream; metadata: ", output ); + print(output, cell.payload.stream.meta); + url_fputws( L"\n", output ); break; } } diff --git a/src/ops/equal.c b/src/ops/equal.c index 2775218..c4d7f54 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -67,6 +67,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr ); break; + case KEYTV: case STRINGTV: case SYMBOLTV: /* @@ -80,8 +81,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload. - string.cdr ) ) ); + && end_of_string( cell_b->payload.string. + cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 1220835..91ec2cf 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -47,32 +47,6 @@ * and others I haven't thought of yet. */ -/** - * Implementation of car in C. If arg is not a cons, does not error but returns nil. - */ -struct cons_pointer c_car( struct cons_pointer arg ) { - struct cons_pointer result = NIL; - - if ( consp( arg ) ) { - result = pointer2cell( arg ).payload.cons.car; - } - - return result; -} - -/** - * Implementation of cdr in C. If arg is not a cons, does not error but returns nil. - */ -struct cons_pointer c_cdr( struct cons_pointer arg ) { - struct cons_pointer result = NIL; - - if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) { - result = pointer2cell( arg ).payload.cons.cdr; - } - - return result; -} - /** * Useful building block; evaluate this single form in the context of this @@ -378,9 +352,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -411,24 +386,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, return result; } - -/** - * Get the Lisp type of the single argument. - * @param pointer a pointer to the object whose type is requested. - * @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 result = NIL; - struct cons_space_object cell = pointer2cell( pointer ); - - for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( ( wchar_t ) cell.tag.bytes[i], result ); - } - - return result; -} - - /** * Function; evaluate the expression which is the first argument in the frame; * further arguments are ignored. @@ -885,7 +842,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) { result = make_string( o.payload.string.character, result ); break; case SYMBOLTV: - result = make_symbol( o.payload.string.character, result ); + result = make_symbol_or_key( o.payload.string.character, result, SYMBOLTAG ); break; } } @@ -1251,13 +1208,13 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( frame->arg[0] ); - + struct cons_pointer source_key = c_string_to_lisp_keyword(L"source"); switch ( cell.tag.value ) { case FUNCTIONTV: - result = cell.payload.function.source; + result = c_assoc( source_key, cell.payload.function.meta); break; case SPECIALTV: - result = cell.payload.special.source; + result = c_assoc( source_key, cell.payload.special.meta); break; case LAMBDATV: result = make_cons( c_string_to_lisp_symbol( L"lambda" ), diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 1aff486..ea8a883 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -19,26 +19,13 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#ifndef __psse_lispops_h +#define __psse_lispops_h + /* * utilities */ -/** - * Get the Lisp type of the single argument. - * @param pointer a pointer to the object whose type is requested. - * @return As a Lisp string, the tag of the object which is at that pointer. - */ -struct cons_pointer c_type( struct cons_pointer pointer ); - -/** - * Implementation of car in C. If arg is not a cons, does not error but returns nil. - */ -struct cons_pointer c_car( struct cons_pointer arg ); - -/** - * Implementation of cdr in C. If arg is not a cons, does not error but returns nil. - */ -struct cons_pointer c_cdr( struct cons_pointer arg ); struct cons_pointer c_reverse( struct cons_pointer arg ); @@ -205,3 +192,5 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +#endif diff --git a/src/ops/meta.c b/src/ops/meta.c new file mode 100644 index 0000000..5e48709 --- /dev/null +++ b/src/ops/meta.c @@ -0,0 +1,47 @@ +/* + * meta.c + * + * Get metadata from a cell which has it. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "conspage.h" +#include "debug.h" + +/** + * Function: get metadata describing my first argument. + * + * * (metadata any) + * + * @return a pointer to the metadata of my first argument, or nil if none. + */ +struct cons_pointer lisp_metadata( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print(L"lisp_metadata: entered\n", DEBUG_EVAL); + debug_dump_object(frame->arg[0], DEBUG_EVAL); + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell(frame->arg[0]); + + switch( cell.tag.value) { + case FUNCTIONTV: + result = cell.payload.function.meta; + break; + case SPECIALTV: + result = cell.payload.special.meta; + break; + case READTV: + case WRITETV: + result = cell.payload.special.meta; + break; + } + + return make_cons( + make_cons( + c_string_to_lisp_keyword( L"type"), + c_type(frame->arg[0])), + result); + +// return result; +} diff --git a/src/ops/meta.h b/src/ops/meta.h new file mode 100644 index 0000000..2c6ccf2 --- /dev/null +++ b/src/ops/meta.h @@ -0,0 +1,17 @@ +/* + * meta.h + * + * Get metadata from a cell which has it. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_meta_h +#define __psse_meta_h + + +struct cons_pointer lisp_metadata( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) ; + +#endif diff --git a/src/ops/print.c b/src/ops/print.c index 8cb137e..e13f17a 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -35,7 +35,7 @@ int print_use_colours = 0; * don't print anything but just return. */ void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { - while ( stringp( pointer ) || symbolp( pointer ) ) { + while ( stringp( pointer ) || symbolp( pointer ) || keywordp(pointer)) { struct cons_space_object *cell = &pointer2cell( pointer ); wchar_t c = cell->payload.string.character; @@ -134,6 +134,13 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { dec_ref( s ); } break; + case KEYTV: + if ( print_use_colours ) { + url_fputws( L"\x1B[1;33m", output ); + } + url_fputws( L":", output ); + print_string_contents( output, pointer ); + break; case LAMBDATV:{ struct cons_pointer to_print = make_cons( c_string_to_lisp_symbol( L"lambda" ), diff --git a/src/ops/read.c b/src/ops/read.c index 69899c0..7362ecb 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -45,7 +45,8 @@ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); -struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ); +struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag, + wint_t initial ); /** * quote reader macro in C (!) @@ -110,7 +111,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, read_number( frame, frame_pointer, input, c, false ); } else { - result = read_symbol( input, c ); + result = read_symbol_or_key( input, SYMBOLTAG, c ); } } break; @@ -129,17 +130,20 @@ struct cons_pointer read_continuation( struct stack_frame *frame, read_continuation( frame, frame_pointer, input, url_fgetwc( input ) ); } else { - read_symbol( input, c ); + read_symbol_or_key( input, SYMBOLTAG, c ); } } break; - //case ':': reserved for keywords and paths + case ':': + result = + read_symbol_or_key( input, KEYTAG, url_fgetwc( input ) ); + break; default: if ( iswdigit( c ) ) { result = read_number( frame, frame_pointer, input, c, false ); } else if ( iswprint( c ) ) { - result = read_symbol( input, c ); + result = read_symbol_or_key( input, SYMBOLTAG, c ); } else { result = throw_exception( make_cons( c_string_to_lisp_string @@ -321,24 +325,22 @@ struct cons_pointer read_string( URL_FILE * input, wint_t initial ) { return result; } -struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { +struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag, + wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; switch ( initial ) { case '\0': - result = make_symbol( initial, NIL ); + result = make_symbol_or_key( initial, NIL, tag ); break; case '"': - /* - * THIS IS NOT A GOOD IDEA, but is legal - */ - result = - make_symbol( initial, - read_symbol( input, url_fgetwc( input ) ) ); - break; + case '\'': + /* unwise to allow embedded quotation marks in symbols */ case ')': + case ':': /* - * symbols may not include right-parenthesis; + * symbols and keywords may not include right-parenthesis + * or colons. */ result = NIL; /* @@ -350,8 +352,11 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { if ( iswprint( initial ) && !iswblank( initial ) ) { result = - make_symbol( initial, - read_symbol( input, url_fgetwc( input ) ) ); + make_symbol_or_key( initial, + read_symbol_or_key( input, + tag, + url_fgetwc( input ) ), + tag ); } else { result = NIL; /* @@ -362,7 +367,7 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { break; } - debug_print( L"read_symbol returning\n", DEBUG_IO ); + debug_print( L"read_symbol_or_key returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); return result; From f9bcac10e7765edfad479276b549a11783612207 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 29 Jan 2019 22:36:20 +0000 Subject: [PATCH 050/101] Fixed, working. --- src/init.c | 36 ++++---- src/io/fopen.c | 2 +- src/io/io.c | 170 ++++++++++++++++++----------------- src/io/io.h | 2 +- src/{ops => io}/print.c | 2 +- src/{ops => io}/print.h | 0 src/{ops => io}/read.c | 4 +- src/{ops => io}/read.h | 0 src/memory/conspage.c | 2 +- src/memory/consspaceobject.c | 14 +-- src/memory/dump.c | 16 ++-- src/ops/lispops.c | 17 ++-- src/ops/meta.c | 44 +++++---- src/ops/meta.h | 5 +- 14 files changed, 159 insertions(+), 155 deletions(-) rename src/{ops => io}/print.c (99%) rename src/{ops => io}/print.h (100%) rename src/{ops => io}/read.c (99%) rename src/{ops => io}/read.h (100%) diff --git a/src/init.c b/src/init.c index 6cceadd..47ba772 100644 --- a/src/init.c +++ b/src/init.c @@ -41,17 +41,16 @@ * more readable and aid debugging generally. */ void bind_function( wchar_t *name, struct cons_pointer ( *executable ) - ( struct stack_frame *, - struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - struct cons_pointer meta = make_cons( - make_cons(c_string_to_lisp_keyword(L"primitive"), TRUE), - make_cons( make_cons( - c_string_to_lisp_keyword(L"name"), - n), - NIL)); + ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ) { + struct cons_pointer n = c_string_to_lisp_symbol( name ); + struct cons_pointer meta = + make_cons( make_cons( c_string_to_lisp_keyword( L"primitive" ), TRUE ), + make_cons( make_cons( c_string_to_lisp_keyword( L"name" ), + n ), + NIL ) ); - deep_bind( n, make_function( meta, executable ) ); + deep_bind( n, make_function( meta, executable ) ); } /** @@ -62,12 +61,11 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer n = c_string_to_lisp_symbol( name ); - struct cons_pointer meta = make_cons( - make_cons(c_string_to_lisp_keyword(L"primitive"), TRUE), - make_cons( make_cons( - c_string_to_lisp_keyword(L"name"), - n), - NIL)); + struct cons_pointer meta = + make_cons( make_cons( c_string_to_lisp_keyword( L"primitive" ), TRUE ), + make_cons( make_cons( c_string_to_lisp_keyword( L"name" ), + n ), + NIL ) ); deep_bind( n, make_special( NIL, executable ) ); } @@ -94,9 +92,9 @@ int main( int argc, char *argv[] ) { bool show_prompt = false; setlocale( LC_ALL, "" ); - if (io_init() != 0) { - fputs("Failed to initialise I/O subsystem\n", stderr); - exit(1); + if ( io_init( ) != 0 ) { + fputs( "Failed to initialise I/O subsystem\n", stderr ); + exit( 1 ); } while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { diff --git a/src/io/fopen.c b/src/io/fopen.c index 50c09b5..d5e4cd6 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -223,7 +223,7 @@ URL_FILE *url_fopen( const char *url, const char *operation ) { curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback ); /* use the share object */ - curl_easy_setopt(file->handle.curl, CURLOPT_SHARE, io_share); + curl_easy_setopt( file->handle.curl, CURLOPT_SHARE, io_share ); if ( !multi_handle ) diff --git a/src/io/io.c b/src/io/io.c index 3d9eb36..82a6b32 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -44,22 +44,23 @@ wint_t ungotten = 0; * * @return 0 on success; any other value means failure. */ -int io_init() { - CURL *curl; - CURLcode res; - int result = curl_global_init( CURL_GLOBAL_SSL ); +int io_init( ) { + CURL *curl; + CURLcode res; + int result = curl_global_init( CURL_GLOBAL_SSL ); - io_share = curl_share_init(); + io_share = curl_share_init( ); - if (result == 0) { - curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_CONNECT); - curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE ); - curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS ); - curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_SSL_SESSION ); - curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL ); - } + if ( result == 0 ) { + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_CONNECT ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, + CURL_LOCK_DATA_SSL_SESSION ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL ); + } - return result; + return result; } /** @@ -243,67 +244,72 @@ lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, return result; } -int index_of( char c, char * s) { - int i; +int index_of( char c, char *s ) { + int i; - for (i = 0; s[i] != c && s[i] != 0; i++); + for ( i = 0; s[i] != c && s[i] != 0; i++ ); - return s[i] == c ? i : -1; + return s[i] == c ? i : -1; } -char * trim(char *s) { - int i; +char *trim( char *s ) { + int i; - for (i = strlen(s); (isblank(s[i]) || iscntrl(s[i])) && i > -1; i--) { - s[i] = (char) 0; - } - for (i = 0; isblank(s[i]) && s[i] != 0; i++); + for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i > -1; + i-- ) { + s[i] = ( char ) 0; + } + for ( i = 0; isblank( s[i] ) && s[i] != 0; i++ ); - return (char *)&s[i]; + return ( char * ) &s[i]; } /** * Callback to assemble metadata for a URL stream. This is naughty because * it modifies data, but it's really the only way to create metadata. */ -static size_t write_meta_callback(void *ptr, size_t size, size_t nmemb, struct cons_pointer stream) -{ - struct cons_space_object * cell = &pointer2cell(stream); +static size_t write_meta_callback( void *ptr, size_t size, size_t nmemb, + struct cons_pointer stream ) { + struct cons_space_object *cell = &pointer2cell( stream ); - if (strncmp(&cell->tag.bytes[0], READTAG, 4) || - strncmp(&cell->tag.bytes[0], WRITETAG, 4)) { - char * s = (char *)ptr; - int offset = index_of (':', ptr); + if ( strncmp( &cell->tag.bytes[0], READTAG, 4 ) || + strncmp( &cell->tag.bytes[0], WRITETAG, 4 ) ) { + char *s = ( char * ) ptr; + int offset = index_of( ':', ptr ); - if (offset != -1) { - s[offset] = (char)0; - char * name = s; - char * value = trim( &s[++offset]); - wchar_t * wname = calloc(strlen(name), sizeof(wchar_t)); - wchar_t * wvalue = calloc(strlen(value), sizeof(wchar_t)); + if ( offset != -1 ) { + s[offset] = ( char ) 0; + char *name = s; + char *value = trim( &s[++offset] ); + wchar_t *wname = calloc( strlen( name ), sizeof( wchar_t ) ); + wchar_t *wvalue = calloc( strlen( value ), sizeof( wchar_t ) ); - mbstowcs(wname, name, strlen(name)); - mbstowcs(wvalue, value, strlen(value)); + mbstowcs( wname, name, strlen( name ) ); + mbstowcs( wvalue, value, strlen( value ) ); - cell->payload.stream.meta = make_cons( - make_cons( - c_string_to_lisp_keyword( wname), - c_string_to_lisp_string(wvalue)), - cell->payload.stream.meta); + cell->payload.stream.meta = + make_cons( make_cons + ( c_string_to_lisp_keyword( wname ), + c_string_to_lisp_string( wvalue ) ), + cell->payload.stream.meta ); - debug_printf( DEBUG_IO, L"write_meta_callback: added header '%s': value '%s'\n", name, value); + debug_printf( DEBUG_IO, + L"write_meta_callback: added header '%s': value '%s'\n", + name, value ); + } + } else { + debug_print + ( L"Pointer passed to write_meta_callback did not point to a stream: ", + DEBUG_IO ); + debug_dump_object( stream, DEBUG_IO ); } - } else { - debug_print( L"Pointer passed to write_meta_callback did not point to a stream: ", DEBUG_IO); - debug_dump_object(stream, DEBUG_IO); - } - return nmemb; + return nmemb; } void collect_meta( struct cons_pointer stream, struct cons_pointer url ) { - URL_FILE * s = pointer2cell(stream).payload.stream.stream; + URL_FILE *s = pointer2cell( stream ).payload.stream.stream; switch ( s->type ) { case CFTYPE_NONE: @@ -315,8 +321,9 @@ void collect_meta( struct cons_pointer stream, struct cons_pointer url ) { case CFTYPE_CURL: curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L ); curl_easy_setopt( s->handle.curl, CURLOPT_HEADER, 1L ); - curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION, write_meta_callback); - curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream); + curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION, + write_meta_callback ); + curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream ); break; } } @@ -338,38 +345,37 @@ void collect_meta( struct cons_pointer stream, struct cons_pointer url ) { * on my stream, if any, else NIL. */ struct cons_pointer - lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; +lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; - if ( stringp( frame->arg[0] ) ) { - struct cons_pointer meta = - make_cons( make_cons( - c_string_to_lisp_keyword( L"url" ), - frame->arg[0] ), - NIL ); + if ( stringp( frame->arg[0] ) ) { + struct cons_pointer meta = + make_cons( make_cons( c_string_to_lisp_keyword( L"url" ), + frame->arg[0] ), + NIL ); - char *url = lisp_string_to_c_string( frame->arg[0] ); + char *url = lisp_string_to_c_string( frame->arg[0] ); - if ( nilp( frame->arg[1] ) ) { - URL_FILE *stream = url_fopen( url, "r" ); - result = make_read_stream( stream, meta ); - } else { - // TODO: anything more complex is a problem for another day. - URL_FILE *stream = url_fopen( url, "w" ); - result = make_write_stream( stream, meta); + if ( nilp( frame->arg[1] ) ) { + URL_FILE *stream = url_fopen( url, "r" ); + result = make_read_stream( stream, meta ); + } else { + // TODO: anything more complex is a problem for another day. + URL_FILE *stream = url_fopen( url, "w" ); + result = make_write_stream( stream, meta ); + } + + free( url ); + + if ( pointer2cell( result ).payload.stream.stream == NULL ) { + result = NIL; + } else { + collect_meta( result, frame->arg[0] ); + } } - free( url ); - - if ( pointer2cell( result ).payload.stream.stream == NULL ) { - result = NIL; - } else { - collect_meta( result, frame->arg[0]); - } - } - - return result; + return result; } /** @@ -392,8 +398,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload. - stream.stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); } return result; diff --git a/src/io/io.h b/src/io/io.h index 167660b..33f733f 100644 --- a/src/io/io.h +++ b/src/io/io.h @@ -15,7 +15,7 @@ extern CURLSH *io_share; -int io_init(); +int io_init( ); URL_FILE *file_to_url_file( FILE * f ); wint_t url_fgetwc( URL_FILE * input ); diff --git a/src/ops/print.c b/src/io/print.c similarity index 99% rename from src/ops/print.c rename to src/io/print.c index e13f17a..854c63a 100644 --- a/src/ops/print.c +++ b/src/io/print.c @@ -35,7 +35,7 @@ int print_use_colours = 0; * don't print anything but just return. */ void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { - while ( stringp( pointer ) || symbolp( pointer ) || keywordp(pointer)) { + while ( stringp( pointer ) || symbolp( pointer ) || keywordp( pointer ) ) { struct cons_space_object *cell = &pointer2cell( pointer ); wchar_t c = cell->payload.string.character; diff --git a/src/ops/print.h b/src/io/print.h similarity index 100% rename from src/ops/print.h rename to src/io/print.h diff --git a/src/ops/read.c b/src/io/read.c similarity index 99% rename from src/ops/read.c rename to src/io/read.c index 7362ecb..c49d043 100644 --- a/src/ops/read.c +++ b/src/io/read.c @@ -355,8 +355,8 @@ struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag, make_symbol_or_key( initial, read_symbol_or_key( input, tag, - url_fgetwc( input ) ), - tag ); + url_fgetwc + ( input ) ), tag ); } else { result = NIL; /* diff --git a/src/ops/read.h b/src/io/read.h similarity index 100% rename from src/ops/read.h rename to src/io/read.h diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 5f8c3a8..2d0958d 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -168,7 +168,7 @@ void free_cell( struct cons_pointer pointer ) { break; case READTV: case WRITETV: - dec_ref(cell->payload.stream.meta); + dec_ref( cell->payload.stream.meta ); url_fclose( cell->payload.stream.stream ); break; case SPECIALTV: diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index f7b5ca9..816618f 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -158,7 +158,7 @@ make_function( struct cons_pointer meta, struct cons_pointer ( *executable ) struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( meta); + inc_ref( meta ); cell->payload.function.meta = meta; cell->payload.function.executable = executable; @@ -261,11 +261,11 @@ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, if ( strncmp( tag, KEYTAG, 4 ) == 0 ) { struct cons_pointer r = internedp( result, oblist ); - if ( nilp(r)) { - intern(result, oblist); - } else { - result = r; - } + if ( nilp( r ) ) { + intern( result, oblist ); + } else { + result = r; + } } return result; @@ -280,7 +280,7 @@ make_special( struct cons_pointer meta, struct cons_pointer ( *executable ) struct cons_pointer, struct cons_pointer env ) ) { struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( meta); + inc_ref( meta ); cell->payload.special.meta = meta; cell->payload.special.executable = executable; diff --git a/src/memory/dump.c b/src/memory/dump.c index 7f7701f..28bd36a 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -108,14 +108,14 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { case RATIOTV: url_fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload. - integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload. - integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ). + payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ). + payload.integer.value, cell.count ); break; case READTV: - url_fputws( L"\t\tInput stream; metadata: ", output ); - print(output, cell.payload.stream.meta); + url_fputws( L"\t\tInput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); url_fputws( L"\n", output ); break; case REALTV: @@ -150,8 +150,8 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { } break; case WRITETV: - url_fputws( L"\t\tOutput stream; metadata: ", output ); - print(output, cell.payload.stream.meta); + url_fputws( L"\t\tOutput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); url_fputws( L"\n", output ); break; } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 91ec2cf..e390ac0 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -352,10 +352,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload. - special.executable ) ( get_stack_frame - ( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -842,7 +841,9 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) { result = make_string( o.payload.string.character, result ); break; case SYMBOLTV: - result = make_symbol_or_key( o.payload.string.character, result, SYMBOLTAG ); + result = + make_symbol_or_key( o.payload.string.character, result, + SYMBOLTAG ); break; } } @@ -1208,13 +1209,13 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( frame->arg[0] ); - struct cons_pointer source_key = c_string_to_lisp_keyword(L"source"); + struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" ); switch ( cell.tag.value ) { case FUNCTIONTV: - result = c_assoc( source_key, cell.payload.function.meta); + result = c_assoc( source_key, cell.payload.function.meta ); break; case SPECIALTV: - result = c_assoc( source_key, cell.payload.special.meta); + result = c_assoc( source_key, cell.payload.special.meta ); break; case LAMBDATV: result = make_cons( c_string_to_lisp_symbol( L"lambda" ), diff --git a/src/ops/meta.c b/src/ops/meta.c index 5e48709..a27d2af 100644 --- a/src/ops/meta.c +++ b/src/ops/meta.c @@ -17,31 +17,29 @@ * * @return a pointer to the metadata of my first argument, or nil if none. */ -struct cons_pointer lisp_metadata( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print(L"lisp_metadata: entered\n", DEBUG_EVAL); - debug_dump_object(frame->arg[0], DEBUG_EVAL); - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell(frame->arg[0]); +struct cons_pointer lisp_metadata( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"lisp_metadata: entered\n", DEBUG_EVAL ); + debug_dump_object( frame->arg[0], DEBUG_EVAL ); + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - switch( cell.tag.value) { - case FUNCTIONTV: - result = cell.payload.function.meta; - break; - case SPECIALTV: - result = cell.payload.special.meta; - break; - case READTV: - case WRITETV: - result = cell.payload.special.meta; - break; - } + switch ( cell.tag.value ) { + case FUNCTIONTV: + result = cell.payload.function.meta; + break; + case SPECIALTV: + result = cell.payload.special.meta; + break; + case READTV: + case WRITETV: + result = cell.payload.stream.meta; + break; + } - return make_cons( - make_cons( - c_string_to_lisp_keyword( L"type"), - c_type(frame->arg[0])), - result); + return make_cons( make_cons( c_string_to_lisp_keyword( L"type" ), + c_type( frame->arg[0] ) ), result ); // return result; } diff --git a/src/ops/meta.h b/src/ops/meta.h index 2c6ccf2..f441a50 100644 --- a/src/ops/meta.h +++ b/src/ops/meta.h @@ -11,7 +11,8 @@ #define __psse_meta_h -struct cons_pointer lisp_metadata( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) ; +struct cons_pointer lisp_metadata( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif From eb49ca4e2d112ea76a764117108888496e76da16 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 30 Jan 2019 00:32:55 +0000 Subject: [PATCH 051/101] Improvements to URL metadata collection Still not perfect - some corruption of data. --- src/io/io.c | 77 +++++++++++++++++++++++++++++++----- src/memory/consspaceobject.c | 6 +++ 2 files changed, 74 insertions(+), 9 deletions(-) diff --git a/src/io/io.c b/src/io/io.c index 82a6b32..1ff53db 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -1,7 +1,10 @@ /* * io.c * - * Communication between PSSE and the outside world, via libcurl. + * Communication between PSSE and the outside world, via libcurl. NOTE + * that this file destructively changes metadata on URL connections, + * because the metadata is not available until the stream has been read + * from. It would be better to find a workaround! * * (c) 2019 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -24,6 +27,8 @@ #include "consspaceobject.h" #include "debug.h" #include "fopen.h" +#include "integer.h" +#include "intern.h" #include "lispops.h" /** @@ -264,18 +269,47 @@ char *trim( char *s ) { return ( char * ) &s[i]; } + +void maybe_add_status_meta(struct cons_space_object *cell) { + struct cons_pointer status_key = c_string_to_lisp_keyword( L"status-code" ); + + debug_print(L"maybe_add_status_meta: entered\n", DEBUG_IO); + + if (cell->payload.stream.stream->type == CFTYPE_CURL && + nilp(c_assoc( status_key, cell->payload.stream.meta))) { + long status = 0; + curl_easy_getinfo(cell->payload.stream.stream->handle.curl, + CURLINFO_RESPONSE_CODE, + &status); + + debug_printf( DEBUG_IO, L"maybe_add_status_meta: read HTTP status %d\n", status); + + if (status > 0) { + cell->payload.stream.meta = make_cons( + make_cons(status_key, + make_integer(status, NIL)), + cell->payload.stream.meta); + } + } +} + + /** * Callback to assemble metadata for a URL stream. This is naughty because * it modifies data, but it's really the only way to create metadata. */ -static size_t write_meta_callback( void *ptr, size_t size, size_t nmemb, +static size_t write_meta_callback( char *string, size_t size, size_t nmemb, struct cons_pointer stream ) { struct cons_space_object *cell = &pointer2cell( stream ); + /* make a copy of the string that we can destructively change */ + char * s = calloc(strlen(string), sizeof(char)); + + strcpy( s, string); + if ( strncmp( &cell->tag.bytes[0], READTAG, 4 ) || strncmp( &cell->tag.bytes[0], WRITETAG, 4 ) ) { - char *s = ( char * ) ptr; - int offset = index_of( ':', ptr ); + int offset = index_of( ':', s ); if ( offset != -1 ) { s[offset] = ( char ) 0; @@ -293,18 +327,43 @@ static size_t write_meta_callback( void *ptr, size_t size, size_t nmemb, c_string_to_lisp_string( wvalue ) ), cell->payload.stream.meta ); + free(wname); + free(wvalue); + debug_printf( DEBUG_IO, L"write_meta_callback: added header '%s': value '%s'\n", name, value ); + } else if (strncmp( "HTTP", s, 4) == 0) { + int offset = index_of( ' ', s ); + char *value = trim( &s[offset] ); + wchar_t *wvalue = calloc( strlen( value ), sizeof( wchar_t ) ); + mbstowcs( wvalue, value, strlen( value ) ); + + cell->payload.stream.meta = + make_cons( make_cons + ( c_string_to_lisp_keyword( L"status" ), + c_string_to_lisp_string( wvalue ) ), + cell->payload.stream.meta ); + + maybe_add_status_meta( cell); + + debug_printf( DEBUG_IO, + L"write_meta_callback: added header 'status': value '%s'\n", + value ); + } else { + debug_printf( DEBUG_IO, + L"write_meta_callback: header passed with no colon: '%s'\n", + s ); } - } else { + } else { debug_print ( L"Pointer passed to write_meta_callback did not point to a stream: ", DEBUG_IO ); debug_dump_object( stream, DEBUG_IO ); } - return nmemb; + free(s); + return strlen(string); } @@ -351,7 +410,7 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( stringp( frame->arg[0] ) ) { struct cons_pointer meta = - make_cons( make_cons( c_string_to_lisp_keyword( L"url" ), + make_cons(make_cons( c_string_to_lisp_keyword( L"url" ), frame->arg[0] ), NIL ); @@ -366,13 +425,13 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, result = make_write_stream( stream, meta ); } - free( url ); - if ( pointer2cell( result ).payload.stream.stream == NULL ) { result = NIL; } else { collect_meta( result, frame->arg[0] ); } + + free( url ); } return result; diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 816618f..0baba69 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -328,6 +328,12 @@ struct cons_pointer make_write_stream( URL_FILE * output, struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { struct cons_pointer result = NIL; + for (int i = 0; symbol[i] != '\0'; i++) { + if(iswalpha(symbol[i] && !iswlower(symbol[i]))) { + symbol[i] = towlower(symbol[i]); + } + } + for ( int i = wcslen( symbol ); i > 0; i-- ) { result = make_keyword( symbol[i - 1], result ); } From 45af898f5e37771b84acf22a7042313f0c84956a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 30 Jan 2019 00:39:43 +0000 Subject: [PATCH 052/101] That seems to fix it! --- src/io/io.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/io/io.c b/src/io/io.c index 1ff53db..e7554ec 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -260,11 +260,11 @@ int index_of( char c, char *s ) { char *trim( char *s ) { int i; - for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i > -1; + for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i >= 0; i-- ) { s[i] = ( char ) 0; } - for ( i = 0; isblank( s[i] ) && s[i] != 0; i++ ); + for ( i = 0; ( isblank( s[i] ) || iscntrl( s[i] ) ) && s[i] != 0; i++ ); return ( char * ) &s[i]; } @@ -313,7 +313,7 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, if ( offset != -1 ) { s[offset] = ( char ) 0; - char *name = s; + char *name = trim( s ); char *value = trim( &s[++offset] ); wchar_t *wname = calloc( strlen( name ), sizeof( wchar_t ) ); wchar_t *wvalue = calloc( strlen( value ), sizeof( wchar_t ) ); From 86319fd1c32ab1accd109e0bfa5b79cfc6ba1446 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 30 Jan 2019 00:39:43 +0000 Subject: [PATCH 053/101] That seems to fix it! --- src/io/io.c | 6 +++--- src/memory/consspaceobject.c | 21 +++++++++++---------- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/io/io.c b/src/io/io.c index 1ff53db..e7554ec 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -260,11 +260,11 @@ int index_of( char c, char *s ) { char *trim( char *s ) { int i; - for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i > -1; + for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i >= 0; i-- ) { s[i] = ( char ) 0; } - for ( i = 0; isblank( s[i] ) && s[i] != 0; i++ ); + for ( i = 0; ( isblank( s[i] ) || iscntrl( s[i] ) ) && s[i] != 0; i++ ); return ( char * ) &s[i]; } @@ -313,7 +313,7 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, if ( offset != -1 ) { s[offset] = ( char ) 0; - char *name = s; + char *name = trim( s ); char *value = trim( &s[++offset] ); wchar_t *wname = calloc( strlen( name ), sizeof( wchar_t ) ); wchar_t *wvalue = calloc( strlen( value ), sizeof( wchar_t ) ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 0baba69..aa1cece 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -323,19 +323,18 @@ struct cons_pointer make_write_stream( URL_FILE * output, } /** - * Return a lisp keyword representation of this wide character string. + * Return a lisp keyword representation of this wide character string. In keywords, + * I am accepting only lower case characters and numbers. */ struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { struct cons_pointer result = NIL; - for (int i = 0; symbol[i] != '\0'; i++) { - if(iswalpha(symbol[i] && !iswlower(symbol[i]))) { - symbol[i] = towlower(symbol[i]); - } - } + for ( int i = wcslen( symbol ) -1; i >= 0; i-- ) { + wchar_t c = towlower(symbol[i]); - for ( int i = wcslen( symbol ); i > 0; i-- ) { - result = make_keyword( symbol[i - 1], result ); + if (iswalnum(c) || c == L'-') { + result = make_keyword( c, result ); + } } return result; @@ -347,8 +346,10 @@ struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { struct cons_pointer c_string_to_lisp_string( wchar_t *string ) { struct cons_pointer result = NIL; - for ( int i = wcslen( string ); i > 0; i-- ) { - result = make_string( string[i - 1], result ); + for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { + if (iswprint(string[i]) && string[i] != '"') { + result = make_string( string[i], result ); + } } return result; From bd4d65536247bbf50c3bba268da45bffdfba2193 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 31 Jan 2019 13:24:06 +0000 Subject: [PATCH 054/101] Metadata for file streams --- src/io/io.c | 137 ++++++++++++++++++++++++++-------------------- src/ops/lispops.c | 8 +-- 2 files changed, 82 insertions(+), 63 deletions(-) diff --git a/src/io/io.c b/src/io/io.c index e7554ec..58ee88d 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -10,11 +10,15 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include +#include +#include #include #include #include #include #include +#include /* * wide characters */ @@ -270,29 +274,33 @@ char *trim( char *s ) { } -void maybe_add_status_meta(struct cons_space_object *cell) { - struct cons_pointer status_key = c_string_to_lisp_keyword( L"status-code" ); - - debug_print(L"maybe_add_status_meta: entered\n", DEBUG_IO); - - if (cell->payload.stream.stream->type == CFTYPE_CURL && - nilp(c_assoc( status_key, cell->payload.stream.meta))) { - long status = 0; - curl_easy_getinfo(cell->payload.stream.stream->handle.curl, - CURLINFO_RESPONSE_CODE, - &status); - - debug_printf( DEBUG_IO, L"maybe_add_status_meta: read HTTP status %d\n", status); - - if (status > 0) { - cell->payload.stream.meta = make_cons( - make_cons(status_key, - make_integer(status, NIL)), - cell->payload.stream.meta); - } - } +struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key, + long int value ) { + return + make_cons( make_cons + ( c_string_to_lisp_keyword( key ), + make_integer( value, NIL ) ), meta ); } +struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, + char *value ) { + wchar_t buffer[strlen( value ) + 1]; + mbstowcs( buffer, value, strlen( value ) ); + return make_cons( make_cons( c_string_to_lisp_keyword( key ), + c_string_to_lisp_string( buffer ) ), meta ); +} + +struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key, + time_t * value ) { + /* I don't yet have a concept of a date-time object, which is a + * bit of an oversight! */ + char datestring[256]; + struct tm *tm = localtime( value ); + + strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), tm ); + + return add_meta_string( meta, key, datestring ); +} /** * Callback to assemble metadata for a URL stream. This is naughty because @@ -303,9 +311,9 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, struct cons_space_object *cell = &pointer2cell( stream ); /* make a copy of the string that we can destructively change */ - char * s = calloc(strlen(string), sizeof(char)); + char *s = calloc( strlen( string ), sizeof( char ) ); - strcpy( s, string); + strcpy( s, string ); if ( strncmp( &cell->tag.bytes[0], READTAG, 4 ) || strncmp( &cell->tag.bytes[0], WRITETAG, 4 ) ) { @@ -315,37 +323,26 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, s[offset] = ( char ) 0; char *name = trim( s ); char *value = trim( &s[++offset] ); - wchar_t *wname = calloc( strlen( name ), sizeof( wchar_t ) ); - wchar_t *wvalue = calloc( strlen( value ), sizeof( wchar_t ) ); + wchar_t wname[strlen( name )]; mbstowcs( wname, name, strlen( name ) ); - mbstowcs( wvalue, value, strlen( value ) ); cell->payload.stream.meta = - make_cons( make_cons - ( c_string_to_lisp_keyword( wname ), - c_string_to_lisp_string( wvalue ) ), - cell->payload.stream.meta ); - - free(wname); - free(wvalue); + add_meta_string( cell->payload.stream.meta, wname, value ); debug_printf( DEBUG_IO, L"write_meta_callback: added header '%s': value '%s'\n", name, value ); - } else if (strncmp( "HTTP", s, 4) == 0) { + } else if ( strncmp( "HTTP", s, 4 ) == 0 ) { int offset = index_of( ' ', s ); char *value = trim( &s[offset] ); - wchar_t *wvalue = calloc( strlen( value ), sizeof( wchar_t ) ); - mbstowcs( wvalue, value, strlen( value ) ); cell->payload.stream.meta = - make_cons( make_cons - ( c_string_to_lisp_keyword( L"status" ), - c_string_to_lisp_string( wvalue ) ), - cell->payload.stream.meta ); - - maybe_add_status_meta( cell); + add_meta_integer( add_meta_string + ( cell->payload.stream.meta, L"status", + value ), L"status-code", strtol( value, + NULL, + 10 ) ); debug_printf( DEBUG_IO, L"write_meta_callback: added header 'status': value '%s'\n", @@ -355,27 +352,54 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, L"write_meta_callback: header passed with no colon: '%s'\n", s ); } - } else { + } else { debug_print ( L"Pointer passed to write_meta_callback did not point to a stream: ", DEBUG_IO ); debug_dump_object( stream, DEBUG_IO ); } - free(s); - return strlen(string); + free( s ); + return strlen( string ); } - -void collect_meta( struct cons_pointer stream, struct cons_pointer url ) { +void collect_meta( struct cons_pointer stream, char *url ) { + struct cons_space_object *cell = &pointer2cell( stream ); URL_FILE *s = pointer2cell( stream ).payload.stream.stream; + struct cons_pointer meta = + add_meta_string( cell->payload.stream.meta, L"url", url ); + struct stat statbuf; + int result = stat( url, &statbuf ); + struct passwd *pwd; + struct group *grp; switch ( s->type ) { case CFTYPE_NONE: break; case CFTYPE_FILE: - /* don't know whether you can get metadata on an open stream in C, - * although we could of course get it from the URL */ + if ( result == 0 ) { + if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) { + meta = add_meta_string( meta, L"owner", pwd->pw_name ); + } else { + meta = add_meta_integer( meta, L"owner", statbuf.st_uid ); + } + + if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) { + meta = add_meta_string( meta, L"group", grp->gr_name ); + } else { + meta = add_meta_integer( meta, L"group", statbuf.st_gid ); + } + + meta = + add_meta_integer( meta, L"size", + ( intmax_t ) statbuf.st_size ); + + meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); + + /* this is destructive change before the cell is released into the + * wild, and consequently permissible, just. */ + cell->payload.stream.meta = meta; + } break; case CFTYPE_CURL: curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L ); @@ -409,26 +433,21 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer result = NIL; if ( stringp( frame->arg[0] ) ) { - struct cons_pointer meta = - make_cons(make_cons( c_string_to_lisp_keyword( L"url" ), - frame->arg[0] ), - NIL ); - char *url = lisp_string_to_c_string( frame->arg[0] ); if ( nilp( frame->arg[1] ) ) { URL_FILE *stream = url_fopen( url, "r" ); - result = make_read_stream( stream, meta ); + result = make_read_stream( stream, NIL ); } else { // TODO: anything more complex is a problem for another day. URL_FILE *stream = url_fopen( url, "w" ); - result = make_write_stream( stream, meta ); + result = make_write_stream( stream, NIL ); } if ( pointer2cell( result ).payload.stream.stream == NULL ) { result = NIL; } else { - collect_meta( result, frame->arg[0] ); + collect_meta( result, url ); } free( url ); @@ -457,8 +476,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload.stream. - stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload. + stream.stream ), NIL ); } return result; diff --git a/src/ops/lispops.c b/src/ops/lispops.c index e390ac0..5471c3f 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -646,12 +646,12 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, case CONSTV: result = cell.payload.cons.car; break; + case NILTV: + break; case READTV: result = make_string( url_fgetwc( cell.payload.stream.stream ), NIL ); break; - case NILTV: - break; case STRINGTV: result = make_string( cell.payload.string.character, NIL ); break; @@ -690,6 +690,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, case CONSTV: result = cell.payload.cons.cdr; break; + case NILTV: + break; case READTV: url_fgetwc( cell.payload.stream.stream ); result = frame->arg[0]; @@ -697,8 +699,6 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, case STRINGTV: result = cell.payload.string.cdr; break; - case NILTV: - break; default: result = throw_exception( c_string_to_lisp_string From 0fea9580fa3a59bc73da17d5d7973a26e8f30766 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 31 Jan 2019 14:17:29 +0000 Subject: [PATCH 055/101] Investigating the junk character problem. --- src/io/io.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/io/io.c b/src/io/io.c index 58ee88d..1f7191c 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -266,9 +266,9 @@ char *trim( char *s ) { for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i >= 0; i-- ) { - s[i] = ( char ) 0; + s[i] = '\0'; } - for ( i = 0; ( isblank( s[i] ) || iscntrl( s[i] ) ) && s[i] != 0; i++ ); + for ( i = 0; ( isblank( s[i] ) || iscntrl( s[i] ) ) && s[i] != '\0'; i++ ); return ( char * ) &s[i]; } @@ -284,7 +284,10 @@ struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key, struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, char *value ) { + value = trim( value); wchar_t buffer[strlen( value ) + 1]; + /* \todo something goes wrong here: I sometimes get junk characters on the + * end of the string. */ mbstowcs( buffer, value, strlen( value ) ); return make_cons( make_cons( c_string_to_lisp_keyword( key ), c_string_to_lisp_string( buffer ) ), meta ); From 83accb2be4ca526ce763d7bdf0f0debfb7d0c0b6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 31 Jan 2019 22:39:32 +0000 Subject: [PATCH 056/101] #13: Fixed --- src/io/fopen.c | 14 +++++++----- src/io/io.c | 60 +++++++++++++++++++++++++++++--------------------- src/utils.c | 33 +++++++++++++++++++++++++++ src/utils.h | 15 +++++++++++++ 4 files changed, 92 insertions(+), 30 deletions(-) create mode 100644 src/utils.c create mode 100644 src/utils.h diff --git a/src/io/fopen.c b/src/io/fopen.c index d5e4cd6..d3ece5c 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -51,8 +51,9 @@ #ifdef FOPEN_STANDALONE CURLSH *io_share; #else -#include "io.h" #include "consspaceobject.h" +#include "io.h" +#include "utils.h" #endif @@ -210,10 +211,9 @@ URL_FILE *url_fopen( const char *url, const char *operation ) { return NULL; file->handle.file = fopen( url, operation ); - if ( file->handle.file ) - file->type = CFTYPE_FILE; /* marked as URL */ - - else { + if ( file->handle.file ) { + file->type = CFTYPE_FILE; /* marked as file */ + } else if ( index_of(':', url ) > -1 ) { file->type = CFTYPE_CURL; /* marked as URL */ file->handle.curl = curl_easy_init( ); @@ -247,7 +247,11 @@ URL_FILE *url_fopen( const char *url, const char *operation ) { file = NULL; } + } else { + file->type = CFTYPE_NONE; + /* not a file, and doesn't look like a URL. */ } + return file; } diff --git a/src/io/io.c b/src/io/io.c index 1f7191c..1cf3c9e 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -34,6 +34,7 @@ #include "integer.h" #include "intern.h" #include "lispops.h" +#include "utils.h" /** * The sharing hub for all connections. TODO: Ultimately this probably doesn't @@ -253,27 +254,6 @@ lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, return result; } -int index_of( char c, char *s ) { - int i; - - for ( i = 0; s[i] != c && s[i] != 0; i++ ); - - return s[i] == c ? i : -1; -} - -char *trim( char *s ) { - int i; - - for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i >= 0; - i-- ) { - s[i] = '\0'; - } - for ( i = 0; ( isblank( s[i] ) || iscntrl( s[i] ) ) && s[i] != '\0'; i++ ); - - return ( char * ) &s[i]; -} - - struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key, long int value ) { return @@ -289,6 +269,13 @@ struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, /* \todo something goes wrong here: I sometimes get junk characters on the * end of the string. */ mbstowcs( buffer, value, strlen( value ) ); + + /* hack: get rid of 32766 as a junk character, to see whether there are + * others. */ + for (int i = 0; i < wcslen( buffer); i++) { + if (buffer[i] == (wchar_t)32766) buffer[i] = (wchar_t)0; + } + return make_cons( make_cons( c_string_to_lisp_keyword( key ), c_string_to_lisp_string( buffer ) ), meta ); } @@ -398,10 +385,6 @@ void collect_meta( struct cons_pointer stream, char *url ) { ( intmax_t ) statbuf.st_size ); meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); - - /* this is destructive change before the cell is released into the - * wild, and consequently permissible, just. */ - cell->payload.stream.meta = meta; } break; case CFTYPE_CURL: @@ -412,6 +395,10 @@ void collect_meta( struct cons_pointer stream, char *url ) { curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream ); break; } + + /* this is destructive change before the cell is released into the + * wild, and consequently permissible, just. */ + cell->payload.stream.meta = meta; } @@ -440,6 +427,29 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( frame->arg[1] ) ) { URL_FILE *stream = url_fopen( url, "r" ); + + debug_printf( DEBUG_IO, + L"lisp_open: stream @ %d, stream type = %d, stream handle = %d\n", + (int) &stream, (int)stream->type, (int)stream->handle.file); + + switch (stream->type) { + case CFTYPE_NONE: + return make_exception( + c_string_to_lisp_string( L"Could not open stream"), + frame_pointer); + break; + case CFTYPE_FILE: + if (stream->handle.file == NULL) { + return make_exception( + c_string_to_lisp_string( L"Could not open file"), + frame_pointer); + } + break; + case CFTYPE_CURL: + /* can't tell whether a URL is bad without reading it */ + break; + } + result = make_read_stream( stream, NIL ); } else { // TODO: anything more complex is a problem for another day. diff --git a/src/utils.c b/src/utils.c new file mode 100644 index 0000000..5b22516 --- /dev/null +++ b/src/utils.c @@ -0,0 +1,33 @@ +/* + * utils.c + * + * little generally useful functions which aren't in any way special to PSSE. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include + + +int index_of( char c, char *s ) { + int i; + + for ( i = 0; s[i] != c && s[i] != 0; i++ ); + + return s[i] == c ? i : -1; +} + +char *trim( char *s ) { + int i; + + for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i >= 0; + i-- ) { + s[i] = '\0'; + } + for ( i = 0; ( isblank( s[i] ) || iscntrl( s[i] ) ) && s[i] != '\0'; i++ ); + + return ( char * ) &s[i]; +} diff --git a/src/utils.h b/src/utils.h new file mode 100644 index 0000000..e56fd6e --- /dev/null +++ b/src/utils.h @@ -0,0 +1,15 @@ +/* + * utils.h + * + * little generally useful functions which aren't in any way special to PSSE. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_utils_h +#define __psse_utils_h + +int index_of( char c, char *s ); +char *trim( char *s ); +#endif From 8cab28f6c84a46825095402b7cc1f391b1b76291 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 31 Jan 2019 22:49:25 +0000 Subject: [PATCH 057/101] Proper fix for the junk characters bug. --- src/io/io.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/io/io.c b/src/io/io.c index 1cf3c9e..dd41190 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -189,7 +189,7 @@ wint_t url_fgetwc( URL_FILE * input ) { if ( count > 1 ) { url_fgets( ( char * ) &cbuff[1], count, input ); } - mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); + mbstowcs( wbuff, cbuff, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); result = wbuff[0]; free( wbuff ); @@ -268,13 +268,13 @@ struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, wchar_t buffer[strlen( value ) + 1]; /* \todo something goes wrong here: I sometimes get junk characters on the * end of the string. */ - mbstowcs( buffer, value, strlen( value ) ); + mbstowcs( buffer, value, strlen( value ) + 1 ); /* hack: get rid of 32766 as a junk character, to see whether there are - * others. */ + * others. for (int i = 0; i < wcslen( buffer); i++) { if (buffer[i] == (wchar_t)32766) buffer[i] = (wchar_t)0; - } + } */ return make_cons( make_cons( c_string_to_lisp_keyword( key ), c_string_to_lisp_string( buffer ) ), meta ); @@ -315,7 +315,7 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, char *value = trim( &s[++offset] ); wchar_t wname[strlen( name )]; - mbstowcs( wname, name, strlen( name ) ); + mbstowcs( wname, name, strlen( name ) + 1 ); cell->payload.stream.meta = add_meta_string( cell->payload.stream.meta, wname, value ); From 23e4f0befa0497b3fcb21c2ea3cd322291c685ba Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 5 Feb 2019 09:59:05 +0000 Subject: [PATCH 058/101] A bit of work on time, but it doesn't actually work yet. --- src/arith/integer.c | 6 --- src/init.c | 2 + src/io/io.c | 8 --- src/io/print.c | 4 ++ src/memory/consspaceobject.h | 32 +++++++++++- src/time/time.c | 98 ++++++++++++++++++++++++++++++++++++ src/time/time.h | 20 ++++++++ src/utils.c | 2 +- 8 files changed, 155 insertions(+), 17 deletions(-) create mode 100644 src/time/time.c create mode 100644 src/time/time.h diff --git a/src/arith/integer.c b/src/arith/integer.c index 1195c53..48992ca 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -12,12 +12,6 @@ #include #include #include -/* safe_iop, as available in the Ubuntu repository, is this one: - * https://code.google.com/archive/p/safe-iop/wikis/README.wiki - * which is installed as `libsafe-iop-dev`. There is an alternate - * implementation here: https://github.com/redpig/safe-iop/ - * which shares the same version number but is not compatible. */ -#include /* * wide characters */ diff --git a/src/init.c b/src/init.c index 47ba772..06494e9 100644 --- a/src/init.c +++ b/src/init.c @@ -30,6 +30,7 @@ #include "peano.h" #include "print.h" #include "repl.h" +#include "time.h" // extern char *optarg; /* defined in unistd.h */ @@ -212,6 +213,7 @@ int main( int argc, char *argv[] ) { bind_function( L"source", &lisp_source ); bind_function( L"subtract", &lisp_subtract ); bind_function( L"throw", &lisp_exception ); + bind_function( L"time", &lisp_time ); bind_function( L"type", &lisp_type ); bind_function( L"+", &lisp_add ); bind_function( L"*", &lisp_multiply ); diff --git a/src/io/io.c b/src/io/io.c index dd41190..b82c6ba 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -266,16 +266,8 @@ struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, char *value ) { value = trim( value); wchar_t buffer[strlen( value ) + 1]; - /* \todo something goes wrong here: I sometimes get junk characters on the - * end of the string. */ mbstowcs( buffer, value, strlen( value ) + 1 ); - /* hack: get rid of 32766 as a junk character, to see whether there are - * others. - for (int i = 0; i < wcslen( buffer); i++) { - if (buffer[i] == (wchar_t)32766) buffer[i] = (wchar_t)0; - } */ - return make_cons( make_cons( c_string_to_lisp_keyword( key ), c_string_to_lisp_string( buffer ) ), meta ); } diff --git a/src/io/print.c b/src/io/print.c index 854c63a..fb0d8a1 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -22,6 +22,7 @@ #include "integer.h" #include "stack.h" #include "print.h" +#include "time.h" /** * Whether or not we colorise output. @@ -210,6 +211,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { case SPECIALTV: url_fwprintf( output, L"" ); break; + case TIMETV: + print_string(output, time_to_string( pointer)); + break; case TRUETV: url_fwprintf( output, L"t" ); break; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 1bbbcd1..91ba3c3 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -193,6 +193,16 @@ */ #define SYMBOLTV 1112365395 +/** + * A time stamp. + */ +#define TIMETAG "TIME" + +/** + * The string `TIME`, considered as an `unsigned int`. + */ +#define TIMETV 1162692948 + /** * The special cons cell at address {0,1} which is canonically different * from NIL. @@ -344,13 +354,18 @@ * (there should only be one of these so it's slightly redundant). * Also note that anything that is not NIL is truthy. */ -#define tp(conspoint) (checktag(conspoint,TRUETAG)) +#define tp(conspoint) (check_tag(conspoint,TRUETAG)) + +/** + * true if `conspoint` points to a time cell, else false. + */ +#define timep(conspoint) (check_tag(conspoint,TIMETAG)) /** * true if `conspoint` points to something that is truthy, i.e. * anything but NIL. */ -#define truep(conspoint) (!checktag(conspoint,NILTAG)) +#define truep(conspoint) (!check_tag(conspoint,NILTAG)) /** * An indirect pointer to a cons cell @@ -531,6 +546,15 @@ struct string_payload { struct cons_pointer cdr; }; +/** + * The payload of a time cell: an unsigned 128 bit value representing micro- + * seconds since the estimated date of the Big Bang (actually, for + * convenience, 14Bn years before 1st Jan 1970 (the UNIX epoch)) + */ +struct time_payload { + unsigned __int128 value; +}; + /** * payload of a vector pointer cell. */ @@ -616,6 +640,10 @@ struct cons_space_object { * if tag == STRINGTAG || tag == SYMBOLTAG */ struct string_payload string; + /** + * if tag == TIMETAG + */ + struct time_payload time; /** * if tag == TRUETAG; we'll treat the special cell T as just a cons */ diff --git a/src/time/time.c b/src/time/time.c new file mode 100644 index 0000000..146f296 --- /dev/null +++ b/src/time/time.c @@ -0,0 +1,98 @@ +/* + * time.h + * + * Bare bones of PSSE time. See issue #16. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +/* + * wide characters + */ +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "integer.h" +#include "time.h" +#define _GNU_SOURCE + +#define seconds_per_year 31557600L + +/** + * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before + * the UNIX epoch; the value in microseconds will break the C reader. + */ +unsigned __int128 epoch_offset = ((__int128)(seconds_per_year * 1000000000L) * + (__int128)(14L * 1000000000L)); + +/** + * Return the UNIX time value which represents this time, if it falls within + * the period representable in UNIX time, or zero otherwise. + */ +long int lisp_time_to_unix_time(struct cons_pointer t) { + long int result = 0; + + if (timep( t)) { + unsigned __int128 value = pointer2cell(t).payload.time.value; + + if (value > epoch_offset) { // \todo && value < UNIX time rollover + result = ((value - epoch_offset) / 1000000000); + } + } + + return result; +} + +unsigned __int128 unix_time_to_lisp_time( time_t t) { + unsigned __int128 result = epoch_offset + (t * 1000000000); + + return result; +} + +struct cons_pointer make_time( struct cons_pointer integer_or_nil) { + struct cons_pointer pointer = allocate_cell( TIMETAG ); + struct cons_space_object *cell = &pointer2cell( pointer ); + + if (integerp(integer_or_nil)) { + cell->payload.time.value = pointer2cell(integer_or_nil).payload.integer.value; + // \todo: if integer is a bignum, deal with it. + } else { + cell->payload.time.value = unix_time_to_lisp_time( time(NULL)); + } + + return pointer; +} + +/** + * Function; return a time representation of the first argument in the frame; + * further arguments are ignored. + * + * * (time integer_or_nil) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a lisp time; if `integer_or_nil` is an integer, return a time which + * is that number of microseconds after the notional big bang; else the current + * time. + */ +struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_time( frame->arg[0]); +} + +/** + * This is temporary, for bootstrapping. + */ +struct cons_pointer time_to_string( struct cons_pointer pointer) { + long int t = lisp_time_to_unix_time(pointer); + + return c_string_to_lisp_string( t == 0 ? + L"Not yet implemented: cannot print times outside UNIX time\n" : + ctime(&t)); +} diff --git a/src/time/time.h b/src/time/time.h new file mode 100644 index 0000000..661decf --- /dev/null +++ b/src/time/time.h @@ -0,0 +1,20 @@ +/* + * time.h + * + * Bare bones of PSSE time. See issue #16. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_time_h +#define __psse_time_h + +#define _GNU_SOURCE +#include "consspaceobject.h" + +struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer time_to_string( struct cons_pointer pointer); + +#endif diff --git a/src/utils.c b/src/utils.c index 5b22516..ea3919f 100644 --- a/src/utils.c +++ b/src/utils.c @@ -27,7 +27,7 @@ char *trim( char *s ) { i-- ) { s[i] = '\0'; } - for ( i = 0; ( isblank( s[i] ) || iscntrl( s[i] ) ) && s[i] != '\0'; i++ ); + for ( i = 0; s[i] != '\0' && ( isblank( s[i] ) || iscntrl( s[i] ) ); i++ ); return ( char * ) &s[i]; } From 2bebee60027b5104ebbfc327330573da639cbc97 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 5 Feb 2019 10:27:16 +0000 Subject: [PATCH 059/101] #8: Bare bones --- src/memory/map.c | 8 ++++++ src/memory/map.h | 65 ++++++++++++++++++++++++++++++++++++++++++++++ src/memory/stack.h | 6 ++--- 3 files changed, 76 insertions(+), 3 deletions(-) create mode 100644 src/memory/map.c create mode 100644 src/memory/map.h diff --git a/src/memory/map.c b/src/memory/map.c new file mode 100644 index 0000000..e897647 --- /dev/null +++ b/src/memory/map.c @@ -0,0 +1,8 @@ +/* + * map.c + * + * An immutable hashmap in vector space. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ diff --git a/src/memory/map.h b/src/memory/map.h new file mode 100644 index 0000000..d7a65c5 --- /dev/null +++ b/src/memory/map.h @@ -0,0 +1,65 @@ +/* + * map.h + * + * An immutable hashmap in vector space. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_map_h +#define __psse_map_h + +#include "consspaceobject.h" +#include "conspage.h" + +/** + * macros for the tag of a mutable map. + */ +#define MAPTAG "IMAP" +#define MAPTV 1346456905 + +/** + * Number of buckets in a single tier map. + */ +#define BUCKETSINMAP 256 + +/** + * Maximum number of entries in an association-list bucket. + */ +#define MAXENTRIESINASSOC 16 + +/** + * The vector-space payload of a map object. + */ +struct map_payload { + /** + * There is a default hash function, which is used if `hash_function` is + * `nil` (which it normally should be); and keywords will probably carry + * their own hash values. But it will be possible to override the hash + * function by putting a function of one argument returning an integer + * here. */ + struct cons_pointer hash_function = NIL; + + /** + * Obviously the number of buckets in a map is a trade off, and this may need + * tuning - or it may even be necessary to have different sized base maps. The + * idea here is that the value of a bucket is + * + * 1. `nil`; or + * 2. an association list; or + * 3. a map. + * + * All buckets are initially `nil`. Adding a value to a `nil` bucket returns + * a map with a new bucket in the form of an assoc list. Subsequent additions + * cons new key/value pairs onto the assoc list, until there are + * `MAXENTRIESINASSOC` pairs, at which point if a further value is added to + * the same bucket the bucket returned will be in the form of a second level + * map. My plan is that buckets the first level map will be indexed on the + * first sixteen bits of the hash value, those in the second on the second + * sixteen, and, potentially, so on. + */ + struct cons_pointer buckets[BUCKETSINMAP]; +}; + +#endif diff --git a/src/memory/stack.h b/src/memory/stack.h index 0ea903c..f132c69 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -18,12 +18,12 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#ifndef __psse_stack_h +#define __psse_stack_h + #include "consspaceobject.h" #include "conspage.h" -#ifndef __stack_h -#define __stack_h - /** * macros for the tag of a stack frame. */ From e7ef82d23f3910726648e60245e71891378e4799 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 5 Feb 2019 11:02:04 +0000 Subject: [PATCH 060/101] #8: keywords as functions on associations working --- src/ops/intern.c | 6 ++++ src/ops/lispops.c | 71 ++++++++++++++++++++++++++--------------------- 2 files changed, 45 insertions(+), 32 deletions(-) diff --git a/src/ops/intern.c b/src/ops/intern.c index 87d116e..8ce5d71 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -91,6 +91,12 @@ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ) { struct cons_pointer result = NIL; + debug_print( L"c_assoc; key is `", DEBUG_BIND); + debug_print_object( key, DEBUG_BIND); + debug_print( L"`; store is \n", DEBUG_BIND); + debug_dump_object( store, DEBUG_BIND); + debug_println(DEBUG_BIND); + for ( struct cons_pointer next = store; consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { struct cons_space_object entry = diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 5471c3f..14724a1 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -269,8 +269,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, * @return the result of evaluating the function with its arguments. */ struct cons_pointer -c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { + c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { debug_print( L"Entering c_apply\n", DEBUG_EVAL ); struct cons_pointer result = NIL; @@ -285,38 +285,47 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, switch ( fn_cell.tag.value ) { case EXCEPTIONTV: - /* just pass exceptions straight back */ - result = fn_pointer; - break; + /* just pass exceptions straight back */ + result = fn_pointer; + break; case FUNCTIONTV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); - result = - ( *fn_cell.payload.function.executable ) ( next, - next_pointer, - env ); - dec_ref( next_pointer ); - } + result = + ( *fn_cell.payload.function.executable ) ( next, + next_pointer, + env ); + dec_ref( next_pointer ); } - break; + } + break; + + case KEYTV: + result = c_assoc( fn_pointer, + eval_form(frame, + frame_pointer, + c_car( c_cdr( frame->arg[0])), + env)); + break; + case LAMBDATV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { struct stack_frame *next = get_stack_frame( next_pointer ); result = @@ -416,9 +425,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, switch ( cell.tag.value ) { case CONSTV: - { result = c_apply( frame, frame_pointer, env ); - } break; case SYMBOLTV: From b6958bbf6516791a32bf048b3876fc287b027078 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 5 Feb 2019 13:46:46 +0000 Subject: [PATCH 061/101] #8: compiles, but most tests fail. --- src/memory/consspaceobject.c | 27 +- src/memory/consspaceobject.h | 2 + src/memory/lookup3.c | 1001 ++++++++++++++++++++++++++++++++++ src/memory/lookup3.h | 19 + src/memory/map.c | 243 +++++++++ src/memory/map.h | 29 +- src/ops/intern.c | 35 +- src/ops/lispops.c | 16 + src/ops/lispops.h | 4 +- 9 files changed, 1360 insertions(+), 16 deletions(-) create mode 100644 src/memory/lookup3.c create mode 100644 src/memory/lookup3.h diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index aa1cece..344f4ae 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -96,18 +96,41 @@ struct cons_pointer c_car( struct cons_pointer arg ) { } /** - * Implementation of cdr in C. If arg is not a cons, does not error but returns nil. + * Implementation of cdr in C. If arg is not a sequence, does not error but returns nil. */ struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer result = NIL; - if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) { + struct cons_space_object cell = pointer2cell( arg ); + + switch (cell.tag.value) { + case CONSTV: result = pointer2cell( arg ).payload.cons.cdr; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = pointer2cell( arg ).payload.string.cdr; + break; } return result; } +/** + * Implementation of `length` in C. If arg is not a cons, does not error but returns 0. + */ +int c_length( struct cons_pointer arg) { + int result = 0; + + for (struct cons_pointer c = arg; !nilp(c); c = c_cdr(c)) { + result ++; + } + + return result; +} + + /** * Construct a cons cell from this pair of pointers. */ diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 91ba3c3..9197172 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -667,6 +667,8 @@ struct cons_pointer c_car( struct cons_pointer arg ); struct cons_pointer c_cdr( struct cons_pointer arg ); +int c_length( struct cons_pointer arg); + struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ); diff --git a/src/memory/lookup3.c b/src/memory/lookup3.c new file mode 100644 index 0000000..006d513 --- /dev/null +++ b/src/memory/lookup3.c @@ -0,0 +1,1001 @@ +/* +------------------------------------------------------------------------------- +lookup3.c, by Bob Jenkins, May 2006, Public Domain. + +These are functions for producing 32-bit hashes for hash table lookup. +hashword(), hashlittle(), hashlittle2(), hashbig(), mix(), and final() +are externally useful functions. Routines to test the hash are included +if SELF_TEST is defined. You can use this free for any purpose. It's in +the public domain. It has no warranty. + +You probably want to use hashlittle(). hashlittle() and hashbig() +hash byte arrays. hashlittle() is is faster than hashbig() on +little-endian machines. Intel and AMD are little-endian machines. +On second thought, you probably want hashlittle2(), which is identical to +hashlittle() except it returns two 32-bit hashes for the price of one. +You could implement hashbig2() if you wanted but I haven't bothered here. + +If you want to find a hash of, say, exactly 7 integers, do + a = i1; b = i2; c = i3; + mix(a,b,c); + a += i4; b += i5; c += i6; + mix(a,b,c); + a += i7; + final(a,b,c); +then use c as the hash value. If you have a variable length array of +4-byte integers to hash, use hashword(). If you have a byte array (like +a character string), use hashlittle(). If you have several byte arrays, or +a mix of things, see the comments above hashlittle(). + +Why is this so big? I read 12 bytes at a time into 3 4-byte integers, +then mix those integers. This is fast (you can do a lot more thorough +mixing with 12*3 instructions on 3 integers than you can with 3 instructions +on 1 byte), but shoehorning those bytes into integers efficiently is messy. +------------------------------------------------------------------------------- +*/ +// #define SELF_TEST 1 + +#include /* defines printf for tests */ +#include /* defines time_t for timings in the test */ +#include /* defines uint32_t etc */ +#include /* attempt to define endianness */ +#ifdef linux +# include /* attempt to define endianness */ +#endif + +/* + * My best guess at if you are big-endian or little-endian. This may + * need adjustment. + */ +#if (defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && \ + __BYTE_ORDER == __LITTLE_ENDIAN) || \ + (defined(i386) || defined(__i386__) || defined(__i486__) || \ + defined(__i586__) || defined(__i686__) || defined(vax) || defined(MIPSEL)) +# define HASH_LITTLE_ENDIAN 1 +# define HASH_BIG_ENDIAN 0 +#elif (defined(__BYTE_ORDER) && defined(__BIG_ENDIAN) && \ + __BYTE_ORDER == __BIG_ENDIAN) || \ + (defined(sparc) || defined(POWERPC) || defined(mc68000) || defined(sel)) +# define HASH_LITTLE_ENDIAN 0 +# define HASH_BIG_ENDIAN 1 +#else +# define HASH_LITTLE_ENDIAN 0 +# define HASH_BIG_ENDIAN 0 +#endif + +#define hashsize(n) ((uint32_t)1<<(n)) +#define hashmask(n) (hashsize(n)-1) +#define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k)))) + +/* +------------------------------------------------------------------------------- +mix -- mix 3 32-bit values reversibly. + +This is reversible, so any information in (a,b,c) before mix() is +still in (a,b,c) after mix(). + +If four pairs of (a,b,c) inputs are run through mix(), or through +mix() in reverse, there are at least 32 bits of the output that +are sometimes the same for one pair and different for another pair. +This was tested for: +* pairs that differed by one bit, by two bits, in any combination + of top bits of (a,b,c), or in any combination of bottom bits of + (a,b,c). +* "differ" is defined as +, -, ^, or ~^. For + and -, I transformed + the output delta to a Gray code (a^(a>>1)) so a string of 1's (as + is commonly produced by subtraction) look like a single 1-bit + difference. +* the base values were pseudorandom, all zero but one bit set, or + all zero plus a counter that starts at zero. + +Some k values for my "a-=c; a^=rot(c,k); c+=b;" arrangement that +satisfy this are + 4 6 8 16 19 4 + 9 15 3 18 27 15 + 14 9 3 7 17 3 +Well, "9 15 3 18 27 15" didn't quite get 32 bits diffing +for "differ" defined as + with a one-bit base and a two-bit delta. I +used http://burtleburtle.net/bob/hash/avalanche.html to choose +the operations, constants, and arrangements of the variables. + +This does not achieve avalanche. There are input bits of (a,b,c) +that fail to affect some output bits of (a,b,c), especially of a. The +most thoroughly mixed value is c, but it doesn't really even achieve +avalanche in c. + +This allows some parallelism. Read-after-writes are good at doubling +the number of bits affected, so the goal of mixing pulls in the opposite +direction as the goal of parallelism. I did what I could. Rotates +seem to cost as much as shifts on every machine I could lay my hands +on, and rotates are much kinder to the top and bottom bits, so I used +rotates. +------------------------------------------------------------------------------- +*/ +#define mix(a,b,c) \ +{ \ + a -= c; a ^= rot(c, 4); c += b; \ + b -= a; b ^= rot(a, 6); a += c; \ + c -= b; c ^= rot(b, 8); b += a; \ + a -= c; a ^= rot(c,16); c += b; \ + b -= a; b ^= rot(a,19); a += c; \ + c -= b; c ^= rot(b, 4); b += a; \ +} + +/* +------------------------------------------------------------------------------- +final -- final mixing of 3 32-bit values (a,b,c) into c + +Pairs of (a,b,c) values differing in only a few bits will usually +produce values of c that look totally different. This was tested for +* pairs that differed by one bit, by two bits, in any combination + of top bits of (a,b,c), or in any combination of bottom bits of + (a,b,c). +* "differ" is defined as +, -, ^, or ~^. For + and -, I transformed + the output delta to a Gray code (a^(a>>1)) so a string of 1's (as + is commonly produced by subtraction) look like a single 1-bit + difference. +* the base values were pseudorandom, all zero but one bit set, or + all zero plus a counter that starts at zero. + +These constants passed: + 14 11 25 16 4 14 24 + 12 14 25 16 4 14 24 +and these came close: + 4 8 15 26 3 22 24 + 10 8 15 26 3 22 24 + 11 8 15 26 3 22 24 +------------------------------------------------------------------------------- +*/ +#define final(a,b,c) \ +{ \ + c ^= b; c -= rot(b,14); \ + a ^= c; a -= rot(c,11); \ + b ^= a; b -= rot(a,25); \ + c ^= b; c -= rot(b,16); \ + a ^= c; a -= rot(c,4); \ + b ^= a; b -= rot(a,14); \ + c ^= b; c -= rot(b,24); \ +} + +/* +-------------------------------------------------------------------- + This works on all machines. To be useful, it requires + -- that the key be an array of uint32_t's, and + -- that the length be the number of uint32_t's in the key + + The function hashword() is identical to hashlittle() on little-endian + machines, and identical to hashbig() on big-endian machines, + except that the length has to be measured in uint32_ts rather than in + bytes. hashlittle() is more complicated than hashword() only because + hashlittle() has to dance around fitting the key bytes into registers. +-------------------------------------------------------------------- +*/ +uint32_t hashword( +const uint32_t *k, /* the key, an array of uint32_t values */ +size_t length, /* the length of the key, in uint32_ts */ +uint32_t initval) /* the previous hash, or an arbitrary value */ +{ + uint32_t a,b,c; + + /* Set up the internal state */ + a = b = c = 0xdeadbeef + (((uint32_t)length)<<2) + initval; + + /*------------------------------------------------- handle most of the key */ + while (length > 3) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 3; + k += 3; + } + + /*------------------------------------------- handle the last 3 uint32_t's */ + switch(length) /* all the case statements fall through */ + { + case 3 : c+=k[2]; + case 2 : b+=k[1]; + case 1 : a+=k[0]; + final(a,b,c); + case 0: /* case 0: nothing left to add */ + break; + } + /*------------------------------------------------------ report the result */ + return c; +} + + +/* +-------------------------------------------------------------------- +hashword2() -- same as hashword(), but take two seeds and return two +32-bit values. pc and pb must both be nonnull, and *pc and *pb must +both be initialized with seeds. If you pass in (*pb)==0, the output +(*pc) will be the same as the return value from hashword(). +-------------------------------------------------------------------- +*/ +void hashword2 ( +const uint32_t *k, /* the key, an array of uint32_t values */ +size_t length, /* the length of the key, in uint32_ts */ +uint32_t *pc, /* IN: seed OUT: primary hash value */ +uint32_t *pb) /* IN: more seed OUT: secondary hash value */ +{ + uint32_t a,b,c; + + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ((uint32_t)(length<<2)) + *pc; + c += *pb; + + /*------------------------------------------------- handle most of the key */ + while (length > 3) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 3; + k += 3; + } + + /*------------------------------------------- handle the last 3 uint32_t's */ + switch(length) /* all the case statements fall through */ + { + case 3 : c+=k[2]; + case 2 : b+=k[1]; + case 1 : a+=k[0]; + final(a,b,c); + case 0: /* case 0: nothing left to add */ + break; + } + /*------------------------------------------------------ report the result */ + *pc=c; *pb=b; +} + + +/* +------------------------------------------------------------------------------- +hashlittle() -- hash a variable-length key into a 32-bit value + k : the key (the unaligned variable-length array of bytes) + length : the length of the key, counting by bytes + initval : can be any 4-byte value +Returns a 32-bit value. Every bit of the key affects every bit of +the return value. Two keys differing by one or two bits will have +totally different hash values. + +The best hash table sizes are powers of 2. There is no need to do +mod a prime (mod is sooo slow!). If you need less than 32 bits, +use a bitmask. For example, if you need only 10 bits, do + h = (h & hashmask(10)); +In which case, the hash table should have hashsize(10) elements. + +If you are hashing n strings (uint8_t **)k, do it like this: + for (i=0, h=0; i 12) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 12; + k += 3; + } + + /*----------------------------- handle the last (probably partial) block */ + /* + * "k[2]&0xffffff" actually reads beyond the end of the string, but + * then masks off the part it's not allowed to read. Because the + * string is aligned, the masked-off tail is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ +#ifndef VALGRIND + + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break; + case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break; + case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break; + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=k[1]&0xffffff; a+=k[0]; break; + case 6 : b+=k[1]&0xffff; a+=k[0]; break; + case 5 : b+=k[1]&0xff; a+=k[0]; break; + case 4 : a+=k[0]; break; + case 3 : a+=k[0]&0xffffff; break; + case 2 : a+=k[0]&0xffff; break; + case 1 : a+=k[0]&0xff; break; + case 0 : return c; /* zero length strings require no mixing */ + } + +#else /* make valgrind happy */ + + k8 = (const uint8_t *)k; + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ + case 10: c+=((uint32_t)k8[9])<<8; /* fall through */ + case 9 : c+=k8[8]; /* fall through */ + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ + case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */ + case 5 : b+=k8[4]; /* fall through */ + case 4 : a+=k[0]; break; + case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ + case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */ + case 1 : a+=k8[0]; break; + case 0 : return c; + } + +#endif /* !valgrind */ + + } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) { + const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ + const uint8_t *k8; + + /*--------------- all but last block: aligned reads and different mixing */ + while (length > 12) + { + a += k[0] + (((uint32_t)k[1])<<16); + b += k[2] + (((uint32_t)k[3])<<16); + c += k[4] + (((uint32_t)k[5])<<16); + mix(a,b,c); + length -= 12; + k += 6; + } + + /*----------------------------- handle the last (probably partial) block */ + k8 = (const uint8_t *)k; + switch(length) + { + case 12: c+=k[4]+(((uint32_t)k[5])<<16); + b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ + case 10: c+=k[4]; + b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 9 : c+=k8[8]; /* fall through */ + case 8 : b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ + case 6 : b+=k[2]; + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 5 : b+=k8[4]; /* fall through */ + case 4 : a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ + case 2 : a+=k[0]; + break; + case 1 : a+=k8[0]; + break; + case 0 : return c; /* zero length requires no mixing */ + } + + } else { /* need to read the key one byte at a time */ + const uint8_t *k = (const uint8_t *)key; + + /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ + while (length > 12) + { + a += k[0]; + a += ((uint32_t)k[1])<<8; + a += ((uint32_t)k[2])<<16; + a += ((uint32_t)k[3])<<24; + b += k[4]; + b += ((uint32_t)k[5])<<8; + b += ((uint32_t)k[6])<<16; + b += ((uint32_t)k[7])<<24; + c += k[8]; + c += ((uint32_t)k[9])<<8; + c += ((uint32_t)k[10])<<16; + c += ((uint32_t)k[11])<<24; + mix(a,b,c); + length -= 12; + k += 12; + } + + /*-------------------------------- last block: affect all 32 bits of (c) */ + switch(length) /* all the case statements fall through */ + { + case 12: c+=((uint32_t)k[11])<<24; + case 11: c+=((uint32_t)k[10])<<16; + case 10: c+=((uint32_t)k[9])<<8; + case 9 : c+=k[8]; + case 8 : b+=((uint32_t)k[7])<<24; + case 7 : b+=((uint32_t)k[6])<<16; + case 6 : b+=((uint32_t)k[5])<<8; + case 5 : b+=k[4]; + case 4 : a+=((uint32_t)k[3])<<24; + case 3 : a+=((uint32_t)k[2])<<16; + case 2 : a+=((uint32_t)k[1])<<8; + case 1 : a+=k[0]; + break; + case 0 : return c; + } + } + + final(a,b,c); + return c; +} + + +/* + * hashlittle2: return 2 32-bit hash values + * + * This is identical to hashlittle(), except it returns two 32-bit hash + * values instead of just one. This is good enough for hash table + * lookup with 2^^64 buckets, or if you want a second hash if you're not + * happy with the first, or if you want a probably-unique 64-bit ID for + * the key. *pc is better mixed than *pb, so use *pc first. If you want + * a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)". + */ +void hashlittle2( + const void *key, /* the key to hash */ + size_t length, /* length of the key */ + uint32_t *pc, /* IN: primary initval, OUT: primary hash */ + uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */ +{ + uint32_t a,b,c; /* internal state */ + union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */ + + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ((uint32_t)length) + *pc; + c += *pb; + + u.ptr = key; + if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) { + const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ + const uint8_t *k8; + + /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ + while (length > 12) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 12; + k += 3; + } + + /*----------------------------- handle the last (probably partial) block */ + /* + * "k[2]&0xffffff" actually reads beyond the end of the string, but + * then masks off the part it's not allowed to read. Because the + * string is aligned, the masked-off tail is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ +#ifndef VALGRIND + + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break; + case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break; + case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break; + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=k[1]&0xffffff; a+=k[0]; break; + case 6 : b+=k[1]&0xffff; a+=k[0]; break; + case 5 : b+=k[1]&0xff; a+=k[0]; break; + case 4 : a+=k[0]; break; + case 3 : a+=k[0]&0xffffff; break; + case 2 : a+=k[0]&0xffff; break; + case 1 : a+=k[0]&0xff; break; + case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + } + +#else /* make valgrind happy */ + + k8 = (const uint8_t *)k; + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ + case 10: c+=((uint32_t)k8[9])<<8; /* fall through */ + case 9 : c+=k8[8]; /* fall through */ + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ + case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */ + case 5 : b+=k8[4]; /* fall through */ + case 4 : a+=k[0]; break; + case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ + case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */ + case 1 : a+=k8[0]; break; + case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + } + +#endif /* !valgrind */ + + } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) { + const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ + const uint8_t *k8; + + /*--------------- all but last block: aligned reads and different mixing */ + while (length > 12) + { + a += k[0] + (((uint32_t)k[1])<<16); + b += k[2] + (((uint32_t)k[3])<<16); + c += k[4] + (((uint32_t)k[5])<<16); + mix(a,b,c); + length -= 12; + k += 6; + } + + /*----------------------------- handle the last (probably partial) block */ + k8 = (const uint8_t *)k; + switch(length) + { + case 12: c+=k[4]+(((uint32_t)k[5])<<16); + b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ + case 10: c+=k[4]; + b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 9 : c+=k8[8]; /* fall through */ + case 8 : b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ + case 6 : b+=k[2]; + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 5 : b+=k8[4]; /* fall through */ + case 4 : a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ + case 2 : a+=k[0]; + break; + case 1 : a+=k8[0]; + break; + case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + } + + } else { /* need to read the key one byte at a time */ + const uint8_t *k = (const uint8_t *)key; + + /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ + while (length > 12) + { + a += k[0]; + a += ((uint32_t)k[1])<<8; + a += ((uint32_t)k[2])<<16; + a += ((uint32_t)k[3])<<24; + b += k[4]; + b += ((uint32_t)k[5])<<8; + b += ((uint32_t)k[6])<<16; + b += ((uint32_t)k[7])<<24; + c += k[8]; + c += ((uint32_t)k[9])<<8; + c += ((uint32_t)k[10])<<16; + c += ((uint32_t)k[11])<<24; + mix(a,b,c); + length -= 12; + k += 12; + } + + /*-------------------------------- last block: affect all 32 bits of (c) */ + switch(length) /* all the case statements fall through */ + { + case 12: c+=((uint32_t)k[11])<<24; + case 11: c+=((uint32_t)k[10])<<16; + case 10: c+=((uint32_t)k[9])<<8; + case 9 : c+=k[8]; + case 8 : b+=((uint32_t)k[7])<<24; + case 7 : b+=((uint32_t)k[6])<<16; + case 6 : b+=((uint32_t)k[5])<<8; + case 5 : b+=k[4]; + case 4 : a+=((uint32_t)k[3])<<24; + case 3 : a+=((uint32_t)k[2])<<16; + case 2 : a+=((uint32_t)k[1])<<8; + case 1 : a+=k[0]; + break; + case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + } + } + + final(a,b,c); + *pc=c; *pb=b; +} + + + +/* + * hashbig(): + * This is the same as hashword() on big-endian machines. It is different + * from hashlittle() on all machines. hashbig() takes advantage of + * big-endian byte ordering. + */ +uint32_t hashbig( const void *key, size_t length, uint32_t initval) +{ + uint32_t a,b,c; + union { const void *ptr; size_t i; } u; /* to cast key to (size_t) happily */ + + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ((uint32_t)length) + initval; + + u.ptr = key; + if (HASH_BIG_ENDIAN && ((u.i & 0x3) == 0)) { + const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ + const uint8_t *k8; + + /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ + while (length > 12) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 12; + k += 3; + } + + /*----------------------------- handle the last (probably partial) block */ + /* + * "k[2]<<8" actually reads beyond the end of the string, but + * then shifts out the part it's not allowed to read. Because the + * string is aligned, the illegal read is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ +#ifndef VALGRIND + + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=k[2]&0xffffff00; b+=k[1]; a+=k[0]; break; + case 10: c+=k[2]&0xffff0000; b+=k[1]; a+=k[0]; break; + case 9 : c+=k[2]&0xff000000; b+=k[1]; a+=k[0]; break; + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=k[1]&0xffffff00; a+=k[0]; break; + case 6 : b+=k[1]&0xffff0000; a+=k[0]; break; + case 5 : b+=k[1]&0xff000000; a+=k[0]; break; + case 4 : a+=k[0]; break; + case 3 : a+=k[0]&0xffffff00; break; + case 2 : a+=k[0]&0xffff0000; break; + case 1 : a+=k[0]&0xff000000; break; + case 0 : return c; /* zero length strings require no mixing */ + } + +#else /* make valgrind happy */ + + k8 = (const uint8_t *)k; + switch(length) /* all the case statements fall through */ + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=((uint32_t)k8[10])<<8; /* fall through */ + case 10: c+=((uint32_t)k8[9])<<16; /* fall through */ + case 9 : c+=((uint32_t)k8[8])<<24; /* fall through */ + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=((uint32_t)k8[6])<<8; /* fall through */ + case 6 : b+=((uint32_t)k8[5])<<16; /* fall through */ + case 5 : b+=((uint32_t)k8[4])<<24; /* fall through */ + case 4 : a+=k[0]; break; + case 3 : a+=((uint32_t)k8[2])<<8; /* fall through */ + case 2 : a+=((uint32_t)k8[1])<<16; /* fall through */ + case 1 : a+=((uint32_t)k8[0])<<24; break; + case 0 : return c; + } + +#endif /* !VALGRIND */ + + } else { /* need to read the key one byte at a time */ + const uint8_t *k = (const uint8_t *)key; + + /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ + while (length > 12) + { + a += ((uint32_t)k[0])<<24; + a += ((uint32_t)k[1])<<16; + a += ((uint32_t)k[2])<<8; + a += ((uint32_t)k[3]); + b += ((uint32_t)k[4])<<24; + b += ((uint32_t)k[5])<<16; + b += ((uint32_t)k[6])<<8; + b += ((uint32_t)k[7]); + c += ((uint32_t)k[8])<<24; + c += ((uint32_t)k[9])<<16; + c += ((uint32_t)k[10])<<8; + c += ((uint32_t)k[11]); + mix(a,b,c); + length -= 12; + k += 12; + } + + /*-------------------------------- last block: affect all 32 bits of (c) */ + switch(length) /* all the case statements fall through */ + { + case 12: c+=k[11]; + case 11: c+=((uint32_t)k[10])<<8; + case 10: c+=((uint32_t)k[9])<<16; + case 9 : c+=((uint32_t)k[8])<<24; + case 8 : b+=k[7]; + case 7 : b+=((uint32_t)k[6])<<8; + case 6 : b+=((uint32_t)k[5])<<16; + case 5 : b+=((uint32_t)k[4])<<24; + case 4 : a+=k[3]; + case 3 : a+=((uint32_t)k[2])<<8; + case 2 : a+=((uint32_t)k[1])<<16; + case 1 : a+=((uint32_t)k[0])<<24; + break; + case 0 : return c; + } + } + + final(a,b,c); + return c; +} + + +#ifdef SELF_TEST + +/* used for timings */ +void driver1() +{ + uint8_t buf[256]; + uint32_t i; + uint32_t h=0; + time_t a,z; + + time(&a); + for (i=0; i<256; ++i) buf[i] = 'x'; + for (i=0; i<1; ++i) + { + h = hashlittle(&buf[0],1,h); + } + time(&z); + if (z-a > 0) printf("time %d %.8x\n", z-a, h); +} + +/* check that every input bit changes every output bit half the time */ +#define HASHSTATE 1 +#define HASHLEN 1 +#define MAXPAIR 60 +#define MAXLEN 70 +void driver2() +{ + uint8_t qa[MAXLEN+1], qb[MAXLEN+2], *a = &qa[0], *b = &qb[1]; + uint32_t c[HASHSTATE], d[HASHSTATE], i=0, j=0, k, l, m=0, z; + uint32_t e[HASHSTATE],f[HASHSTATE],g[HASHSTATE],h[HASHSTATE]; + uint32_t x[HASHSTATE],y[HASHSTATE]; + uint32_t hlen; + + printf("No more than %d trials should ever be needed \n",MAXPAIR/2); + for (hlen=0; hlen < MAXLEN; ++hlen) + { + z=0; + for (i=0; i>(8-j)); + c[0] = hashlittle(a, hlen, m); + b[i] ^= ((k+1)<>(8-j)); + d[0] = hashlittle(b, hlen, m); + /* check every bit is 1, 0, set, and not set at least once */ + for (l=0; lz) z=k; + if (k==MAXPAIR) + { + printf("Some bit didn't change: "); + printf("%.8x %.8x %.8x %.8x %.8x %.8x ", + e[0],f[0],g[0],h[0],x[0],y[0]); + printf("i %d j %d m %d len %d\n", i, j, m, hlen); + } + if (z==MAXPAIR) goto done; + } + } + } + done: + if (z < MAXPAIR) + { + printf("Mix success %2d bytes %2d initvals ",i,m); + printf("required %d trials\n", z/2); + } + } + printf("\n"); +} + +/* Check for reading beyond the end of the buffer and alignment problems */ +void driver3() +{ + uint8_t buf[MAXLEN+20], *b; + uint32_t len; + uint8_t q[] = "This is the time for all good men to come to the aid of their country..."; + uint32_t h; + uint8_t qq[] = "xThis is the time for all good men to come to the aid of their country..."; + uint32_t i; + uint8_t qqq[] = "xxThis is the time for all good men to come to the aid of their country..."; + uint32_t j; + uint8_t qqqq[] = "xxxThis is the time for all good men to come to the aid of their country..."; + uint32_t ref,x,y; + uint8_t *p; + + printf("Endianness. These lines should all be the same (for values filled in):\n"); + printf("%.8x %.8x %.8x\n", + hashword((const uint32_t *)q, (sizeof(q)-1)/4, 13), + hashword((const uint32_t *)q, (sizeof(q)-5)/4, 13), + hashword((const uint32_t *)q, (sizeof(q)-9)/4, 13)); + p = q; + printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), + hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), + hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), + hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), + hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), + hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); + p = &qq[1]; + printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), + hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), + hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), + hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), + hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), + hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); + p = &qqq[2]; + printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), + hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), + hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), + hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), + hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), + hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); + p = &qqqq[3]; + printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), + hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), + hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), + hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), + hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), + hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); + printf("\n"); + + /* check that hashlittle2 and hashlittle produce the same results */ + i=47; j=0; + hashlittle2(q, sizeof(q), &i, &j); + if (hashlittle(q, sizeof(q), 47) != i) + printf("hashlittle2 and hashlittle mismatch\n"); + + /* check that hashword2 and hashword produce the same results */ + len = 0xdeadbeef; + i=47, j=0; + hashword2(&len, 1, &i, &j); + if (hashword(&len, 1, 47) != i) + printf("hashword2 and hashword mismatch %x %x\n", + i, hashword(&len, 1, 47)); + + /* check hashlittle doesn't read before or after the ends of the string */ + for (h=0, b=buf+1; h<8; ++h, ++b) + { + for (i=0; i + * Public domain. + */ + +#ifndef __lookup3_h +#define __lookup3_h + +uint32_t hashword( +const uint32_t *k, +size_t length, +uint32_t initval); + +#endif diff --git a/src/memory/map.c b/src/memory/map.c index e897647..358b2e4 100644 --- a/src/memory/map.c +++ b/src/memory/map.c @@ -6,3 +6,246 @@ * (c) 2019 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. */ + +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "debug.h" +#include "dump.h" +#include "fopen.h" +#include "intern.h" +#include "lookup3.h" +#include "map.h" +#include "print.h" +#include "vectorspace.h" + +/* \todo: a lot of this will be inherited by namespaces, regularities and + * homogeneities. Exactly how I don't yet know. */ + +/** + * Get a hash value for this key. + */ +uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) { + uint32_t result = 0; + int l = c_length(key); + + if (keywordp(key) || stringp(key)) { + if ( l > 0) { + uint32_t buffer[l]; + + if (!nilp(f)) { + fputws(L"Custom hashing functions are not yet implemented.\n", stderr); + } + for (int i = 0; i < l; i++) { + buffer[i] = (uint32_t)pointer2cell(key).payload.string.character; + } + + result = hashword( buffer, l, 0); + } + } else { + fputws(L"Hashing is thud far implemented only for keys and strings.\n", stderr); + } + + return result; +} + +/** + * get the actual map object from this `pointer`, or NULL if + * `pointer` is not a map pointer. + */ +struct map_payload *get_map_payload( struct cons_pointer pointer ) { + struct map_payload *result = NULL; + struct vector_space_object *vso = + pointer2cell( pointer ).payload.vectorp.address; + + if (vectorpointp(pointer) && mapp( vso ) ) { + result = ( struct map_payload * ) &( vso->payload ); + debug_printf( DEBUG_STACK, + L"get_map_payload: all good, returning %p\n", result ); + } else { + debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_STACK ); + } + + return result; +} + + +/** + * Make an empty immutable map, and return it. + * + * @param hash_function a pointer to a function of one argument, which + * returns an integer; or (more usually) `nil`. + * @return the new map, or NULL if memory is exhausted. + */ +struct cons_pointer make_empty_map( struct cons_pointer hash_function ) { + debug_print( L"Entering make_empty_map\n", DEBUG_ALLOC ); + struct cons_pointer result = + make_vso( MAPTAG, sizeof( struct map_payload ) ); + + if ( !nilp( result ) ) { + struct map_payload *payload = get_map_payload( result ); + + payload->hash_function = functionp( hash_function) ? hash_function : NIL; + inc_ref(hash_function); + + for ( int i = 0; i < BUCKETSINMAP; i++) { + payload->buckets[i] = NIL; + } + } + + return result; +} + + +struct cons_pointer make_duplicate_map( struct cons_pointer parent) { + struct cons_pointer result = NIL; + struct map_payload * parent_payload = get_map_payload(parent); + + if (parent_payload != NULL) { + result = + make_vso( MAPTAG, sizeof( struct map_payload ) ); + + if ( !nilp( result ) ) { + struct map_payload *payload = get_map_payload( result ); + + payload->hash_function = parent_payload->hash_function; + inc_ref(payload->hash_function); + + for ( int i = 0; i < BUCKETSINMAP; i++) { + payload->buckets[i] = parent_payload->buckets[i]; + inc_ref(payload->buckets[i]); + } + } + } + + return result; +} + + +struct cons_pointer bind_in_map( struct cons_pointer parent, + struct cons_pointer key, + struct cons_pointer value) { + struct cons_pointer result = make_duplicate_map(parent); + + if ( !nilp( result)) { + struct map_payload * payload = get_map_payload( result ); + int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; + + payload->buckets[bucket] = make_cons( + make_cons(key, value), payload->buckets[bucket]); + + inc_ref(payload->buckets[bucket]); + } + + return result; +} + + +struct cons_pointer keys( struct cons_pointer store) { + struct cons_pointer result = NIL; + + struct cons_space_object cell = pointer2cell( store ); + + switch (pointer2cell( store ).tag.value) { + case CONSTV: + for (struct cons_pointer c = store; !nilp(c); c = c_cdr(c)) { + result = make_cons( c_car( c_car( c)), result); + } + break; + case VECTORPOINTTV: { + struct vector_space_object *vso = + pointer2cell( store ).payload.vectorp.address; + + if ( mapp( vso ) ) { + struct map_payload * payload = get_map_payload( result ); + + for (int bucket = 0; bucket < BUCKETSINMAP; bucket++) { + for (struct cons_pointer c = payload->buckets[bucket]; + !nilp(c); c = c_cdr(c)) { + result = make_cons( c_car( c_car( c)), result); + } + } + } + } + break; + } + + return result; +} + +/** + * Return a new map which represents the merger of `to_merge` into + * `parent`. `parent` must be a map, but `to_merge` may be a map or + * an assoc list. + * + * @param parent a map; + * @param to_merge an association from which key/value pairs will be merged. + * @result a new map, containing all key/value pairs from `to_merge` + * together with those key/value pairs from `parent` whose keys did not + * collide. + */ +struct cons_pointer merge_into_map( struct cons_pointer parent, + struct cons_pointer to_merge) { + struct cons_pointer result = make_duplicate_map(parent); + + if (!nilp(result)) { + struct map_payload *payload = get_map_payload( result ); + for (struct cons_pointer c = keys(to_merge); + !nilp(c); c = c_cdr(c)) { + struct cons_pointer key = c_car( c); + int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; + + payload->buckets[bucket] = make_cons( + make_cons( key, c_assoc( key, to_merge)), + payload->buckets[bucket]); + } + } + + return result; +} + + +struct cons_pointer assoc_in_map( struct cons_pointer map, + struct cons_pointer key) { + struct cons_pointer result = NIL; + struct map_payload *payload = get_map_payload( map ); + + if (payload != NULL) { + int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; + + result = c_assoc(key, payload->buckets[bucket]); + } + + return result; +} + +/** + * Dump a map to this stream for debugging + * @param output the stream + * @param map_pointer the pointer to the frame + */ +void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) { + struct vector_space_object *vso = + pointer2cell( map_pointer ).payload.vectorp.address; + + if (vectorpointp(map_pointer) && mapp( vso ) ) { + struct map_payload *payload = get_map_payload( map_pointer ); + + if ( payload != NULL ) { + url_fputws( L"Immutable map; hash function:", output ); + + if (nilp(payload->hash_function)) { + url_fputws( L"default", output); + } else { + dump_object( output, payload->hash_function); + } + + for (int i = 0; i < BUCKETSINMAP; i++) { + url_fwprintf(output, L"\n\tBucket %d: ", i); + print( output, payload->buckets[i]); + } + } + } +} + diff --git a/src/memory/map.h b/src/memory/map.h index d7a65c5..143c7b9 100644 --- a/src/memory/map.h +++ b/src/memory/map.h @@ -30,7 +30,14 @@ #define MAXENTRIESINASSOC 16 /** - * The vector-space payload of a map object. + * true if this vector_space_object is a map, else false. + */ +#define mapp( vso) (((struct vector_space_object *)vso)->header.tag.value == MAPTV) + +/** + * The vector-space payload of a map object. Essentially a vector of + * `BUCKETSINMAP` + 1 `cons_pointer`s, but the first one is considered + * special. */ struct map_payload { /** @@ -39,7 +46,7 @@ struct map_payload { * their own hash values. But it will be possible to override the hash * function by putting a function of one argument returning an integer * here. */ - struct cons_pointer hash_function = NIL; + struct cons_pointer hash_function; /** * Obviously the number of buckets in a map is a trade off, and this may need @@ -62,4 +69,22 @@ struct map_payload { struct cons_pointer buckets[BUCKETSINMAP]; }; +uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key); + +struct map_payload *get_map_payload( struct cons_pointer pointer ); + +struct cons_pointer bind_in_map( struct cons_pointer parent, + struct cons_pointer key, + struct cons_pointer value); + +struct cons_pointer keys( struct cons_pointer store); + +struct cons_pointer merge_into_map( struct cons_pointer parent, + struct cons_pointer to_merge); + +struct cons_pointer assoc_in_map( struct cons_pointer map, + struct cons_pointer key); + +void dump_map( URL_FILE * output, struct cons_pointer map_pointer ); + #endif diff --git a/src/ops/intern.c b/src/ops/intern.c index 8ce5d71..b4eafd2 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -24,6 +24,7 @@ #include "debug.h" #include "equal.h" #include "lispops.h" +#include "map.h" #include "print.h" /** @@ -88,7 +89,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { * of that key from the store; otherwise return NIL. */ struct cons_pointer c_assoc( struct cons_pointer key, - struct cons_pointer store ) { + struct cons_pointer store ) { struct cons_pointer result = NIL; debug_print( L"c_assoc; key is `", DEBUG_BIND); @@ -97,15 +98,19 @@ struct cons_pointer c_assoc( struct cons_pointer key, debug_dump_object( store, DEBUG_BIND); debug_println(DEBUG_BIND); - for ( struct cons_pointer next = store; - consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { - struct cons_space_object entry = - pointer2cell( pointer2cell( next ).payload.cons.car ); + if (consp(store)) { + for ( struct cons_pointer next = store; + consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { + struct cons_space_object entry = + pointer2cell( pointer2cell( next ).payload.cons.car ); - if ( equal( key, entry.payload.cons.car ) ) { - result = entry.payload.cons.cdr; - break; + if ( equal( key, entry.payload.cons.car ) ) { + result = entry.payload.cons.cdr; + break; + } } + } else if (vectorpointp( store)) { + result = assoc_in_map( key, store); } return result; @@ -116,15 +121,23 @@ struct cons_pointer c_assoc( struct cons_pointer key, * with this key/value pair added to the front. */ struct cons_pointer -set( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { + set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { + struct cons_pointer result = NIL; + debug_print( L"Binding ", DEBUG_BIND ); debug_print_object( key, DEBUG_BIND ); debug_print( L" to ", DEBUG_BIND ); debug_print_object( value, DEBUG_BIND ); debug_println( DEBUG_BIND ); - return make_cons( make_cons( key, value ), store ); + if (consp(store)) { + result = make_cons( make_cons( key, value ), store ); + } else if (vectorpointp( store)) { + result = bind_in_map( store, key, value); + } + + return result; } /** diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 14724a1..1624261 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -716,6 +716,22 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, return result; } +/** + * Function: return, as an integer, the length of the sequence indicated by + * the first argument, or zero if it is not a sequence. + * + * * (length any) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the length of `any`, if it is a sequence, or zero otherwise. + */ +struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_integer( c_length( frame->arg[0]), NIL); +} + /** * Function; look up the value of a `key` in a `store`. * diff --git a/src/ops/lispops.h b/src/ops/lispops.h index ea8a883..122635f 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -85,7 +85,9 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); - +struct cons_pointer lisp_length( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Construct an interpretable special form. * From 0687b0baebacc2940922c74f31f8b3133a388ddd Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 6 Feb 2019 11:17:31 +0000 Subject: [PATCH 062/101] #8: Buggy, but a lot of it works. --- src/init.c | 2 ++ src/io/print.c | 42 ++++++++++++++++++++++++++++++++++++++++++ src/memory/dump.c | 5 +++++ src/memory/map.c | 22 ++++++++++++++++++++-- src/memory/map.h | 6 +++++- src/ops/intern.c | 30 ++++++++++++++++++++++++------ 6 files changed, 98 insertions(+), 9 deletions(-) diff --git a/src/init.c b/src/init.c index 06494e9..82b497a 100644 --- a/src/init.c +++ b/src/init.c @@ -26,6 +26,7 @@ #include "intern.h" #include "io.h" #include "lispops.h" +#include "map.h" #include "meta.h" #include "peano.h" #include "print.h" @@ -196,6 +197,7 @@ int main( int argc, char *argv[] ) { bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); bind_function( L"inspect", &lisp_inspect ); + bind_function( L"make-map", &lisp_make_map); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); bind_function( L"multiply", &lisp_multiply ); diff --git a/src/io/print.c b/src/io/print.c index fb0d8a1..f4c98aa 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -20,9 +20,12 @@ #include "conspage.h" #include "consspaceobject.h" #include "integer.h" +#include "intern.h" +#include "map.h" #include "stack.h" #include "print.h" #include "time.h" +#include "vectorspace.h" /** * Whether or not we colorise output. @@ -98,7 +101,43 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) { } else { url_fputws( L")", output ); } +} + +void print_map( URL_FILE * output, struct cons_pointer pointer) { + if ( vectorpointp( pointer)) { + struct vector_space_object *vso = pointer_to_vso( pointer); + + if ( mapp( vso ) ) { + url_fputwc( btowc( '{' ), output ); + + for ( struct cons_pointer ks = keys(pointer); + !nilp(ks); ks = c_cdr(ks)) { + print( output, c_car(ks)); + url_fputwc( btowc( ' ' ), output ); + print( output, c_assoc( pointer, c_car(ks))); + + if ( !nilp( c_cdr( ks))) { + url_fputws( L", ", output ); + } + } + + url_fputwc( btowc( '}' ), output ); + } + } +} + + +void print_vso( URL_FILE * output, struct cons_pointer pointer) { + struct vector_space_object *vso = + pointer2cell( pointer ).payload.vectorp.address; + + switch ( vso->header.tag.value) { + case MAPTV: + print_map( output, pointer); + break; + // \todo: others. + } } /** @@ -217,6 +256,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { case TRUETV: url_fwprintf( output, L"t" ); break; + case VECTORPOINTTV: + print_vso( output, pointer); + break; case WRITETV: url_fwprintf( output, L"" ); break; diff --git a/src/memory/dump.c b/src/memory/dump.c index 28bd36a..074d1c4 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -21,6 +21,8 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "intern.h" +#include "map.h" #include "print.h" #include "stack.h" #include "vectorspace.h" @@ -146,6 +148,9 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { case STACKFRAMETV: dump_frame( output, pointer ); break; + case MAPTV: + dump_map( output, pointer); + break; } } break; diff --git a/src/memory/map.c b/src/memory/map.c index 358b2e4..7224a12 100644 --- a/src/memory/map.c +++ b/src/memory/map.c @@ -30,7 +30,7 @@ uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) { uint32_t result = 0; int l = c_length(key); - if (keywordp(key) || stringp(key)) { + if (keywordp(key) || stringp(key) || symbolp( key)) { if ( l > 0) { uint32_t buffer[l]; @@ -44,7 +44,7 @@ uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) { result = hashword( buffer, l, 0); } } else { - fputws(L"Hashing is thud far implemented only for keys and strings.\n", stderr); + fputws(L"Hashing is thus far implemented only for keys, strings and symbols.\n", stderr); } return result; @@ -220,6 +220,24 @@ struct cons_pointer assoc_in_map( struct cons_pointer map, return result; } +/** + * Function: create a map initialised with key/value pairs from my + * first argument. + * + * * (make-map) + * * (make-map store) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which it is to be intepreted. + * @return a new containing all the key/value pairs from store. + */ +struct cons_pointer +lisp_make_map( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return merge_into_map( make_empty_map( NIL), frame->arg[0]); +} + /** * Dump a map to this stream for debugging * @param output the stream diff --git a/src/memory/map.h b/src/memory/map.h index 143c7b9..76a7193 100644 --- a/src/memory/map.h +++ b/src/memory/map.h @@ -83,7 +83,11 @@ struct cons_pointer merge_into_map( struct cons_pointer parent, struct cons_pointer to_merge); struct cons_pointer assoc_in_map( struct cons_pointer map, - struct cons_pointer key); + struct cons_pointer key); + +struct cons_pointer lisp_make_map( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); void dump_map( URL_FILE * output, struct cons_pointer map_pointer ); diff --git a/src/ops/intern.c b/src/ops/intern.c index b4eafd2..02deb23 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -52,7 +52,7 @@ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_pointer result = NIL; - if ( symbolp( key ) ) { + if ( symbolp( key ) || keywordp( key ) ) { for ( struct cons_pointer next = store; nilp( result ) && consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { @@ -74,7 +74,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { debug_print_object( key, DEBUG_BIND ); debug_print( L"` is a ", DEBUG_BIND ); debug_print_object( c_type( key ), DEBUG_BIND ); - debug_print( L", not a SYMB", DEBUG_BIND ); + debug_print( L", not a KEYW or SYMB", DEBUG_BIND ); } return result; @@ -113,6 +113,10 @@ struct cons_pointer c_assoc( struct cons_pointer key, result = assoc_in_map( key, store); } + debug_print( L"c_assoc returning ", DEBUG_BIND); + debug_print_object( result, DEBUG_BIND); + debug_println( DEBUG_BIND); + return result; } @@ -125,18 +129,24 @@ struct cons_pointer struct cons_pointer store ) { struct cons_pointer result = NIL; - debug_print( L"Binding ", DEBUG_BIND ); + debug_print( L"set: binding `", DEBUG_BIND ); debug_print_object( key, DEBUG_BIND ); - debug_print( L" to ", DEBUG_BIND ); + debug_print( L"` to `", DEBUG_BIND ); debug_print_object( value, DEBUG_BIND ); + debug_print( L"` in store ", DEBUG_BIND ); + debug_dump_object( store, DEBUG_BIND); debug_println( DEBUG_BIND ); - if (consp(store)) { + if (nilp( store) || consp(store)) { result = make_cons( make_cons( key, value ), store ); } else if (vectorpointp( store)) { result = bind_in_map( store, key, value); } + debug_print( L"set returning ", DEBUG_BIND); + debug_print_object( result, DEBUG_BIND); + debug_println( DEBUG_BIND); + return result; } @@ -150,11 +160,19 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { debug_print( L"Entering deep_bind\n", DEBUG_BIND ); struct cons_pointer old = oblist; + debug_print( L"deep_bind: binding `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` to ", DEBUG_BIND ); + debug_print_object( value, DEBUG_BIND ); + debug_println( DEBUG_BIND ); + oblist = set( key, value, oblist ); inc_ref( oblist ); dec_ref( old ); - debug_print( L"Leaving deep_bind\n", DEBUG_BIND ); + debug_print( L"deep_bind returning ", DEBUG_BIND ); + debug_print_object( oblist, DEBUG_BIND ); + debug_println( DEBUG_BIND ); return oblist; } From f36436a9e145740ae937064298f9b2f6156313cf Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 Feb 2019 09:02:28 +0000 Subject: [PATCH 063/101] #8: Done I'm now of the opinion that this is done at the wrong level in the stack and needs to be redone later; but it works for now. There's a regression in `open`, but I can't see why. --- src/init.c | 2 +- src/io/io.c | 7 ++- src/io/print.c | 30 ++++++++----- src/io/read.c | 79 ++++++++++++++++++++++++++++----- src/memory/map.c | 36 +++++++++++---- src/memory/map.h | 6 ++- src/ops/intern.c | 4 +- src/ops/lispops.c | 1 + src/utils.c | 2 +- src/utils.h | 4 +- unit-tests/eval-quote-symbol.sh | 2 +- unit-tests/slurp.sh | 2 +- 12 files changed, 134 insertions(+), 41 deletions(-) diff --git a/src/init.c b/src/init.c index 82b497a..275cc40 100644 --- a/src/init.c +++ b/src/init.c @@ -69,7 +69,7 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) n ), NIL ) ); - deep_bind( n, make_special( NIL, executable ) ); + deep_bind( n, make_special( meta, executable ) ); } /** diff --git a/src/io/io.c b/src/io/io.c index b82c6ba..7e6a3c0 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -15,6 +15,7 @@ #include #include #include +#include #include #include #include @@ -277,9 +278,11 @@ struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key, /* I don't yet have a concept of a date-time object, which is a * bit of an oversight! */ char datestring[256]; - struct tm *tm = localtime( value ); - strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), tm ); + strftime( datestring, + sizeof( datestring ), + nl_langinfo( D_T_FMT ), + localtime( value ) ); return add_meta_string( meta, key, datestring ); } diff --git a/src/io/print.c b/src/io/print.c index f4c98aa..343160e 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -104,18 +104,18 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) { } -void print_map( URL_FILE * output, struct cons_pointer pointer) { - if ( vectorpointp( pointer)) { - struct vector_space_object *vso = pointer_to_vso( pointer); +void print_map( URL_FILE * output, struct cons_pointer map) { + if ( vectorpointp( map)) { + struct vector_space_object *vso = pointer_to_vso( map); if ( mapp( vso ) ) { url_fputwc( btowc( '{' ), output ); - for ( struct cons_pointer ks = keys(pointer); - !nilp(ks); ks = c_cdr(ks)) { - print( output, c_car(ks)); + for ( struct cons_pointer ks = keys( map); + !nilp( ks); ks = c_cdr( ks)) { + print( output, c_car( ks)); url_fputwc( btowc( ' ' ), output ); - print( output, c_assoc( pointer, c_car(ks))); + print( output, c_assoc( c_car( ks), map)); if ( !nilp( c_cdr( ks))) { url_fputws( L", ", output ); @@ -162,7 +162,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { dump_stack_trace( output, pointer ); break; case FUNCTIONTV: - url_fwprintf( output, L"" ); + url_fputws( L"', output); break; case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); @@ -214,7 +216,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print( output, cell.payload.ratio.divisor ); break; case READTV: - url_fwprintf( output, L"" ); + url_fwprintf( output, L"', output); break; case REALTV: /* \todo using the C heap is a bad plan because it will fragment. @@ -248,7 +252,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_string_contents( output, pointer ); break; case SPECIALTV: - url_fwprintf( output, L"" ); + url_fwprintf( output, L"', output); break; case TIMETV: print_string(output, time_to_string( pointer)); @@ -260,7 +266,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_vso( output, pointer); break; case WRITETV: - url_fwprintf( output, L"" ); + url_fwprintf( output, L"', output); break; default: fwprintf( stderr, diff --git a/src/io/read.c b/src/io/read.c index c49d043..4f3ed0a 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -24,6 +24,7 @@ #include "intern.h" #include "io.h" #include "lispops.h" +#include "map.h" #include "peano.h" #include "print.h" #include "ratio.h" @@ -44,6 +45,9 @@ struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE * input, wint_t initial ); +struct cons_pointer read_map( struct stack_frame *frame, + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag, wint_t initial ); @@ -100,6 +104,10 @@ struct cons_pointer read_continuation( struct stack_frame *frame, read_list( frame, frame_pointer, input, url_fgetwc( input ) ); break; + case '{': + result = read_map( frame, frame_pointer, input, + url_fgetwc( input ) ); + break; case '"': result = read_string( input, url_fgetwc( input ) ); break; @@ -126,9 +134,10 @@ struct cons_pointer read_continuation( struct stack_frame *frame, } else if ( iswblank( next ) ) { /* dotted pair. \todo this isn't right, we * really need to backtrack up a level. */ - result = - read_continuation( frame, frame_pointer, input, + result = read_continuation( frame, frame_pointer, input, url_fgetwc( input ) ); + debug_print( L"read_continuation: dotted pair; read cdr ", + DEBUG_IO); } else { read_symbol_or_key( input, SYMBOLTAG, c ); } @@ -275,19 +284,38 @@ struct cons_pointer read_number( struct stack_frame *frame, * left parenthesis. */ struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - URL_FILE * input, wint_t initial ) { + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ) { struct cons_pointer result = NIL; + wint_t c; + if ( initial != ')' ) { debug_printf( DEBUG_IO, - L"read_list starting '%C' (%d)\n", initial, initial ); + L"read_list starting '%C' (%d)\n", initial, initial ); struct cons_pointer car = read_continuation( frame, frame_pointer, input, - initial ); - result = - make_cons( car, - read_list( frame, frame_pointer, input, - url_fgetwc( input ) ) ); + initial ); + + /* skip whitespace */ + for (c = url_fgetwc( input ); + iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input )); + + if ( c == L'.') { + /* might be a dotted pair; indeed, if we rule out numbers with + * initial periods, it must be a dotted pair. \todo Ought to check, + * howerver, that there's only one form after the period. */ + result = + make_cons( car, + c_car( read_list( frame, + frame_pointer, + input, + url_fgetwc( input ) ) ) ); + } else { + result = + make_cons( car, + read_list( frame, frame_pointer, input, c ) ); + } } else { debug_print( L"End of list detected\n", DEBUG_IO ); } @@ -295,6 +323,37 @@ struct cons_pointer read_list( struct stack_frame *frame, return result; } + +struct cons_pointer read_map( struct stack_frame *frame, + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ) { + struct cons_pointer result = make_empty_map( NIL); + wint_t c = initial; + + while ( c != L'}' ) { + struct cons_pointer key = + read_continuation( frame, frame_pointer, input, c ); + + /* skip whitespace */ + for (c = url_fgetwc( input ); + iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input )); + + struct cons_pointer value = + read_continuation( frame, frame_pointer, input, c ); + + /* skip commaa and whitespace at this point. */ + for (c = url_fgetwc( input ); + c == L',' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input )); + + result = merge_into_map( result, make_cons( make_cons( key, value), NIL)); + } + + return result; +} + + /** * Read a string. This means either a string delimited by double quotes * (is_quoted == true), in which case it may contain whitespace but may diff --git a/src/memory/map.c b/src/memory/map.c index 7224a12..cbad3df 100644 --- a/src/memory/map.c +++ b/src/memory/map.c @@ -15,6 +15,7 @@ #include "dump.h" #include "fopen.h" #include "intern.h" +#include "io.h" #include "lookup3.h" #include "map.h" #include "print.h" @@ -61,10 +62,10 @@ struct map_payload *get_map_payload( struct cons_pointer pointer ) { if (vectorpointp(pointer) && mapp( vso ) ) { result = ( struct map_payload * ) &( vso->payload ); - debug_printf( DEBUG_STACK, + debug_printf( DEBUG_BIND, L"get_map_payload: all good, returning %p\n", result ); } else { - debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_STACK ); + debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_BIND ); } return result; @@ -79,7 +80,7 @@ struct map_payload *get_map_payload( struct cons_pointer pointer ) { * @return the new map, or NULL if memory is exhausted. */ struct cons_pointer make_empty_map( struct cons_pointer hash_function ) { - debug_print( L"Entering make_empty_map\n", DEBUG_ALLOC ); + debug_print( L"Entering make_empty_map\n", DEBUG_BIND ); struct cons_pointer result = make_vso( MAPTAG, sizeof( struct map_payload ) ); @@ -94,6 +95,7 @@ struct cons_pointer make_empty_map( struct cons_pointer hash_function ) { } } + debug_print( L"Leaving make_empty_map\n", DEBUG_BIND ); return result; } @@ -143,6 +145,7 @@ struct cons_pointer bind_in_map( struct cons_pointer parent, struct cons_pointer keys( struct cons_pointer store) { + debug_print( L"Entering keys\n", DEBUG_BIND ); struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( store ); @@ -158,18 +161,27 @@ struct cons_pointer keys( struct cons_pointer store) { pointer2cell( store ).payload.vectorp.address; if ( mapp( vso ) ) { - struct map_payload * payload = get_map_payload( result ); + struct map_payload * payload = get_map_payload( store ); for (int bucket = 0; bucket < BUCKETSINMAP; bucket++) { for (struct cons_pointer c = payload->buckets[bucket]; !nilp(c); c = c_cdr(c)) { + debug_print( L"keys: c is ", DEBUG_BIND); + debug_print_object( c, DEBUG_BIND); + result = make_cons( c_car( c_car( c)), result); + debug_print( L"; result is ", DEBUG_BIND); + debug_print_object( result, DEBUG_BIND); + debug_println( DEBUG_BIND); } } } } break; } + debug_print( L"keys returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND); return result; } @@ -187,6 +199,7 @@ struct cons_pointer keys( struct cons_pointer store) { */ struct cons_pointer merge_into_map( struct cons_pointer parent, struct cons_pointer to_merge) { + debug_print( L"Entering merge_into_map\n", DEBUG_BIND ); struct cons_pointer result = make_duplicate_map(parent); if (!nilp(result)) { @@ -202,24 +215,31 @@ struct cons_pointer merge_into_map( struct cons_pointer parent, } } + debug_print( L"Leaving merge_into_map\n", DEBUG_BIND ); + return result; } -struct cons_pointer assoc_in_map( struct cons_pointer map, - struct cons_pointer key) { +struct cons_pointer assoc_in_map( struct cons_pointer key, + struct cons_pointer map) { + debug_print( L"Entering assoc_in_map\n", DEBUG_BIND ); struct cons_pointer result = NIL; struct map_payload *payload = get_map_payload( map ); if (payload != NULL) { int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; - result = c_assoc(key, payload->buckets[bucket]); } + debug_print( L"assoc_in_map returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND); + debug_println( DEBUG_BIND); + return result; } + /** * Function: create a map initialised with key/value pairs from my * first argument. @@ -251,7 +271,7 @@ void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) { struct map_payload *payload = get_map_payload( map_pointer ); if ( payload != NULL ) { - url_fputws( L"Immutable map; hash function:", output ); + url_fputws( L"Immutable map; hash function: ", output ); if (nilp(payload->hash_function)) { url_fputws( L"default", output); diff --git a/src/memory/map.h b/src/memory/map.h index 76a7193..c9b5cfc 100644 --- a/src/memory/map.h +++ b/src/memory/map.h @@ -73,6 +73,8 @@ uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key); struct map_payload *get_map_payload( struct cons_pointer pointer ); +struct cons_pointer make_empty_map( struct cons_pointer hash_function ); + struct cons_pointer bind_in_map( struct cons_pointer parent, struct cons_pointer key, struct cons_pointer value); @@ -82,8 +84,8 @@ struct cons_pointer keys( struct cons_pointer store); struct cons_pointer merge_into_map( struct cons_pointer parent, struct cons_pointer to_merge); -struct cons_pointer assoc_in_map( struct cons_pointer map, - struct cons_pointer key); +struct cons_pointer assoc_in_map( struct cons_pointer key, + struct cons_pointer map); struct cons_pointer lisp_make_map( struct stack_frame *frame, struct cons_pointer frame_pointer, diff --git a/src/ops/intern.c b/src/ops/intern.c index 02deb23..cf86e6b 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -94,9 +94,7 @@ struct cons_pointer c_assoc( struct cons_pointer key, debug_print( L"c_assoc; key is `", DEBUG_BIND); debug_print_object( key, DEBUG_BIND); - debug_print( L"`; store is \n", DEBUG_BIND); - debug_dump_object( store, DEBUG_BIND); - debug_println(DEBUG_BIND); + debug_print( L"`\n", DEBUG_BIND); if (consp(store)) { for ( struct cons_pointer next = store; diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 1624261..cb58cf9 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1288,6 +1288,7 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame, } dump_object( output, frame->arg[0] ); + url_fputws( L"\n", output ); if ( writep( out_stream ) ) { dec_ref( out_stream ); diff --git a/src/utils.c b/src/utils.c index ea3919f..9919dbe 100644 --- a/src/utils.c +++ b/src/utils.c @@ -12,7 +12,7 @@ #include -int index_of( char c, char *s ) { +int index_of( char c, const char *s ) { int i; for ( i = 0; s[i] != c && s[i] != 0; i++ ); diff --git a/src/utils.h b/src/utils.h index e56fd6e..456e4d0 100644 --- a/src/utils.h +++ b/src/utils.h @@ -10,6 +10,8 @@ #ifndef __psse_utils_h #define __psse_utils_h -int index_of( char c, char *s ); +int index_of( char c, const char *s ); + char *trim( char *s ); + #endif diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh index 7e80c48..e977461 100755 --- a/unit-tests/eval-quote-symbol.sh +++ b/unit-tests/eval-quote-symbol.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='' +expected='' actual=`echo "(eval 'cond)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/slurp.sh b/unit-tests/slurp.sh index b389143..0a9bc7c 100755 --- a/unit-tests/slurp.sh +++ b/unit-tests/slurp.sh @@ -1,6 +1,6 @@ #!/bin/bash -tmp=hi$$ +tmp=hi.$$ echo "Hello, there." > ${tmp} expected='"Hello, there.' actual=`echo "(slurp (open \"${tmp}\"))" | target/psse | tail -2 | head -1` From e35bc643a7246d60c8dfe507d81e633127fb993a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 Feb 2019 10:28:20 +0000 Subject: [PATCH 064/101] Ignore unit test detritus --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index ec1281e..1968658 100644 --- a/.gitignore +++ b/.gitignore @@ -36,3 +36,5 @@ utils_src/readprintwc/out *.bak src/io/fopen + +hi\.* From 30438297452cb29641e60a8b46244b66152844de Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 Feb 2019 13:40:34 +0000 Subject: [PATCH 065/101] #17: Fixed --- src/io/io.c | 4 ++-- where-does-it-break.sh | 29 ----------------------------- 2 files changed, 2 insertions(+), 31 deletions(-) delete mode 100755 where-does-it-break.sh diff --git a/src/io/io.c b/src/io/io.c index 7e6a3c0..e9990e9 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -378,13 +378,13 @@ void collect_meta( struct cons_pointer stream, char *url ) { meta = add_meta_integer( meta, L"size", ( intmax_t ) statbuf.st_size ); - +/* meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); +*/ } break; case CFTYPE_CURL: curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L ); - curl_easy_setopt( s->handle.curl, CURLOPT_HEADER, 1L ); curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION, write_meta_callback ); curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream ); diff --git a/where-does-it-break.sh b/where-does-it-break.sh deleted file mode 100755 index 4d70041..0000000 --- a/where-does-it-break.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/bash - -# Not really a unit test, but a check to see where bignum addition breaks - -broken=0 -i=11529215046068469750 -# we've already proven we can successfullu get up to here -increment=1 - -while [ $broken -eq "0" ] -do - expr="(+ $i $increment)" - # Use sbcl as our reference implementation... - expected=`echo "$expr" | sbcl --noinform | grep -v '*'` - actual=`echo "$expr" | target/psse | tail -1 | sed 's/\,//g'` - - echo -n "adding $increment to $i: " - - if [ "${expected}" = "${actual}" ] - then - echo "OK" - else - echo "Fail: expected '${expected}', got '${actual}'" - broken=1 - exit 1 - fi - - i=$expected -done From 897d5d267027fef2b7c30b91e15e612b2dd66c55 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 Feb 2019 13:57:37 +0000 Subject: [PATCH 066/101] Map in function position --- src/ops/lispops.c | 119 +++++++++++++++++++++++++++------------------- 1 file changed, 69 insertions(+), 50 deletions(-) diff --git a/src/ops/lispops.c b/src/ops/lispops.c index cb58cf9..4e2ddbf 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -33,9 +33,11 @@ #include "intern.h" #include "io.h" #include "lispops.h" +#include "map.h" #include "print.h" #include "read.h" #include "stack.h" +#include "vectorspace.h" /* * also to create in this section: @@ -288,6 +290,7 @@ struct cons_pointer /* just pass exceptions straight back */ result = fn_pointer; break; + case FUNCTIONTV: { struct cons_pointer exep = NIL; @@ -326,64 +329,80 @@ struct cons_pointer if ( exceptionp( next_pointer ) ) { result = next_pointer; } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - if ( !exceptionp( result ) ) { - dec_ref( next_pointer ); - } + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); } } + } + break; + + case VECTORPOINTTV: + switch ( pointer_to_vso(fn_pointer)->header.tag.value) { + case MAPTV: + /* \todo: if arg[0] is a CONS, treat it as a path */ + result = c_assoc( eval_form(frame, + frame_pointer, + c_car( c_cdr( frame->arg[0])), + env), + fn_pointer); break; + } + break; + case NLAMBDATV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - dec_ref( next_pointer ); - } + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); } - break; + } + break; + case SPECIALTV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); - debug_print( L"Special form returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - dec_ref( next_pointer ); - } + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); + debug_print( L"Special form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + dec_ref( next_pointer ); } - break; + } + break; + default: - { - 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 ); - result = throw_exception( message, frame_pointer ); - } + { + 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 ); + result = throw_exception( message, frame_pointer ); + } } } From b35eb8f5c75791244c29152c1049b1341b7d4e24 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 Feb 2019 14:19:49 +0000 Subject: [PATCH 067/101] Unit tests for maps --- unit-tests/map.sh | 89 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100755 unit-tests/map.sh diff --git a/unit-tests/map.sh b/unit-tests/map.sh new file mode 100755 index 0000000..f40c321 --- /dev/null +++ b/unit-tests/map.sh @@ -0,0 +1,89 @@ +#!/bin/bash + +##################################################################### +# Create an empty map using map notation +expected='{}' +actual=`echo "$expected" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Create an empty map using make-map +expected='{}' +actual=`echo "(make-map)" | target/psse | tail -1` + +echo -n "Empty map using (make-map): " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Create a map using map notation: order of keys in output is not +# significant at this stage, but in the long term should be sorted +# alphanumerically +expected='{:two 2, :one 1, :three 3}' +actual=`echo "{:one 1 :two 2 :three 3}" | target/psse | tail -1` + +echo -n "Map using map notation: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Create a map using make-map: order of keys in output is not +# significant at this stage, but in the long term should be sorted +# alphanumerically +expected='{:two 2, :one 1, :three 3}' +actual=`echo "(make-map '((:one . 1)(:two . 2)(:three . 3)))" | target/psse | tail -1` + +echo -n "Map using (make-map): " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Keyword in function position +expected='2' +actual=`echo "(:two {:one 1 :two 2 :three 3})" | target/psse | tail -1` + +echo -n "Keyword in function position: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# Map in function position +expected='2' +actual=`echo "({:one 1 :two 2 :three 3} :two)" | target/psse | tail -1` + +echo -n "Map in function position: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From af814d8f03a4095ab549c53757eec2f9a593b713 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 Feb 2019 15:32:06 +0000 Subject: [PATCH 068/101] #time: Fixed Major (unexpected) problem was collision between the name of my header file and that of the system header file! --- src/init.c | 2 +- src/io/io.c | 3 +-- src/io/print.c | 29 +++++++++++++++++++++++++++-- src/time/{time.c => psse_time.c} | 19 ++++++++++++++----- src/time/{time.h => psse_time.h} | 2 +- 5 files changed, 44 insertions(+), 11 deletions(-) rename src/time/{time.c => psse_time.c} (88%) rename src/time/{time.h => psse_time.h} (96%) diff --git a/src/init.c b/src/init.c index 275cc40..538ede3 100644 --- a/src/init.c +++ b/src/init.c @@ -31,7 +31,7 @@ #include "peano.h" #include "print.h" #include "repl.h" -#include "time.h" +#include "psse_time.h" // extern char *optarg; /* defined in unistd.h */ diff --git a/src/io/io.c b/src/io/io.c index e9990e9..5065044 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -378,9 +378,8 @@ void collect_meta( struct cons_pointer stream, char *url ) { meta = add_meta_integer( meta, L"size", ( intmax_t ) statbuf.st_size ); -/* + meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); -*/ } break; case CFTYPE_CURL: diff --git a/src/io/print.c b/src/io/print.c index 343160e..dd92606 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -24,7 +24,7 @@ #include "map.h" #include "stack.h" #include "print.h" -#include "time.h" +#include "psse_time.h" #include "vectorspace.h" /** @@ -140,6 +140,27 @@ void print_vso( URL_FILE * output, struct cons_pointer pointer) { } } +/** + * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc + */ +void print_128bit( URL_FILE * output, __int128_t n ) { + if ( n == 0 ) { + fwprintf( stderr, L"0" ); + } else { + char str[40] = { 0 }; // log10(1 << 128) + '\0' + char *s = str + sizeof( str ) - 1; // start at the end + while ( n != 0 ) { + if ( s == str ) + return; // never happens + + *--s = "0123456789"[n % 10]; // save last digit + n /= 10; // drop it + } + url_fwprintf( output, L"%s", s ); + } +} + + /** * Print the cons-space object indicated by `pointer` to the stream indicated * by `output`. @@ -257,7 +278,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { url_fputwc( L'>', output); break; case TIMETV: - print_string(output, time_to_string( pointer)); + url_fwprintf( output, L"', output); break; case TRUETV: url_fwprintf( output, L"t" ); diff --git a/src/time/time.c b/src/time/psse_time.c similarity index 88% rename from src/time/time.c rename to src/time/psse_time.c index 146f296..76f52a9 100644 --- a/src/time/time.c +++ b/src/time/psse_time.c @@ -1,5 +1,5 @@ /* - * time.h + * psse_time.c * * Bare bones of PSSE time. See issue #16. * @@ -8,6 +8,7 @@ */ #include +#include #include /* * wide characters @@ -18,7 +19,7 @@ #include "conspage.h" #include "consspaceobject.h" #include "integer.h" -#include "time.h" +#include "psse_time.h" #define _GNU_SOURCE #define seconds_per_year 31557600L @@ -90,9 +91,17 @@ struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer fr * This is temporary, for bootstrapping. */ struct cons_pointer time_to_string( struct cons_pointer pointer) { + struct cons_pointer result = NIL; long int t = lisp_time_to_unix_time(pointer); - return c_string_to_lisp_string( t == 0 ? - L"Not yet implemented: cannot print times outside UNIX time\n" : - ctime(&t)); + if ( t != 0) { + char * bytes = ctime(&t); + int l = strlen(bytes) + 1; + wchar_t buffer[ l]; + + mbstowcs( buffer, bytes, l); + result = c_string_to_lisp_string( buffer); + } + + return result; } diff --git a/src/time/time.h b/src/time/psse_time.h similarity index 96% rename from src/time/time.h rename to src/time/psse_time.h index 661decf..af70966 100644 --- a/src/time/time.h +++ b/src/time/psse_time.h @@ -1,5 +1,5 @@ /* - * time.h + * psse_time.h * * Bare bones of PSSE time. See issue #16. * From 27411689c9a04c96af5bd95622dac275922ae9b2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 Feb 2019 15:42:01 +0000 Subject: [PATCH 069/101] Removed the `print_use_colours` feature. More nuisance than help at this stage; removed. --- src/init.c | 5 +---- src/io/print.c | 47 +++++------------------------------------------ src/io/print.h | 1 - 3 files changed, 6 insertions(+), 47 deletions(-) diff --git a/src/init.c b/src/init.c index 538ede3..6074ba5 100644 --- a/src/init.c +++ b/src/init.c @@ -99,11 +99,8 @@ int main( int argc, char *argv[] ) { exit( 1 ); } - while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { + while ( ( option = getopt( argc, argv, "pdv:" ) ) != -1 ) { switch ( option ) { - case 'c': - print_use_colours = true; - break; case 'd': dump_at_end = true; break; diff --git a/src/io/print.c b/src/io/print.c index dd92606..c886981 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -27,12 +27,6 @@ #include "psse_time.h" #include "vectorspace.h" -/** - * Whether or not we colorise output. - * \todo this should be a Lisp symbol binding, not a C variable. - */ -int print_use_colours = 0; - /** * print all the characters in the symbol or string indicated by `pointer` * onto this `output`; if `pointer` does not indicate a string or symbol, @@ -89,18 +83,9 @@ print_list_contents( URL_FILE * output, struct cons_pointer pointer, } void print_list( URL_FILE * output, struct cons_pointer pointer ) { - if ( print_use_colours ) { - url_fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); - } else { - url_fputws( L"(", output ); - }; - + url_fputws( L"(", output ); print_list_contents( output, pointer, false ); - if ( print_use_colours ) { - url_fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); - } else { - url_fputws( L")", output ); - } + url_fputws( L")", output ); } @@ -178,8 +163,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_list( output, pointer ); break; case EXCEPTIONTV: - url_fwprintf( output, L"\n%sException: ", - print_use_colours ? "\x1B[31m" : "" ); + url_fwuts( L"\nException: ", output ); dump_stack_trace( output, pointer ); break; case FUNCTIONTV: @@ -190,17 +174,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); inc_ref( s ); - if ( print_use_colours ) { - url_fputws( L"\x1B[34m", output ); - } print_string_contents( output, s ); dec_ref( s ); } break; case KEYTV: - if ( print_use_colours ) { - url_fputws( L"\x1B[1;33m", output ); - } url_fputws( L":", output ); print_string_contents( output, pointer ); break; @@ -254,22 +232,13 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { buffer[i] = '\0'; } } - if ( print_use_colours ) { - url_fputws( L"\x1B[34m", output ); - } url_fwprintf( output, L"%s", buffer ); free( buffer ); break; case STRINGTV: - if ( print_use_colours ) { - url_fputws( L"\x1B[36m", output ); - } print_string( output, pointer ); break; case SYMBOLTV: - if ( print_use_colours ) { - url_fputws( L"\x1B[1;33m", output ); - } print_string_contents( output, pointer ); break; case SPECIALTV: @@ -297,17 +266,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; default: fwprintf( stderr, - L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", - print_use_colours ? "\x1B[31m" : "", - cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], - cell.tag.bytes[2], cell.tag.bytes[3] ); + L"Error: Unrecognised tag value %d (%4.4s)\n", + cell.tag.value, &cell.tag.bytes[0] ); break; } - if ( print_use_colours ) { - url_fputws( L"\x1B[39m", output ); - } - return pointer; } diff --git a/src/io/print.h b/src/io/print.h index f59f090..006ef80 100644 --- a/src/io/print.h +++ b/src/io/print.h @@ -16,6 +16,5 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ); void println( URL_FILE * output ); -extern int print_use_colours; #endif From d5dbc48849d28d55c1517bde890aa8c450ce73af Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 Feb 2019 15:42:01 +0000 Subject: [PATCH 070/101] Removed the `print_use_colours` feature. More nuisance than help at this stage; removed. --- src/init.c | 5 +---- src/io/print.c | 47 +++++------------------------------------------ src/io/print.h | 1 - 3 files changed, 6 insertions(+), 47 deletions(-) diff --git a/src/init.c b/src/init.c index 538ede3..6074ba5 100644 --- a/src/init.c +++ b/src/init.c @@ -99,11 +99,8 @@ int main( int argc, char *argv[] ) { exit( 1 ); } - while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { + while ( ( option = getopt( argc, argv, "pdv:" ) ) != -1 ) { switch ( option ) { - case 'c': - print_use_colours = true; - break; case 'd': dump_at_end = true; break; diff --git a/src/io/print.c b/src/io/print.c index dd92606..f0db8cd 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -27,12 +27,6 @@ #include "psse_time.h" #include "vectorspace.h" -/** - * Whether or not we colorise output. - * \todo this should be a Lisp symbol binding, not a C variable. - */ -int print_use_colours = 0; - /** * print all the characters in the symbol or string indicated by `pointer` * onto this `output`; if `pointer` does not indicate a string or symbol, @@ -89,18 +83,9 @@ print_list_contents( URL_FILE * output, struct cons_pointer pointer, } void print_list( URL_FILE * output, struct cons_pointer pointer ) { - if ( print_use_colours ) { - url_fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); - } else { - url_fputws( L"(", output ); - }; - + url_fputws( L"(", output ); print_list_contents( output, pointer, false ); - if ( print_use_colours ) { - url_fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); - } else { - url_fputws( L")", output ); - } + url_fputws( L")", output ); } @@ -178,8 +163,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_list( output, pointer ); break; case EXCEPTIONTV: - url_fwprintf( output, L"\n%sException: ", - print_use_colours ? "\x1B[31m" : "" ); + url_fputws( L"\nException: ", output ); dump_stack_trace( output, pointer ); break; case FUNCTIONTV: @@ -190,17 +174,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); inc_ref( s ); - if ( print_use_colours ) { - url_fputws( L"\x1B[34m", output ); - } print_string_contents( output, s ); dec_ref( s ); } break; case KEYTV: - if ( print_use_colours ) { - url_fputws( L"\x1B[1;33m", output ); - } url_fputws( L":", output ); print_string_contents( output, pointer ); break; @@ -254,22 +232,13 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { buffer[i] = '\0'; } } - if ( print_use_colours ) { - url_fputws( L"\x1B[34m", output ); - } url_fwprintf( output, L"%s", buffer ); free( buffer ); break; case STRINGTV: - if ( print_use_colours ) { - url_fputws( L"\x1B[36m", output ); - } print_string( output, pointer ); break; case SYMBOLTV: - if ( print_use_colours ) { - url_fputws( L"\x1B[1;33m", output ); - } print_string_contents( output, pointer ); break; case SPECIALTV: @@ -297,17 +266,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; default: fwprintf( stderr, - L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", - print_use_colours ? "\x1B[31m" : "", - cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], - cell.tag.bytes[2], cell.tag.bytes[3] ); + L"Error: Unrecognised tag value %d (%4.4s)\n", + cell.tag.value, &cell.tag.bytes[0] ); break; } - if ( print_use_colours ) { - url_fputws( L"\x1B[39m", output ); - } - return pointer; } diff --git a/src/io/print.h b/src/io/print.h index f59f090..006ef80 100644 --- a/src/io/print.h +++ b/src/io/print.h @@ -16,6 +16,5 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ); void println( URL_FILE * output ); -extern int print_use_colours; #endif From 71354d0f866722b8baeeb05f1fedac5809558ce2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 15 Feb 2019 14:19:41 +0000 Subject: [PATCH 071/101] Woohoo! Actual goddamned progress! Multiply might be working! Print definitely isn't! --- src/arith/integer.c | 111 +++++++++++++++++++++++++------------------- src/io/print.c | 2 +- 2 files changed, 64 insertions(+), 49 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 48992ca..db6f71c 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -216,6 +216,27 @@ struct cons_pointer base_partial( int depth ) { return result; } +/** + * destructively modify this `partial` by appending this `digit`. + */ +struct cons_pointer append_digit( struct cons_pointer partial, struct cons_pointer digit) { + struct cons_pointer c = partial; + struct cons_pointer result = partial; + + if (nilp( partial)) { + result = digit; + } else { + while ( !nilp( pointer2cell(c).payload.integer.more)) { + c = pointer2cell(c).payload.integer.more; + } + + (&pointer2cell(c))->payload.integer.more = digit; + } + return result; +} + + + /** * Return a pointer to an integer representing the product of the integers * pointed to by `a` and `b`. If either isn't an integer, will return nil. @@ -225,11 +246,11 @@ struct cons_pointer base_partial( int depth ) { * @param b an integer. */ struct cons_pointer multiply_integers( struct cons_pointer a, - struct cons_pointer b ) { - struct cons_pointer result = NIL; + struct cons_pointer b ) { + struct cons_pointer result = make_integer( 0, NIL); bool neg = is_negative( a ) != is_negative( b ); bool is_first_b = true; - int oom = -1; + int i = 0; debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); debug_print_object( a, DEBUG_ARITH ); @@ -238,60 +259,54 @@ struct cons_pointer multiply_integers( struct cons_pointer a, debug_println( DEBUG_ARITH ); if ( integerp( a ) && integerp( b ) ) { - while ( !nilp( b ) ) { - bool is_first_d = true; - struct cons_pointer d = a; - struct cons_pointer partial = base_partial( ++oom ); + /* for each digit in a, starting with the least significant (ai) */ + + for ( struct cons_pointer ai = a; !nilp( ai ); + ai = pointer2cell(ai).payload.integer.more) { + /* set carry to 0 */ __int128_t carry = 0; - while ( !nilp( d ) || carry != 0 ) { - partial = make_integer( 0, partial ); - struct cons_pointer new = NIL; - __int128_t dv = cell_value( d, '+', is_first_d ); - __int128_t bv = cell_value( b, '+', is_first_b ); + /* set least significant digits for result ri for this iteration + * to i zeros */ + struct cons_pointer ri = base_partial( i++ ); - __int128_t rv = ( dv * bv ) + carry; + /* for each digit in b, starting with the least significant (bj) */ + for ( struct cons_pointer bj = b; !nilp( bj ); + bj = pointer2cell(bj).payload.integer.more) { - debug_print( L"multiply_integers: d = ", DEBUG_ARITH ); - debug_print_object( d, DEBUG_ARITH ); - debug_print( L"; dv = ", DEBUG_ARITH ); - debug_print_128bit( dv, DEBUG_ARITH ); - debug_print( L"; bv = ", DEBUG_ARITH ); - debug_print_128bit( bv, DEBUG_ARITH ); - debug_print( L"; carry = ", DEBUG_ARITH ); - debug_print_128bit( carry, DEBUG_ARITH ); - debug_print( L"; rv = ", DEBUG_ARITH ); - debug_print_128bit( rv, DEBUG_ARITH ); - debug_print( L"; acc = ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"; partial = ", DEBUG_ARITH ); - debug_print_object( partial, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); + debug_printf( DEBUG_ARITH, + L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n", + pointer2cell(ai).payload.integer.value, + pointer2cell(bj).payload.integer.value, i); - new = make_integer_128( rv, base_partial( oom ) ); + /* multiply ai with bj and add the carry, resulting in a + * value xj which may exceed one digit */ + __int128_t xj = pointer2cell(ai).payload.integer.value * + pointer2cell(bj).payload.integer.value; + xj += carry; - if ( zerop( partial ) ) { - partial = new; - } else { - partial = add_integers( partial, new ); - } + /* if xj exceeds one digit, break it into the digit dj and + * the carry */ + carry = xj >> 60; + struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL); - d = integerp( d ) ? pointer2cell( d ).payload.integer. - more : NIL; - is_first_d = false; + /* destructively modify ri by appending dj */ + ri = append_digit( ri, dj); + } /* end for bj */ + + /* if carry is not equal to zero, append it as a final digit + * to ri */ + if (carry != 0) { + ri = append_digit( ri, make_integer( carry, NIL)); } - if ( nilp( result ) || zerop( result ) ) { - result = partial; - } else { - struct cons_pointer old = result; - result = add_integers( partial, result ); - //if (!eq(result, old)) dec_ref(old); - //if (!eq(result, partial)) dec_ref(partial); - } - b = pointer2cell( b ).payload.integer.more; - is_first_b = false; - } + /* add ri to result */ + result = add_integers( result, ri); + + debug_print( L"multiply_integers: result is ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + } /* end for ai */ } debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); diff --git a/src/io/print.c b/src/io/print.c index c886981..f0db8cd 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -163,7 +163,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_list( output, pointer ); break; case EXCEPTIONTV: - url_fwuts( L"\nException: ", output ); + url_fputws( L"\nException: ", output ); dump_stack_trace( output, pointer ); break; case FUNCTIONTV: From baf8d6669df641b8eec4bec75ad51eb94103e644 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 15 Feb 2019 18:48:30 +0000 Subject: [PATCH 072/101] OK, it is BETTER, but not FIXED. (expt 2 63) goes weirdly wrong - returns T. Internal representation is correct, so fault is in print. --- src/arith/integer.c | 70 ++++++++++++++++++++------------------------- 1 file changed, 31 insertions(+), 39 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index db6f71c..1b2667c 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -240,7 +240,10 @@ struct cons_pointer append_digit( struct cons_pointer partial, struct cons_point /** * Return a pointer to an integer representing the product of the integers * pointed to by `a` and `b`. If either isn't an integer, will return nil. - * \todo it is MUCH more complicated than this! + * + * Yes, this is one of Muhammad ibn Musa al-Khwarizmi's original recipes, so + * you'd think it would be easy; the reason that each step is documented is + * because I did not find it so. * * @param a an integer; * @param b an integer. @@ -339,38 +342,28 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, * when we get to the last digit from one integer cell, we have potentially * to be looking to the next. H'mmmm. */ -/* - * \todo this blows up when printing three-cell integers, but works fine - * for two-cell. What's happening is that when we cross the barrier we - * SHOULD print 2^120, but what we actually print is 2^117. H'mmm. - */ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, - int base ) { + int base ) { struct cons_pointer result = NIL; - struct cons_space_object integer = pointer2cell( int_pointer ); - __int128_t accumulator = llabs( integer.payload.integer.value ); - bool is_negative = integer.payload.integer.value < 0; - int digits = 0; - if ( accumulator == 0 && nilp( integer.payload.integer.more ) ) { - result = c_string_to_lisp_string( L"0" ); - } else { - while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { - if ( !nilp( integer.payload.integer.more ) ) { - integer = pointer2cell( integer.payload.integer.more ); - accumulator += integer.payload.integer.value; - debug_print - ( L"integer_to_string: crossing cell boundary, accumulator is: ", - DEBUG_IO ); - debug_print_128bit( accumulator, DEBUG_IO ); - debug_println( DEBUG_IO ); - } + if ( integerp( int_pointer ) ) { + struct cons_pointer next = pointer2cell( int_pointer ).payload.integer.more; + __int128_t accumulator = llabs( pointer2cell( int_pointer ).payload.integer.value ); + bool is_negative = pointer2cell( int_pointer ).payload.integer.value < 0; + int digits = 0; - do { + if ( accumulator == 0 && nilp( next ) ) { + result = c_string_to_lisp_string( L"0" ); + } else { + while ( accumulator > 0 || !nilp( next ) ) { + if ( accumulator < MAX_INTEGER && !nilp( next ) ) { + accumulator += (pointer2cell(next).payload.integer.value << 60); + next = pointer2cell(next).payload.integer.more; + } int offset = ( int ) ( accumulator % base ); debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", - offset, hex_digits[offset] ); + L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", + offset, hex_digits[offset] ); debug_print_128bit( accumulator, DEBUG_IO ); debug_print( L"; result is: ", DEBUG_IO ); debug_print_object( result, DEBUG_IO ); @@ -379,20 +372,19 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, result = integer_to_string_add_digit( offset, ++digits, result ); accumulator = accumulator / base; - } while ( accumulator > base ); - } + } - if ( stringp( result ) - && pointer2cell( result ).payload.string.character == L',' ) { - /* if the number of digits in the string is divisible by 3, there will be - * an unwanted comma on the front. */ - struct cons_pointer tmp = result; - result = pointer2cell( result ).payload.string.cdr; - //dec_ref( tmp ); - } + if ( stringp( result ) + && pointer2cell( result ).payload.string.character == L',' ) { + /* if the number of digits in the string is divisible by 3, there will be + * an unwanted comma on the front. */ + result = pointer2cell( result ).payload.string.cdr; + } - if ( is_negative ) { - result = make_string( L'-', result ); + + if ( is_negative ) { + result = make_string( L'-', result ); + } } } From e0f6e0a42a6333a4773e6afc4ec38a76bf130e17 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 19 Jul 2021 09:49:30 +0100 Subject: [PATCH 073/101] Added information on command line flags because picking this up again after five years is HARD! --- src/init.c | 40 ++++++++++++++++++++++++++++++++++++---- 1 file changed, 36 insertions(+), 4 deletions(-) diff --git a/src/init.c b/src/init.c index 6074ba5..dbfdd5d 100644 --- a/src/init.c +++ b/src/init.c @@ -84,6 +84,33 @@ void bind_value( wchar_t *name, struct cons_pointer value ) { dec_ref( n ); } +void print_banner() { + fwprintf(stdout, L"Post-Scarcity Software Environment version %s\n\n", VERSION); +} + +/** + * Print command line options to this `stream`. + * + * @stream the stream to print to. + */ +void print_options(FILE* stream) { + fwprintf(stream, L"Expected options are:\n"); + fwprintf(stream, L"\t-d\tDump memory to standard out at end of run (copious!);\n"); + fwprintf(stream, L"\t-h\tPrint this message and exit;\n"); + fwprintf(stream, L"\t-p\tShow a prompt (default is no prompt);\n"); + fwprintf(stream, L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n"); + fwprintf(stream, L"\t\tWhere bits are interpreted as follows:\n"); + fwprintf(stream, L"\t\t1\tALLOC;\n"); + fwprintf(stream, L"\t\t2\tARITH;\n"); + fwprintf(stream, L"\t\t4\tBIND;\n"); + fwprintf(stream, L"\t\t8\tBOOTSTRAP;\n"); + fwprintf(stream, L"\t\t16\tEVAL;\n"); + fwprintf(stream, L"\t\t32\tINPUT/OUTPUT;\n"); + fwprintf(stream, L"\t\t64\tLAMBDA;\n"); + fwprintf(stream, L"\t\t128\tREPL;\n"); + fwprintf(stream, L"\t\t256\tSTACK.\n"); +} + /** * main entry point; parse command line arguments, initialise the environment, * and enter the read-eval-print loop. @@ -99,11 +126,16 @@ int main( int argc, char *argv[] ) { exit( 1 ); } - while ( ( option = getopt( argc, argv, "pdv:" ) ) != -1 ) { + while ( ( option = getopt( argc, argv, "phdv:" ) ) != -1 ) { switch ( option ) { case 'd': dump_at_end = true; break; + case 'h': + print_banner(); + print_options(stdout); + exit( 0 ); + break; case 'p': show_prompt = true; break; @@ -112,14 +144,14 @@ int main( int argc, char *argv[] ) { break; default: fwprintf( stderr, L"Unexpected option %c\n", option ); + print_options(stderr); + exit( 1 ); break; } } if ( show_prompt ) { - fwprintf( stdout, - L"Post scarcity software environment version %s\n\n", - VERSION ); + print_banner(); } debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP ); From 8522e50f4281ce34ff23265157d54015ea60d5f1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 19 Jul 2021 09:53:08 +0100 Subject: [PATCH 074/101] Really shouldn't have the same VERSION in 'develop' as in 'master'! --- src/version.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/version.h b/src/version.h index 96fb98e..0e08c48 100644 --- a/src/version.h +++ b/src/version.h @@ -8,4 +8,4 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#define VERSION "0.0.4" +#define VERSION "0.0.5-SNAPSHOT" From 16f78f40779c48af73603a2d62ea85c63c8c1eb1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 19 Jul 2021 10:57:22 +0100 Subject: [PATCH 075/101] Print output for lambda and nlambda cells was misleading. --- src/io/print.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/io/print.c b/src/io/print.c index f0db8cd..c68c03e 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -183,8 +183,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_string_contents( output, pointer ); break; case LAMBDATV:{ + url_fputws( L"', output); } break; case NILTV: url_fwprintf( output, L"nil" ); break; case NLAMBDATV:{ + url_fputws( L"', output); } break; case RATIOTV: From d2101dbd473eff0984e540bd76b45cd4484803ff Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 24 Jul 2021 08:54:55 +0100 Subject: [PATCH 076/101] Started to try to get back into this; work on exceptions and loops. --- .vscode/settings.json | 7 ++++ src/memory/conspage.c | 2 +- src/memory/consspaceobject.c | 2 +- src/memory/consspaceobject.h | 25 +++++++++++--- src/memory/stack.c | 3 +- src/ops/exceptions.c | 62 +++++++++++++++++++++++++++++++++++ src/ops/lispops.c | 6 ++-- src/ops/lispops.h | 4 +++ utils_src/tagvalcalc/tvc | Bin 8544 -> 16848 bytes 9 files changed, 101 insertions(+), 10 deletions(-) create mode 100644 .vscode/settings.json create mode 100644 src/ops/exceptions.c diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..14fb483 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,7 @@ +{ + "files.associations": { + "future": "cpp", + "system_error": "cpp", + "functional": "c" + } +} \ No newline at end of file diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 2d0958d..53496d3 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -148,7 +148,7 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.cons.cdr ); break; case EXCEPTIONTV: - dec_ref( cell->payload.exception.message ); + dec_ref( cell->payload.exception.payload ); dec_ref( cell->payload.exception.frame ); break; case FUNCTIONTV: diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 344f4ae..98bb495 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -163,7 +163,7 @@ struct cons_pointer make_exception( struct cons_pointer message, inc_ref( message ); inc_ref( frame_pointer ); - cell->payload.exception.message = message; + cell->payload.exception.payload = message; cell->payload.exception.frame = frame_pointer; result = pointer; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 9197172..4b0500b 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -45,7 +45,8 @@ #define CONSTV 1397641027 /** - * An exception. + * An exception. TODO: we need a means of dealing with different classes of + * exception, and we don't have one yet. */ #define EXCEPTIONTAG "EXEP" @@ -108,6 +109,17 @@ */ #define LAMBDATV 1094995276 +/** + * A loop exit is a special kind of exception which has exactly the same + * payload as an exception. + */ +#define LOOPXTAG "LOOX" + +/** + * The string `LOOX`, considered as an `unsigned int`. + */ +#define LOOPXTV 1481592652 + /** * The special cons cell at address {0,0} whose car and cdr both point to * itself. @@ -286,10 +298,15 @@ #define keywordp(conspoint) (check_tag(conspoint,KEYTAG)) /** - * true if `conspoint` points to a special Lambda cell, else false + * true if `conspoint` points to a Lambda binding cell, else false */ #define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) +/** + * true if `conspoint` points to a loop exit exception, else false. + */ +#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTAG)) + /** * true if `conspoint` points to a special form cell, else false */ @@ -414,8 +431,8 @@ struct cons_payload { * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. */ struct exception_payload { - /** The message: should be a Lisp string but in practice anything printable will do. */ - struct cons_pointer message; + /** The payload: usually a Lisp string but in practice anything printable will do. */ + struct cons_pointer payload; /** pointer to the (unfreed) stack frame in which the exception was thrown. */ struct cons_pointer frame; }; diff --git a/src/memory/stack.c b/src/memory/stack.c index 3f4a271..d6d3c36 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -267,7 +267,8 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { - print( output, pointer2cell( pointer ).payload.exception.message ); + // todo: if the payload isn't a message, we maybe shouldn't print it? + print( output, pointer2cell( pointer ).payload.exception.payload ); url_fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); diff --git a/src/ops/exceptions.c b/src/ops/exceptions.c new file mode 100644 index 0000000..48c031f --- /dev/null +++ b/src/ops/exceptions.c @@ -0,0 +1,62 @@ + /* + * exceptions.c + * + * This is really, really unfinished and doesn't yet work. One of the really key + * things about exceptions is that the stack frames between the throw and the + * catch should not be derefed, so eval/apply will need to be substantially + * re-written. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "debug.h" +#include "dump.h" +#include "equal.h" +#include "integer.h" +#include "intern.h" +#include "io.h" +#include "lispops.h" +#include "map.h" +#include "print.h" +#include "read.h" +#include "stack.h" +#include "vectorspace.h" + + +/** + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * function in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, + * or until the list is exhausted. If the list was exhausted, then the value of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of + * those is returned. + * + * This is experimental. It almost certainly WILL change. + */ +struct cons_pointer lisp_try(struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env) +{ + struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); + + if (loopexitp(result)) + { + // TODO: need to put the exception into the environment! + result = c_progn(frame, frame_pointer, frame->arg[1], env); + } + + return result; +} + + diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 4e2ddbf..8dd0109 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -107,7 +107,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame, list = c_cdr( list ); } - return result; + return c_reverse( result); } /** @@ -991,7 +991,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, result = eval_form( frame, frame_pointer, c_car( expressions ), env ); dec_ref( r ); - expressions = c_cdr( expressions ); + expressions = exceptionp(result) ? NIL : c_cdr( expressions ); } return result; @@ -1259,7 +1259,7 @@ struct cons_pointer lisp_source( struct stack_frame *frame, case SPECIALTV: result = c_assoc( source_key, cell.payload.special.meta ); break; - case LAMBDATV: + case LAMBDATV: result = make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( cell.payload.lambda.args, cell.payload.lambda.body ) ); diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 122635f..f359252 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -29,6 +29,10 @@ struct cons_pointer c_reverse( struct cons_pointer arg ); +struct cons_pointer +c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer expressions, struct cons_pointer env ); + /** * Useful building block; evaluate this single form in the context of this * parent stack frame and this environment. diff --git a/utils_src/tagvalcalc/tvc b/utils_src/tagvalcalc/tvc index a639364e1d9b231bea94f83e58fdd6378dcccd83..acd850a02231fc7f80d1516dc01c995fcc0d848b 100755 GIT binary patch literal 16848 zcmeHOeQZB$=-#PYs zFOI0H{kL}&``q(8ANSsK@4LP?@7`|*JKCHMhv4KAUlGVncyz>10?#(e0P%}vu^7JV z#DiiU@D&o%<$j%jR8Nd(3PEBjs2ylmi2~xS z^cK~VDa(uHdC?e>SAG|1H!474YP7?uj5SEH7~5{9161B1QMN-C?Z(M&oa~rRQ+Z4| zo){DSG*djS)C)39UimGA)$SnKS!pZjGsQA69k{MVK2Lf3$j;-HZiJO`IZU~{C%}%n zRyVxIH+S=XDsQfS=%)BHrSOXN@mSB6ruFeiLp+wu4mJ!nZ)w=lMq!kFQA0e+&%Zb`dh*u8l@@|vX&GS*FmD-r8DQn~*UW(j=D=S9+zTITdIW%S{=Wyf z*QyLWMtgM`TtNSXu{*YijFwJ@2Zn^IX0%ZFX*JycwAver#l=86mehJhA{39O!XOS0 zhSc6zG8B(J8wD0Uph;R&6QNjA?CNN5*{N>yH5GFkeVc{a-nm)bU|-ofAR;L>0XqVA1ndad5wIg*N8qzX;N$8C z|E&!Fqe>a6{L^|Nl$RznXJJwqK38>CIw)*@0pOWJ{V-5<70J50N^V*?^WhHV%x#zAIImp1tJQ#mSII$D;Yx3H9kh$>F+Rt) zqgZ4g=~9NbzkpdKcU@bgjBGyvOn&Nap^%S2aL!jA1>SKOY)$r4M?i>cq*Wt?d|nd*S(1Klj93VGKNo%^Ww;sV*AUEfE@ul0(J!K2-p#@BVb3s zj({BjI|BbV5y1CP^-aE}%(eyfk^5lxxytnzY|{k3Q}Ij}3WGqqfsO$k0E+v&aiHBm ze{iEvm;~BAQz%RWodnv9dre6A?h}*a+5N&X=y9xCG{5Q;$PmYO`U?1f4Y&}k^X03r zHIQwB|Jg?)&-J#FsV$Ez0}sX8uptlakSrZuY(M*BnXISqQ!5J5a_& z0XqVA1ndad5wIg*N5GDN9f8jh0Y2Zy=lN)RRXjVlh@H@82wu#|l&3?MD~RWFgR6+= zvwACu=ktTOU&6%lTXzd7G9fcD zM(6qP)iI`S`CZya@)^JT2_K+Ch>VX@#kk%Rq{n9ux%>wSXTARv^!7nqB?NCOWqXg4 zKX~&hd5$}5BPHKU@=u88c98r38R2u^R)>w$-+rR|h;|dT>fej!bD_I-?%d{G+trgz zYFY1A-zHyU!-hw*lHG7@W23LJX`K$=%OS{JFiLC71P0H+^7(Y58y8sc`ExT~A)YJi zr?NOM&HD3--E@b-{mE4wltlUObO%*8hUw`NWLh zFUpN)7t9X){G0V*_VODMJ?|1Lg{Lgevs=jqpW6y?qfkQh9L}3g=#*(oJl%wQ>HIX? zeTi_MhZ%nqG7dw1c%EpJ`0O~~VSOxj%;JAY>d%hnD}a})|6J{QRr;wBhp@tyRL;+D zrOxtM{dEp-hnU@8e;|GSJ>ep*$jt2V^D*Es3(V@@tIz_T#z0AF1O7vZ#)(Xw!& zCoD?0FjOs}hVdRo2JT=)Qfgm3)f0-V5iOO@sG;nj2&WPQ@u(J!_?jEHG?rJwyC5+& zlun0+)M!#m4~gD%C=pd7*+c?wlNdM^G&Pf|7V3K@6c586R7_Rd_6K$c)!?316|RAp zwIf1p{o0?2TK5ZeSI6F#K!>`wt?fXtQ|%12bOh0>ysr|@ zWM#ei){EcI*H-R%StS|?X(8}qz9my~&_owzN{Do6y(eQ8qgVY34EQ$RhfyP$l-eIk zM)0mo`(DtB#FA<@6NQ+RnuD>WOFCBHJ(&!-mN#@%6|UcKl<{6p*~>QOi#}$T!j~CJ zXrUgUT3V<5oP*0k(e!}uB~x0|*O$!t2GXg4Xj&UGKt0(QTnURs2nw{cH^4{`QoTQv z=@-7pP!fvJsg~9y&qULiSSo2^RFI{k@emqNZXm7+pNxhNvcA3)u$ak2!@{RU2Z6;Q z3)(5!mA+^{4buJycwyW`c z1aDV)oy_--t@_L}y#cn^Mz-gD)N2g@LSj9gEAfoq0RfI(w&(p8-zVpL<2Zj{Vmt2t zUjT+pWP9G1jnP7|8)U}B_Dtu2vC&@mNxM;}Tn_tSJLVUGF=AXkuOB^RZ`H@LjA;p# zPwGVx+do`H^bFe@DUThas-GNo)5P!q2z~J3`tbaV|8L^D8|}yNhY8YNi*qhlm*U#K Qy!}Vby2eV2frS*+?rA z9~=y-p^H%KV?r*$xs=jFjy<}xkWdUxa!C$4_>cq{8pzQUW97ZwS!=a!dvBQ!X6JkJ z%{7$gf-v9-@d1j3BIWtvGv+1p!q;qVwMZ-c zTST7c=qTlwIWgAS#T_4QZ4(M(Zeour>>;I{x@pt%EX=puiDVF3QgLFW)3n`Uz6r=z zv`dNNc2k%y0YS)jQ1$S!KcHRl?NtpPpG>E+GpPdF!hE*k8&Lg;sr$C=m|wDJ7c%*4 zszaD>N%0*}apIu0a3dgPDSsoApOTsU)oB;EuEzt#$2F%BhdI26cjda)QKTFh9vcos zuzoG;>aTBLU2)HCb4!`e%HnJ;F`bn&cHtlSd>Y;#9PbJb`If+~kEIk8<7iemrL%(KCc-N7atnp97#UfImS! zftvlOJ>!eO%rV+0#Cg*B$ckI`nJL{LQMez(wfwd}YPISxO{n6jhDpFDgn zgT~)w-i$GaJ&#@>jYxAYn9t~J(N5(CJ|DomG6{5o9YG=gcZQeOF@>p@Hm!hGKr5gX z&to^Ea#c!{82wehU#g)bXt`!5gljrNd=u9 z^YH^w=N{BCSHM_ajyPs*{a&NdsF<5p`SmKr5gX&Q``p8DnZWrl4zIr{h(%F|cE=?TwF~*=%&bhNud}fSjk(Eeb~;I90L|cx z+P(_pTSVgAewWOpW$I=sS+Y|&6Q3k)Uv4s!7cqXYXcNo5s=x2BxhvwG81ggCdoK3A zZ4mRD2Wq;moxnASPlhl*-UQ>`&w6L1{9geq9&9sk^1O4-NEUMr>EJ8i=e|QglD`E8 C{uSo{ From 70d176982b04709abd94a1b5e861e8c7b596a95b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 25 Jul 2021 17:02:28 +0100 Subject: [PATCH 077/101] Work on exception handling, especially around ratio arithmetic Much simplified but will break things! --- .gitignore | 2 + lisp/defun.lisp | 5 ++ src/arith/integer.c | 35 ++++++++ src/arith/integer.h | 18 ++-- src/arith/peano.c | 54 ++++++------ src/arith/peano.h | 9 +- src/arith/ratio.c | 145 ++++++++++++++++++--------------- src/arith/ratio.h | 25 ++---- src/io/read.c | 6 +- src/memory/consspaceobject.h | 4 +- src/memory/stack.c | 1 - src/ops/equal.c | 154 ++++++++++++++++++++--------------- src/ops/exceptions.c | 62 -------------- src/ops/lispops.c | 36 ++++++++ 14 files changed, 298 insertions(+), 258 deletions(-) delete mode 100644 src/ops/exceptions.c diff --git a/.gitignore b/.gitignore index 1968658..3bf3906 100644 --- a/.gitignore +++ b/.gitignore @@ -38,3 +38,5 @@ utils_src/readprintwc/out src/io/fopen hi\.* + +.vscode/ diff --git a/lisp/defun.lisp b/lisp/defun.lisp index cec893b..a6d80f5 100644 --- a/lisp/defun.lisp +++ b/lisp/defun.lisp @@ -9,6 +9,11 @@ (set (car form) (apply 'lambda (cdr form)))) (t nil)))) +(set! defun! + (nlambda + form + (eval (list 'set! (car form) (cons 'lambda (cdr form)))))) + (defun! square (x) (* x x)) (set! defsp! diff --git a/src/arith/integer.c b/src/arith/integer.c index 1b2667c..e02d30e 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -390,3 +390,38 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, return result; } + +/** + * true if a and be are both integers whose value is the same value. + */ +bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) { + bool result = false; + + if (integerp(a) && integerp(b)){ + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); + + result = cell_a->payload.integer.value == cell_b->payload.integer.value; + } + + return result; +} + +/** + * true if `a` is an integer, and `b` is a real number whose value is the + * value of that integer. + */ +bool equal_integer_real(struct cons_pointer a, struct cons_pointer b) { + bool result = false; + + if (integerp(a) && realp(b)) + { + long double bv = pointer2cell(b).payload.real.value; + + if (floor(bv) == bv) { + result = pointer2cell(a).payload.integer.value == (int64_t)bv; + } + } + + return result; +} \ No newline at end of file diff --git a/src/arith/integer.h b/src/arith/integer.h index 117a0bf..f0117f5 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -11,15 +11,19 @@ #ifndef __integer_h #define __integer_h -struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); +struct cons_pointer make_integer(int64_t value, struct cons_pointer more); -struct cons_pointer add_integers( struct cons_pointer a, - struct cons_pointer b ); +struct cons_pointer add_integers(struct cons_pointer a, + struct cons_pointer b); -struct cons_pointer multiply_integers( struct cons_pointer a, - struct cons_pointer b ); +struct cons_pointer multiply_integers(struct cons_pointer a, + struct cons_pointer b); -struct cons_pointer integer_to_string( struct cons_pointer int_pointer, - int base ); +struct cons_pointer integer_to_string(struct cons_pointer int_pointer, + int base); + +bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b); + +bool equal_integer_real(struct cons_pointer a, struct cons_pointer b); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index 8e4cb43..8fe63fb 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -86,8 +86,7 @@ bool is_negative( struct cons_pointer arg ) { return result; } -struct cons_pointer absolute( struct cons_pointer frame_pointer, - struct cons_pointer arg ) { +struct cons_pointer absolute( struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -99,9 +98,7 @@ struct cons_pointer absolute( struct cons_pointer frame_pointer, cell.payload.integer.more ); break; case RATIOTV: - result = make_ratio( frame_pointer, - absolute( frame_pointer, - cell.payload.ratio.dividend ), + result = make_ratio( absolute( cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -210,7 +207,7 @@ int64_t to_long_int( struct cons_pointer arg ) { struct cons_pointer lisp_absolute( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return absolute( frame_pointer, frame->arg[0] ); + return absolute( frame->arg[0] ); } /** @@ -251,7 +248,7 @@ struct cons_pointer add_2( struct stack_frame *frame, break; case RATIOTV: result = - add_integer_ratio( frame_pointer, arg1, arg2 ); + add_integer_ratio( arg1, arg2 ); break; case REALTV: result = @@ -272,10 +269,10 @@ struct cons_pointer add_2( struct stack_frame *frame, break; case INTEGERTV: result = - add_integer_ratio( frame_pointer, arg2, arg1 ); + add_integer_ratio( arg2, arg1 ); break; case RATIOTV: - result = add_ratio_ratio( frame_pointer, arg1, arg2 ); + result = add_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -384,7 +381,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; case RATIOTV: result = - multiply_integer_ratio( frame_pointer, arg1, + multiply_integer_ratio( arg1, arg2 ); break; case REALTV: @@ -409,12 +406,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; case INTEGERTV: result = - multiply_integer_ratio( frame_pointer, arg2, + multiply_integer_ratio( arg2, arg1 ); break; case RATIOTV: result = - multiply_ratio_ratio( frame_pointer, arg1, arg2 ); + multiply_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -496,8 +493,7 @@ struct cons_pointer lisp_multiply( struct * return a cons_pointer indicating a number which is the * 0 - the number indicated by `arg`. */ -struct cons_pointer negative( struct cons_pointer frame, - struct cons_pointer arg ) { +struct cons_pointer negative( struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -514,9 +510,7 @@ struct cons_pointer negative( struct cons_pointer frame, result = TRUE; break; case RATIOTV: - result = make_ratio( frame, - negative( frame, - cell.payload.ratio.dividend ), + result = make_ratio( negative( cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -571,7 +565,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame, break; case INTEGERTV:{ struct cons_pointer i = - negative( frame_pointer, arg2 ); + negative( arg2 ); inc_ref( i ); result = add_integers( arg1, i ); dec_ref( i ); @@ -579,11 +573,11 @@ struct cons_pointer subtract_2( struct stack_frame *frame, break; case RATIOTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, arg1, + make_ratio( arg1, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, tmp, arg2 ); + subtract_ratio_ratio( tmp, arg2 ); dec_ref( tmp ); } break; @@ -606,16 +600,16 @@ struct cons_pointer subtract_2( struct stack_frame *frame, break; case INTEGERTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, arg2, + make_ratio( arg2, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, arg1, tmp ); + subtract_ratio_ratio( arg1, tmp ); dec_ref( tmp ); } break; case RATIOTV: - result = subtract_ratio_ratio( frame_pointer, arg1, arg2 ); + result = subtract_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -687,11 +681,11 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer unsimplified = - make_ratio( frame_pointer, frame->arg[0], + make_ratio( frame->arg[0], frame->arg[1] ); /* OK, if result may be unsimplified, we should not inc_ref it * - but if not, we should dec_ref it. */ - result = simplify_ratio( frame_pointer, unsimplified ); + result = simplify_ratio( unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); } @@ -700,10 +694,10 @@ struct cons_pointer lisp_divide( struct case RATIOTV:{ struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer ratio = - make_ratio( frame_pointer, frame->arg[0], one ); + make_ratio( frame->arg[0], one ); inc_ref( ratio ); result = - divide_ratio_ratio( frame_pointer, ratio, + divide_ratio_ratio( ratio, frame->arg[1] ); dec_ref( ratio ); } @@ -729,10 +723,10 @@ struct cons_pointer lisp_divide( struct struct cons_pointer one = make_integer( 1, NIL ); inc_ref( one ); struct cons_pointer ratio = - make_ratio( frame_pointer, frame->arg[1], one ); + make_ratio( frame->arg[1], one ); inc_ref( ratio ); result = - divide_ratio_ratio( frame_pointer, frame->arg[0], + divide_ratio_ratio( frame->arg[0], ratio ); dec_ref( ratio ); dec_ref( one ); @@ -740,7 +734,7 @@ struct cons_pointer lisp_divide( struct break; case RATIOTV: result = - divide_ratio_ratio( frame_pointer, frame->arg[0], + divide_ratio_ratio( frame->arg[0], frame->arg[1] ); break; case REALTV: diff --git a/src/arith/peano.h b/src/arith/peano.h index 7ad7662..89bfc3d 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -19,13 +19,11 @@ bool zerop( struct cons_pointer arg ); -struct cons_pointer negative( struct cons_pointer frame, - struct cons_pointer arg ); +struct cons_pointer negative( struct cons_pointer arg ); bool is_negative( struct cons_pointer arg ); -struct cons_pointer absolute( struct cons_pointer frame_pointer, - struct cons_pointer arg ); +struct cons_pointer absolute( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg ); @@ -46,8 +44,7 @@ struct cons_pointer lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer negative( struct cons_pointer frame, - struct cons_pointer arg ); +struct cons_pointer negative( struct cons_pointer arg ); struct cons_pointer subtract_2( struct stack_frame *frame, struct cons_pointer frame_pointer, diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 65b09da..8976e38 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -43,52 +43,52 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { return m / greatest_common_divisor( m, n ) * n; } -/** - * return a cons_pointer indicating a number which is of the - * same value as the ratio indicated by `arg`, but which may - * be in a simplified representation. - * @exception If `arg` isn't a ratio, will return an exception. - */ -struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg ) { - struct cons_pointer result = arg; +struct cons_pointer simplify_ratio( struct cons_pointer pointer) { + struct cons_pointer result = pointer; + struct cons_space_object cell = pointer2cell(pointer); + struct cons_space_object dividend = pointer2cell(cell.payload.ratio.dividend); + struct cons_space_object divisor = pointer2cell(cell.payload.ratio.divisor); - if ( ratiop( arg ) ) { - int64_t ddrv = - pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). - payload.integer.value, drrv = - pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). - payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); + if (divisor.payload.integer.value == 1) + { + result = pointer2cell(pointer).payload.ratio.dividend; + } + else + { + if (ratiop(pointer)) + { + int64_t ddrv = dividend.payload.integer.value, + drrv = divisor.payload.integer.value, + gcd = greatest_common_divisor(ddrv, drrv); - if ( gcd > 1 ) { - if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd, NIL ); - } else { - result = - make_ratio( frame_pointer, make_integer( ddrv / gcd, NIL ), - make_integer( drrv / gcd, NIL ) ); + if (gcd > 1) + { + if (drrv / gcd == 1) + { + result = make_integer(ddrv / gcd, NIL); + } + else + { + result = + make_ratio(make_integer(ddrv / gcd, NIL), + make_integer(drrv / gcd, NIL)); + } } } - } else { - result = - throw_exception( make_cons( c_string_to_lisp_string - ( L"Shouldn't happen: bad arg to simplify_ratio" ), - arg ), frame_pointer ); } return result; + } - /** * return a cons_pointer indicating a number which is the sum of * the ratios indicated by `arg1` and `arg2`. * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer r, result; @@ -116,18 +116,17 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, m1, m2 ); if ( dr1v == dr2v ) { - r = make_ratio( frame_pointer, - make_integer( dd1v + dd2v, NIL ), + r = make_ratio( make_integer( dd1v + dd2v, NIL ), cell1.payload.ratio.divisor ); } else { struct cons_pointer dd1vm = make_integer( dd1v * m1, NIL ), dr1vm = make_integer( dr1v * m1, NIL ), dd2vm = make_integer( dd2v * m2, NIL ), dr2vm = make_integer( dr2v * m2, NIL ), - r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), - r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); + r1 = make_ratio( dd1vm, dr1vm ), + r2 = make_ratio( dd2vm, dr2vm ); - r = add_ratio_ratio( frame_pointer, r1, r2 ); + r = add_ratio_ratio( r1, r2 ); /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were * never incremented except when making r1 and r2, decrementing @@ -136,7 +135,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, dec_ref( r2 ); } - result = simplify_ratio( frame_pointer, r ); + result = simplify_ratio( r ); if ( !eq( r, result ) ) { dec_ref( r ); } @@ -146,7 +145,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, ( L"Shouldn't happen: bad arg to add_ratio_ratio" ), make_cons( arg1, make_cons( arg2, NIL ) ) ), - frame_pointer ); + NIL ); } debug_print( L" => ", DEBUG_ARITH ); @@ -163,16 +162,16 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, * `ratarg`. * @exception if either `intarg` or `ratarg` is not of the expected type. */ -struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer add_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { + // TODO: not longer works struct cons_pointer one = make_integer( 1, NIL ), - ratio = make_ratio( frame_pointer, intarg, one ); + ratio = make_ratio( intarg, one ); - result = add_ratio_ratio( frame_pointer, ratio, ratarg ); + result = add_ratio_ratio( ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); @@ -183,7 +182,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, make_cons( intarg, make_cons( ratarg, NIL ) ) ), - frame_pointer ); + NIL ); } return result; @@ -195,15 +194,14 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload. + // TODO: this now has to work if `arg1` is an integer + struct cons_pointer i = make_ratio( pointer2cell( arg2 ).payload. ratio.divisor, pointer2cell( arg2 ).payload. ratio.dividend ), result = - multiply_ratio_ratio( frame_pointer, arg1, i ); + multiply_ratio_ratio( arg1, i ); dec_ref( i ); @@ -216,9 +214,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { + // TODO: this now has to work if arg1 is an integer struct cons_pointer result; debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH ); @@ -241,9 +240,9 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str ddrv = dd1v * dd2v, drrv = dr1v * dr2v; struct cons_pointer unsimplified = - make_ratio( frame_pointer, make_integer( ddrv, NIL ), + make_ratio( make_integer( ddrv, NIL ), make_integer( drrv, NIL ) ); - result = simplify_ratio( frame_pointer, unsimplified ); + result = simplify_ratio( unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); @@ -252,7 +251,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str result = throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), - frame_pointer ); + NIL ); } return result; @@ -264,15 +263,15 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str * `ratarg`. * @exception if either `intarg` or `ratarg` is not of the expected type. */ -struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { + // TODO: no longer works; fix struct cons_pointer one = make_integer( 1, NIL ), - ratio = make_ratio( frame_pointer, intarg, one ); - result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); + ratio = make_ratio( intarg, one ); + result = multiply_ratio_ratio( ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); @@ -280,7 +279,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, result = throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), - frame_pointer ); + NIL ); } return result; @@ -293,11 +292,10 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = negative( frame_pointer, arg2 ), - result = add_ratio_ratio( frame_pointer, arg1, i ); + struct cons_pointer i = negative( arg2), + result = add_ratio_ratio( arg1, i ); dec_ref( i ); @@ -311,8 +309,7 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, * `frame_pointer`. * @exception if either `dividend` or `divisor` is not an integer. */ -struct cons_pointer make_ratio( struct cons_pointer frame_pointer, - struct cons_pointer dividend, +struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer divisor ) { struct cons_pointer result; if ( integerp( dividend ) && integerp( divisor ) ) { @@ -326,10 +323,30 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer, result = throw_exception( c_string_to_lisp_string ( L"Dividend and divisor of a ratio must be integers" ), - frame_pointer ); + NIL ); } debug_dump_object( result, DEBUG_ARITH ); - return result; } + +/** + * True if a and be are identical ratios, else false. + */ +bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b) +{ + bool result = false; + + if (ratiop(a) && ratiop(b)) + { + struct cons_space_object *cell_a = &pointer2cell(a); + struct cons_space_object *cell_b = &pointer2cell(b); + + result = equal_integer_integer(cell_a->payload.ratio.dividend, + cell_b->payload.ratio.dividend) && + equal_integer_integer(cell_a->payload.ratio.divisor, + cell_b->payload.ratio.divisor); + } + + return result; +} \ No newline at end of file diff --git a/src/arith/ratio.h b/src/arith/ratio.h index 5a3b0d6..d440530 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -11,36 +11,29 @@ #ifndef __ratio_h #define __ratio_h -struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg ); +struct cons_pointer simplify_ratio( struct cons_pointer arg ); -struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer add_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct - cons_pointer arg1, struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer make_ratio( struct cons_pointer frame_pointer, - struct cons_pointer dividend, +struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer divisor ); +bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b); #endif diff --git a/src/io/read.c b/src/io/read.c index 4f3ed0a..0f32815 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -250,7 +250,7 @@ struct cons_pointer read_number( struct stack_frame *frame, if ( seen_period ) { debug_print( L"read_number: converting result to real\n", DEBUG_IO ); - struct cons_pointer div = make_ratio( frame_pointer, result, + struct cons_pointer div = make_ratio( result, make_integer( powl ( to_long_double ( base ), @@ -263,14 +263,14 @@ struct cons_pointer read_number( struct stack_frame *frame, dec_ref( div ); } else if ( integerp( dividend ) ) { debug_print( L"read_number: converting result to ratio\n", DEBUG_IO ); - result = make_ratio( frame_pointer, dividend, result ); + result = make_ratio( dividend, result ); } if ( neg ) { debug_print( L"read_number: converting result to negative\n", DEBUG_IO ); - result = negative( frame_pointer, result ); + result = negative( result ); } debug_print( L"read_number returning\n", DEBUG_IO ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 4b0500b..f82b103 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -346,7 +346,7 @@ * true if `conspoint` points to some sort of a number cell, * else false */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) +#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)) /** * true if `conspoint` points to a sequence (list, string or, later, vector), @@ -614,7 +614,7 @@ struct cons_space_object { */ struct cons_payload cons; /** - * if tag == EXCEPTIONTAG + * if tag == EXCEPTIONTAG || tag == LOOPXTAG */ struct exception_payload exception; /** diff --git a/src/memory/stack.c b/src/memory/stack.c index d6d3c36..e26bd0e 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -267,7 +267,6 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { - // todo: if the payload isn't a message, we maybe shouldn't print it? print( output, pointer2cell( pointer ).payload.exception.payload ); url_fputws( L"\n", output ); dump_stack_trace( output, diff --git a/src/ops/equal.c b/src/ops/equal.c index c4d7f54..6a87de8 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -12,14 +12,17 @@ #include "conspage.h" #include "consspaceobject.h" +#include "integer.h" #include "peano.h" +#include "ratio.h" /** * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. */ -bool eq( struct cons_pointer a, struct cons_pointer b ) { - return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); +bool eq(struct cons_pointer a, struct cons_pointer b) +{ + return ((a.page == b.page) && (a.offset == b.offset)); } /** @@ -29,12 +32,12 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) { * @return true if the objects at these two cons pointers have the same tag, * else false. */ -bool same_type( struct cons_pointer a, struct cons_pointer b ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); +bool same_type(struct cons_pointer a, struct cons_pointer b) +{ + struct cons_space_object *cell_a = &pointer2cell(a); + struct cons_space_object *cell_b = &pointer2cell(b); return cell_a->tag.value == cell_b->tag.value; - } /** @@ -42,82 +45,99 @@ bool same_type( struct cons_pointer a, struct cons_pointer b ) { * @param string the string to test * @return true if it's the end of a string. */ -bool end_of_string( struct cons_pointer string ) { - return nilp( string ) || - pointer2cell( string ).payload.string.character == '\0'; +bool end_of_string(struct cons_pointer string) +{ + return nilp(string) || + pointer2cell(string).payload.string.character == '\0'; } /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal( struct cons_pointer a, struct cons_pointer b ) { - bool result = eq( a, b ); +bool equal(struct cons_pointer a, struct cons_pointer b) +{ + bool result = eq(a, b); - if ( !result && same_type( a, b ) ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); + if (!result && same_type(a, b)) + { + struct cons_space_object *cell_a = &pointer2cell(a); + struct cons_space_object *cell_b = &pointer2cell(b); - switch ( cell_a->tag.value ) { - case CONSTV: - case LAMBDATV: - case NLAMBDATV: - result = - equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) - && equal( cell_a->payload.cons.cdr, - cell_b->payload.cons.cdr ); - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - /* + switch (cell_a->tag.value) + { + case CONSTV: + case LAMBDATV: + case NLAMBDATV: + result = + equal(cell_a->payload.cons.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr, + cell_b->payload.cons.cdr); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + /* * slightly complex because a string may or may not have a '\0' * cell at the end, but I'll ignore that for now. I think in * practice only the empty string will. */ - result = - cell_a->payload.string.character == - cell_b->payload.string.character - && ( equal( cell_a->payload.string.cdr, - cell_b->payload.string.cdr ) - || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload.string. - cdr ) ) ); - break; - case INTEGERTV: - result = - ( cell_a->payload.integer.value == - cell_b->payload.integer.value ) && - equal( cell_a->payload.integer.more, - cell_b->payload.integer.more ); - break; - case REALTV: - { - double num_a = to_long_double( a ); - double num_b = to_long_double( b ); - double max = - fabs( num_a ) > - fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); + result = + cell_a->payload.string.character == + cell_b->payload.string.character && + (equal(cell_a->payload.string.cdr, + cell_b->payload.string.cdr) || + (end_of_string(cell_a->payload.string.cdr) && end_of_string(cell_b->payload.string.cdr))); + break; + case INTEGERTV: + result = + (cell_a->payload.integer.value == + cell_b->payload.integer.value) && + equal(cell_a->payload.integer.more, + cell_b->payload.integer.more); + break; + case RATIOTV: + result = equal_ratio_ratio(a, b); + break; + case REALTV: + { + double num_a = to_long_double(a); + double num_b = to_long_double(b); + double max = + fabs(num_a) > + fabs(num_b) + ? fabs(num_a) + : fabs(num_b); - /* - * not more different than one part in a million - close enough - */ - result = fabs( num_a - num_b ) < ( max / 1000000.0 ); - } - break; - default: - result = false; - break; + /* + * not more different than one part in a million - close enough + */ + result = fabs(num_a - num_b) < (max / 1000000.0); + } + break; + default: + result = false; + break; } - - /* - * there's only supposed ever to be one T and one NIL cell, so each - * should be caught by eq; equality of vector-space objects is a whole - * other ball game so we won't deal with it now (and indeed may never). - * I'm not certain what equality means for read and write streams, so - * I'll ignore them, too, for now. - */ } + else if (numberp(a) && numberp(b)) + { + if (integerp(a)) + { + result = equal_integer_real(a, b); + } + else if (integerp(b)) + { + result = equal_integer_real(b, a); + } + } + + /* + * there's only supposed ever to be one T and one NIL cell, so each + * should be caught by eq; equality of vector-space objects is a whole + * other ball game so we won't deal with it now (and indeed may never). + * I'm not certain what equality means for read and write streams, so + * I'll ignore them, too, for now. + */ return result; } diff --git a/src/ops/exceptions.c b/src/ops/exceptions.c deleted file mode 100644 index 48c031f..0000000 --- a/src/ops/exceptions.c +++ /dev/null @@ -1,62 +0,0 @@ - /* - * exceptions.c - * - * This is really, really unfinished and doesn't yet work. One of the really key - * things about exceptions is that the stack frames between the throw and the - * catch should not be derefed, so eval/apply will need to be substantially - * re-written. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include - -#include "consspaceobject.h" -#include "conspage.h" -#include "debug.h" -#include "dump.h" -#include "equal.h" -#include "integer.h" -#include "intern.h" -#include "io.h" -#include "lispops.h" -#include "map.h" -#include "print.h" -#include "read.h" -#include "stack.h" -#include "vectorspace.h" - - -/** - * OK, the idea here (and I know this is less than perfect) is that the basic `try` - * function in PSSE takes two arguments, the first, `body`, being a list of forms, - * and the second, `catch`, being a catch handler (which is also a list of forms). - * Forms from `body` are evaluated in turn until one returns an exception object, - * or until the list is exhausted. If the list was exhausted, then the value of - * evaluating the last form in `body` is returned. If an exception was encountered, - * then each of the forms in `catch` is evaluated and the value of the last of - * those is returned. - * - * This is experimental. It almost certainly WILL change. - */ -struct cons_pointer lisp_try(struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env) -{ - struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); - - if (loopexitp(result)) - { - // TODO: need to put the exception into the environment! - result = c_progn(frame, frame_pointer, frame->arg[1], env); - } - - return result; -} - - diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 8dd0109..c96b1be 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -110,6 +110,37 @@ struct cons_pointer eval_forms( struct stack_frame *frame, return c_reverse( result); } +/** + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * function in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, + * or until the list is exhausted. If the list was exhausted, then the value of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of + * those is returned. + * + * This is experimental. It almost certainly WILL change. + */ +struct cons_pointer lisp_try(struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env) { + struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); + + if (exceptionp(result)) + { + // TODO: need to put the exception into the environment! + result = c_progn(frame, frame_pointer, frame->arg[1], + make_cons( + make_cons(c_string_to_lisp_keyword(L"*exception*"), + result), + env)); + } + + return result; +} + + /** * Return the object list (root namespace). * @@ -251,6 +282,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, dec_ref( result ); result = eval_form( frame, frame_pointer, sexpr, new_env ); + + if (exceptionp(result)) + { + break; + } } dec_ref( new_env ); From 3f3b596ff0f2e2b35b1328110836717994cb531c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 3 Aug 2021 15:46:50 +0100 Subject: [PATCH 078/101] Added the beginnings of hashmap but does not yet compile. --- .vscode/settings.json | 7 ----- src/memory/conspage.h | 2 +- src/memory/consspaceobject.c | 42 ++++++++++++++++++++++--- src/memory/consspaceobject.h | 7 +++-- src/memory/hashmap.c | 61 ++++++++++++++++++++++++++++++++++++ src/memory/hashmap.h | 36 +++++++++++++++++++++ src/ops/equal.c | 25 +++++++++------ 7 files changed, 154 insertions(+), 26 deletions(-) delete mode 100644 .vscode/settings.json create mode 100644 src/memory/hashmap.c create mode 100644 src/memory/hashmap.h diff --git a/.vscode/settings.json b/.vscode/settings.json deleted file mode 100644 index 14fb483..0000000 --- a/.vscode/settings.json +++ /dev/null @@ -1,7 +0,0 @@ -{ - "files.associations": { - "future": "cpp", - "system_error": "cpp", - "functional": "c" - } -} \ No newline at end of file diff --git a/src/memory/conspage.h b/src/memory/conspage.h index f13a46b..9eab748 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -13,7 +13,7 @@ #ifndef __psse_conspage_h #define __psse_conspage_h -#include "consspaceobject.h" +#include "memory/consspaceobject.h" /** * the number of cons cells on a cons page. The maximum value this can diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 98bb495..080158d 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -101,16 +101,16 @@ struct cons_pointer c_car( struct cons_pointer arg ) { struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( arg ); + struct cons_space_object *cell = &pointer2cell( arg ); - switch (cell.tag.value) { + switch (cell->tag.value) { case CONSTV: - result = pointer2cell( arg ).payload.cons.cdr; + result = cell->payload.cons.cdr; break; case KEYTV: case STRINGTV: case SYMBOLTV: - result = pointer2cell( arg ).payload.string.cdr; + result = cell->payload.string.cdr; break; } @@ -226,6 +226,36 @@ struct cons_pointer make_nlambda( struct cons_pointer args, return pointer; } +/** + * Return a hash value for this string. + * + * What's important here is that two strings with the same characters in the + * same order should have the same hash value, even if one was created using + * `"foobar"` and the other by `(append "foo" "bar")`. I *think* this function + * has that property. I doubt that it's the most efficient hash function to + * have that property. + */ +uint32_t calculate_hash( wint_t c, struct cons_pointer ptr) { +struct cons_space_object *cell = &pointer2cell(ptr); + uint32_t result = 0; + + switch (cell->tag.value) + { + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if (nilp(ptr)) { + result =(uint32_t) c; + } else { + result = ((uint32_t)c * + cell->payload.string.hash) & + 0xffffffff; + } + } + + return result; +} + /** * Construct a string from this character (which later will be UTF) and * this tail. A string is implemented as a flat list of cells each of which @@ -245,8 +275,10 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { cell->payload.string.cdr.page = tail.page; /* \todo There's a problem here. Sometimes the offsets on * strings are quite massively off. Fix is probably - * cell->payload.string.cdr = tsil */ + * cell->payload.string.cdr = tail */ cell->payload.string.cdr.offset = tail.offset; + + cell->payload.string.hash = calculate_hash(c, tail); } else { // \todo should throw an exception! debug_printf( DEBUG_ALLOC, diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index f82b103..7bf34de 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -20,7 +20,8 @@ #include #include -#include "fopen.h" +#include "io/fopen.h" +#include "memory/conspage.h" /** @@ -557,8 +558,8 @@ struct stream_payload { struct string_payload { /** the actual character stored in this cell */ wint_t character; - /** unused padding to word-align the cdr */ - uint32_t padding; + /** a hash of the string value, computed at store time. */ + uint32_t hash; /** the remainder of the string following this character. */ struct cons_pointer cdr; }; diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c new file mode 100644 index 0000000..fcd69e4 --- /dev/null +++ b/src/memory/hashmap.c @@ -0,0 +1,61 @@ +/* + * hashmap.c + * + * Basic implementation of a hashmap. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "arith/integer.h" +#include "memory/consspaceobject.h" +#include "memory/hashmap.h" + +/** + * Get the hash value for the cell indicated by this `ptr`; currently only + * implemented for string like things. + */ +uint32_t get_hash(struct cons_pointer ptr) +{ + struct cons_space_object *cell = &pointer2cell(ptr); + uint32_t result = 0; + + switch (cell->tag.value) + { + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = cell->payload.string.hash; + default: + // TODO: Not Yet Implemented + result = 0; + } + + return result; +} + +/** + * A lisp function signature conforming wrapper around get_hash, q.v.. + */ +struct cons_pointer lisp_get_hash(struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env) +{ + return make_integer(get_hash(frame->arg[0]), NIL); +} + +/** + * Make a hashmap with this number of buckets. + */ +struct cons_pointer make_hashmap( uint32_t n_buckets) { + struct cons_pointer result = make_vso(HASHTAG, + (sizeof(struct cons_pointer) * (n_buckets + 1)) + + (sizeof(uint32_t) * 2)); + + // TODO: fill in the payload! + + struct hashmap_payload *payload = + (struct hashmap_payload *) &pointer_to_vso(result)->payload; + + return result; +} \ No newline at end of file diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h new file mode 100644 index 0000000..b834f5a --- /dev/null +++ b/src/memory/hashmap.h @@ -0,0 +1,36 @@ +/* + * hashmap.h + * + * Basic implementation of a hashmap. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_hashmap_h +#define __psse_hashmap_h + +#include "memory/consspaceobject.h" +#include "memory/vectorspace.h" + +/** + * The payload of a hashmap. The number of buckets is assigned at run-time, + * and is stored in n_buckets. Each bucket is something ASSOC can consume: + * i.e. either an assoc list or a further hashmap. + */ +struct hashmap_payload { + struct cons_pointer hash_fn; + uint32_t n_buckets; + uint32_t unused; /* for word alignment and possible later expansion */ + struct cons_pointer buckets[]; +}; + +uint32_t get_hash(struct cons_pointer ptr); + +struct cons_pointer lisp_get_hash(struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env); + +struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn); + +#endif \ No newline at end of file diff --git a/src/ops/equal.c b/src/ops/equal.c index 6a87de8..feffb93 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -10,11 +10,11 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" -#include "integer.h" -#include "peano.h" -#include "ratio.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "arith/integer.h" +#include "arith/peano.h" +#include "arith/ratio.h" /** * Shallow, and thus cheap, equality: true if these two objects are @@ -69,6 +69,9 @@ bool equal(struct cons_pointer a, struct cons_pointer b) case CONSTV: case LAMBDATV: case NLAMBDATV: + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ result = equal(cell_a->payload.cons.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr, cell_b->payload.cons.cdr); @@ -76,11 +79,13 @@ bool equal(struct cons_pointer a, struct cons_pointer b) case KEYTV: case STRINGTV: case SYMBOLTV: - /* - * slightly complex because a string may or may not have a '\0' - * cell at the end, but I'll ignore that for now. I think in - * practice only the empty string will. - */ + /* slightly complex because a string may or may not have a '\0' + * cell at the end, but I'll ignore that for now. I think in + * practice only the empty string will. + */ + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ result = cell_a->payload.string.character == cell_b->payload.string.character && From 492460f37e61b5c86269daa40b25d6f439ef264e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 4 Aug 2021 11:16:00 +0100 Subject: [PATCH 079/101] Compiles and tests, but there are still major problems. --- src/arith/integer.h | 3 ++ src/memory/consspaceobject.c | 67 ++++++++++++++++++++++++++---------- src/memory/consspaceobject.h | 2 +- src/memory/hashmap.c | 24 ++++++++++--- src/memory/hashmap.h | 2 ++ src/memory/vectorspace.h | 6 ++++ 6 files changed, 81 insertions(+), 23 deletions(-) diff --git a/src/arith/integer.h b/src/arith/integer.h index f0117f5..4ce58d5 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -11,6 +11,9 @@ #ifndef __integer_h #define __integer_h +#include +#include + struct cons_pointer make_integer(int64_t value, struct cons_pointer more); struct cons_pointer add_integers(struct cons_pointer a, diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 080158d..c240c4d 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -24,13 +24,30 @@ #include "intern.h" #include "print.h" #include "stack.h" +#include "vectorspace.h" /** - * True if the tag on the cell at this `pointer` is this `tag`, else false. + * True if the tag on the cell at this `pointer` is this `tag`, or, if the tag + * of the cell is `VECP`, if the tag of the vectorspace object indicated by the + * cell is this `tag`, else false. */ bool check_tag( struct cons_pointer pointer, char *tag ) { - struct cons_space_object cell = pointer2cell( pointer ); - return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; + bool result = false; + struct cons_space_object cell = pointer2cell( pointer ); + + result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; + + if ( !result ) { + // if ( vectorpointp( pointer ) ) { <<< this line blows up! + // // struct vector_space_object *vec = pointer_to_vso( pointer ); + + // // if ( vec != NULL ) { + // // result = strncmp( &vec->header.tag.bytes[0], tag, TAGLENGTH ) == 0; + // // } + // } + } + + return result; } /** @@ -72,14 +89,22 @@ void dec_ref( struct cons_pointer 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 result = NIL; - struct cons_space_object cell = pointer2cell( pointer ); + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( pointer ); + + if ( strncmp( (char *)&cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { + struct vector_space_object *vec = pointer_to_vso( pointer ); for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( ( wchar_t ) cell.tag.bytes[i], result ); + result = make_string( (wchar_t)vec->header.tag.bytes[i], result ); } + } else { + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = make_string( (wchar_t)cell.tag.bytes[i], result ); + } + } - return result; + return result; } /** @@ -227,16 +252,19 @@ struct cons_pointer make_nlambda( struct cons_pointer args, } /** - * Return a hash value for this string. + * Return a hash value for this string like thing. * * What's important here is that two strings with the same characters in the * same order should have the same hash value, even if one was created using * `"foobar"` and the other by `(append "foo" "bar")`. I *think* this function * has that property. I doubt that it's the most efficient hash function to * have that property. - */ -uint32_t calculate_hash( wint_t c, struct cons_pointer ptr) { -struct cons_space_object *cell = &pointer2cell(ptr); + * + * returns 0 for things which are not string like. + */ +uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) +{ + struct cons_space_object *cell = &pointer2cell(ptr); uint32_t result = 0; switch (cell->tag.value) @@ -244,13 +272,16 @@ struct cons_space_object *cell = &pointer2cell(ptr); case KEYTV: case STRINGTV: case SYMBOLTV: - if (nilp(ptr)) { - result =(uint32_t) c; - } else { - result = ((uint32_t)c * - cell->payload.string.hash) & - 0xffffffff; - } + if (nilp(ptr)) + { + result = (uint32_t)c; + } + else + { + result = ((uint32_t)c * + cell->payload.string.hash) & + 0xffffffff; + } } return result; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 7bf34de..486efe2 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -21,7 +21,7 @@ #include #include "io/fopen.h" -#include "memory/conspage.h" +// #include "memory/conspage.h" /** diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index fcd69e4..edabb89 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -10,6 +10,7 @@ #include "arith/integer.h" #include "memory/consspaceobject.h" #include "memory/hashmap.h" +#include "memory/vectorspace.h" /** * Get the hash value for the cell indicated by this `ptr`; currently only @@ -45,17 +46,32 @@ struct cons_pointer lisp_get_hash(struct stack_frame *frame, } /** - * Make a hashmap with this number of buckets. + * Make a hashmap with this number of buckets, using this `hash_fn`. If + * `hash_fn` is `NIL`, use the standard hash funtion. */ -struct cons_pointer make_hashmap( uint32_t n_buckets) { +struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn) { struct cons_pointer result = make_vso(HASHTAG, (sizeof(struct cons_pointer) * (n_buckets + 1)) + (sizeof(uint32_t) * 2)); - // TODO: fill in the payload! - struct hashmap_payload *payload = (struct hashmap_payload *) &pointer_to_vso(result)->payload; + payload->hash_fn = hash_fn; + payload->n_buckets = n_buckets; + for (int i = 0; i < n_buckets; i++) { + payload->buckets[i] = NIL; + } + + return result; +} + +struct cons_pointer clone_hashmap(struct cons_pointer ptr) { + struct cons_pointer result = NIL; + + if (hashmapp(ptr)) { + + } + return result; } \ No newline at end of file diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h index b834f5a..813211b 100644 --- a/src/memory/hashmap.h +++ b/src/memory/hashmap.h @@ -10,6 +10,8 @@ #ifndef __psse_hashmap_h #define __psse_hashmap_h +#include "arith/integer.h" +#include "memory/conspage.h" #include "memory/consspaceobject.h" #include "memory/vectorspace.h" diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 22b0d88..15740ac 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -28,18 +28,24 @@ #define HASHTAG "HASH" #define HASHTV 0 +#define hashmapp(conspoint)((check_tag(conspoint,HASHTAG))) + /* * a namespace (i.e. a binding of names to values, implemented as a hashmap) */ #define NAMESPACETAG "NMSP" #define NAMESPACETV 0 +#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETAG)) + /* * a vector of cons pointers. */ #define VECTORTAG "VECT" #define VECTORTV 0 +#define vectorp(conspoint)(check_tag(conspoint,VECTORTAG)) + /** * given a pointer to a vector space object, return the object. */ From 6f54b92d3205146a036ae695f7785108f61b9b15 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 5 Aug 2021 23:35:21 +0100 Subject: [PATCH 080/101] check_tag now works for vectorspace as well as consspace tags All tests except bignum boundary tests still pass. --- src/memory/consspaceobject.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index c240c4d..06bf41c 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -37,14 +37,14 @@ bool check_tag( struct cons_pointer pointer, char *tag ) { result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; - if ( !result ) { - // if ( vectorpointp( pointer ) ) { <<< this line blows up! - // // struct vector_space_object *vec = pointer_to_vso( pointer ); + if ( result == false ) { + if ( strncmp( &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { + struct vector_space_object *vec = pointer_to_vso( pointer ); - // // if ( vec != NULL ) { - // // result = strncmp( &vec->header.tag.bytes[0], tag, TAGLENGTH ) == 0; - // // } - // } + if ( vec != NULL ) { + result = strncmp( &vec->header.tag.bytes[0], tag, TAGLENGTH ) == 0; + } + } } return result; From 132f5fb268547056603d40da8c20d73aefe37fc4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 6 Aug 2021 00:24:19 +0100 Subject: [PATCH 081/101] More work on hashmaps --- src/memory/hashmap.c | 56 +++++++++++++++++++++++++++++--------------- 1 file changed, 37 insertions(+), 19 deletions(-) diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index edabb89..b8110e4 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -49,29 +49,47 @@ struct cons_pointer lisp_get_hash(struct stack_frame *frame, * Make a hashmap with this number of buckets, using this `hash_fn`. If * `hash_fn` is `NIL`, use the standard hash funtion. */ -struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn) { - struct cons_pointer result = make_vso(HASHTAG, - (sizeof(struct cons_pointer) * (n_buckets + 1)) + - (sizeof(uint32_t) * 2)); +struct cons_pointer make_hashmap( uint32_t n_buckets, + struct cons_pointer hash_fn ) { + struct cons_pointer result = + make_vso( HASHTAG, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + + ( sizeof( uint32_t ) * 2 ) ); - struct hashmap_payload *payload = - (struct hashmap_payload *) &pointer_to_vso(result)->payload; + struct hashmap_payload *payload = + (struct hashmap_payload *)&pointer_to_vso( result )->payload; - payload->hash_fn = hash_fn; - payload->n_buckets = n_buckets; - for (int i = 0; i < n_buckets; i++) { - payload->buckets[i] = NIL; + payload->hash_fn = hash_fn; + payload->n_buckets = n_buckets; + for ( int i = 0; i < n_buckets; i++ ) { + payload->buckets[i] = NIL; + } + + return result; +} + +/** + * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; + * else return `NIL`. TODO: should return an exception. + */ +struct cons_pointer clone_hashmap(struct cons_pointer ptr) { + struct cons_pointer result = NIL; + + if (hashmapp(ptr)) { + struct vector_space_object *from = pointer_to_vso( ptr ); + + if ( from != NULL ) { + struct hashmap_payload *from_pl = (struct hashmap_payload*)from->payload; + result = make_hashmap( from_pl->n_buckets, from_pl->hash_fn); + struct vector_space_object *to = pointer_to_vso(result); + struct hashmap_payload *to_pl = (struct hashmap_payload*)to->payload; + + for (int i = 0; i < to_pl->n_buckets; i++) { + to_pl->buckets[i] = from_pl->buckets[i]; + inc_ref(to_pl->buckets[i]); + } + } } return result; } -struct cons_pointer clone_hashmap(struct cons_pointer ptr) { - struct cons_pointer result = NIL; - - if (hashmapp(ptr)) { - - } - - return result; -} \ No newline at end of file From bfd7304da129dd6ce69a3885800595ff67ae6899 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 16 Aug 2021 15:12:05 +0100 Subject: [PATCH 082/101] Bother. It looks like I'd already fully implemented hashmaps... May need to back out a whole hill of work. --- src/arith/peano.h | 2 + src/authorise.c | 24 ++++ src/authorise.h | 15 +++ src/memory/conspage.c | 20 +-- src/memory/consspaceobject.c | 48 ++++--- src/memory/consspaceobject.h | 4 +- src/memory/hashmap.c | 255 +++++++++++++++++++++++++++++++---- src/memory/hashmap.h | 32 ++--- src/memory/vectorspace.c | 26 ++++ src/memory/vectorspace.h | 30 ++++- src/ops/intern.c | 5 +- 11 files changed, 378 insertions(+), 83 deletions(-) create mode 100644 src/authorise.c create mode 100644 src/authorise.h diff --git a/src/arith/peano.h b/src/arith/peano.h index 89bfc3d..9bcd9e4 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -27,6 +27,8 @@ struct cons_pointer absolute( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg ); +int64_t to_long_int( struct cons_pointer arg ) ; + struct cons_pointer lisp_absolute( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/authorise.c b/src/authorise.c new file mode 100644 index 0000000..5574db9 --- /dev/null +++ b/src/authorise.c @@ -0,0 +1,24 @@ +/* + * authorised.c + * + * For now, a dummy authorising everything. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/conspage.h" +#include "memory/consspaceobject.h" + + +/** + * TODO: does nothing, yet. What it should do is access a magic value in the + * runtime environment and check that it is identical to something on this `acl` + */ +struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl) { + if (nilp(acl)) { + acl = pointer2cell(target).access; + } + return TRUE; +} + diff --git a/src/authorise.h b/src/authorise.h new file mode 100644 index 0000000..c67977d --- /dev/null +++ b/src/authorise.h @@ -0,0 +1,15 @@ +/* + * authorise.h + * + * Basic implementation of a authorisation. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_authorise_h +#define __psse_authorise_h + +struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl); + +#endif \ No newline at end of file diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 53496d3..c9c224d 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -179,26 +179,8 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.string.cdr ); break; case VECTORPOINTTV: - /* for vector space pointers, free the actual vector-space - * object. Dangerous! */ - debug_printf( DEBUG_ALLOC, - L"About to free vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); - struct vector_space_object *vso = - cell->payload.vectorp.address; - - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - free_stack_frame( get_stack_frame( pointer ) ); - break; - } - - free( ( void * ) cell->payload.vectorp.address ); - debug_printf( DEBUG_ALLOC, - L"Freed vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); + free_vso( pointer); break; - } strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 06bf41c..ee82956 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -18,6 +18,7 @@ #include #include +#include "authorise.h" #include "conspage.h" #include "consspaceobject.h" #include "debug.h" @@ -38,7 +39,7 @@ bool check_tag( struct cons_pointer pointer, char *tag ) { result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; if ( result == false ) { - if ( strncmp( &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { + if ( strncmp( &cell.tag.bytes[0], VECTORPOINTTAG, TAGLENGTH ) == 0 ) { struct vector_space_object *vec = pointer_to_vso( pointer ); if ( vec != NULL ) { @@ -55,13 +56,17 @@ bool check_tag( struct cons_pointer pointer, char *tag ) { * * You can't roll over the reference count. Once it hits the maximum * value you cannot increment further. + * + * Returns the `pointer`. */ -void inc_ref( struct cons_pointer pointer ) { +struct cons_pointer inc_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); if ( cell->count < MAXREFERENCE ) { cell->count++; } + + return pointer; } /** @@ -69,8 +74,10 @@ void inc_ref( struct cons_pointer pointer ) { * * If a count has reached MAXREFERENCE it cannot be decremented. * If a count is decremented to zero the cell should be freed. + * + * Returns the `pointer`, or, if the cell has been freed, NIL. */ -void dec_ref( struct cons_pointer pointer ) { +struct cons_pointer dec_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); if ( cell->count > 0 ) { @@ -78,8 +85,11 @@ void dec_ref( struct cons_pointer pointer ) { if ( cell->count == 0 ) { free_cell( pointer ); + pointer = NIL; } } + + return pointer; } @@ -108,38 +118,42 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { } /** - * Implementation of car in C. If arg is not a cons, does not error but returns nil. + * Implementation of car in C. If arg is not a cons, or the current user is not + * authorised to read it, does not error but returns nil. */ struct cons_pointer c_car( struct cons_pointer arg ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if ( consp( arg ) ) { - result = pointer2cell( arg ).payload.cons.car; - } + if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { + result = pointer2cell( arg ).payload.cons.car; + } - return result; + return result; } /** - * Implementation of cdr in C. If arg is not a sequence, does not error but returns nil. + * Implementation of cdr in C. If arg is not a sequence, or the current user is + * not authorised to read it,does not error but returns nil. */ struct cons_pointer c_cdr( struct cons_pointer arg ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; + if ( truep( authorised( arg, NIL ) ) ) { struct cons_space_object *cell = &pointer2cell( arg ); - switch (cell->tag.value) { - case CONSTV: + switch ( cell->tag.value ) { + case CONSTV: result = cell->payload.cons.cdr; break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: + case KEYTV: + case STRINGTV: + case SYMBOLTV: result = cell->payload.string.cdr; break; } + } - return result; + return result; } /** diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 486efe2..98a5a24 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -675,9 +675,9 @@ struct cons_space_object { bool check_tag( struct cons_pointer pointer, char *tag ); -void inc_ref( struct cons_pointer pointer ); +struct cons_pointer inc_ref( struct cons_pointer pointer ); -void dec_ref( struct cons_pointer pointer ); +struct cons_pointer dec_ref( struct cons_pointer pointer ); struct cons_pointer c_type( struct cons_pointer pointer ); diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index b8110e4..9be7d64 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -8,33 +8,89 @@ */ #include "arith/integer.h" +#include "arith/peano.h" +#include "authorise.h" +#include "debug.h" #include "memory/consspaceobject.h" #include "memory/hashmap.h" #include "memory/vectorspace.h" +/** + * Return a hash value for the structure indicated by `ptr` such that if + * `x`,`y` are two separate structures whose print representation is the same + * then `(sxhash x)` and `(sxhash y)` will always be equal. + */ +uint32_t sxhash( struct cons_pointer ptr ) { + // TODO: Not Yet Implemented + /* TODO: should look at the implementation of Common Lisp sxhash? + * My current implementation of `print` only addresses URL_FILE + * streams. It would be better if it also addressed strings but + * currently it doesn't. Creating a print string of the structure + * and taking the hash of that would be one simple (but not necessarily + * cheap) solution. + */ + /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp + * and is EXTREMELY complex, and essentially has a different dispatch for + * every type of object. It's likely we need to do the same. + */ + return 0; +} + /** * Get the hash value for the cell indicated by this `ptr`; currently only - * implemented for string like things. + * implemented for string like things and integers. */ uint32_t get_hash(struct cons_pointer ptr) { struct cons_space_object *cell = &pointer2cell(ptr); uint32_t result = 0; - switch (cell->tag.value) - { - case KEYTV: - case STRINGTV: - case SYMBOLTV: + switch ( cell->tag.value ) { + case INTEGERTV: + /* Note that we're only hashing on the least significant word of an + * integer. */ + result = cell->payload.integer.value & 0xffffffff; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: result = cell->payload.string.hash; - default: - // TODO: Not Yet Implemented - result = 0; + break; + case TRUETV: + result = 1; // arbitrarily + break; + default: + result = sxhash( ptr ); + break; } return result; } +/** + * Free the hashmap indicated by this `pointer`. + */ +void free_hashmap( struct cons_pointer pointer ) { + struct cons_space_object *cell = &pointer2cell( pointer ); + + if ( hashmapp( pointer ) ) { + struct vector_space_object *vso = cell->payload.vectorp.address; + struct hashmap_payload payload = vso->payload.hashmap; + + dec_ref( payload.hash_fn ); + dec_ref( payload.write_acl ); + + for ( int i = 0; i < payload.n_buckets; i++ ) { + debug_printf( DEBUG_ALLOC, + L"Decrementing buckets[%d] of hashmap at 0x%lx\n", i, + cell->payload.vectorp.address ); + dec_ref( payload.buckets[i] ); + } + } else { + debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); + } +} + /** * A lisp function signature conforming wrapper around get_hash, q.v.. */ @@ -50,7 +106,8 @@ struct cons_pointer lisp_get_hash(struct stack_frame *frame, * `hash_fn` is `NIL`, use the standard hash funtion. */ struct cons_pointer make_hashmap( uint32_t n_buckets, - struct cons_pointer hash_fn ) { + struct cons_pointer hash_fn, + struct cons_pointer write_acl ) { struct cons_pointer result = make_vso( HASHTAG, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + ( sizeof( uint32_t ) * 2 ) ); @@ -58,7 +115,9 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct hashmap_payload *payload = (struct hashmap_payload *)&pointer_to_vso( result )->payload; - payload->hash_fn = hash_fn; + payload->hash_fn = inc_ref(hash_fn); + payload->write_acl = inc_ref(write_acl); + payload->n_buckets = n_buckets; for ( int i = 0; i < n_buckets; i++ ) { payload->buckets[i] = NIL; @@ -68,28 +127,170 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, } /** - * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; - * else return `NIL`. TODO: should return an exception. + * Lisp funtion of up to four args (all optional), where + * + * first is expected to be an integer, the number of buckets, or nil; + * second is expected to be a hashing function, or nil; + * third is expected to be an assocable, or nil; + * fourth is a list of user tokens, to be used as a write ACL, or nil. */ -struct cons_pointer clone_hashmap(struct cons_pointer ptr) { - struct cons_pointer result = NIL; +struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + uint32_t n = 32; + struct cons_pointer hash_fn = NIL; + struct cons_pointer result = NIL; - if (hashmapp(ptr)) { - struct vector_space_object *from = pointer_to_vso( ptr ); + if ( frame->args > 0 ) { + if ( integerp( frame->arg[0] ) ) { + n = to_long_int( frame->arg[0] ) % UINT32_MAX; + } else if ( !nilp( frame->arg[0] ) ) { + result = make_exception( + c_string_to_lisp_string( L"First arg to `hashmap`, if passed, must " + L"be an integer or `nil`.`" ), + NIL ); + } + } + if ( frame->args > 1 ) { + hash_fn = frame->arg[1]; + } - if ( from != NULL ) { - struct hashmap_payload *from_pl = (struct hashmap_payload*)from->payload; - result = make_hashmap( from_pl->n_buckets, from_pl->hash_fn); - struct vector_space_object *to = pointer_to_vso(result); - struct hashmap_payload *to_pl = (struct hashmap_payload*)to->payload; + if ( nilp( result ) ) { + /* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which + * is fine */ + result = make_hashmap( n, hash_fn, frame->arg[3] ); + struct vector_space_object *map = pointer_to_vso( result ); - for (int i = 0; i < to_pl->n_buckets; i++) { - to_pl->buckets[i] = from_pl->buckets[i]; - inc_ref(to_pl->buckets[i]); - } + if ( frame->args > 2 && + truep( authorised( result, map->payload.hashmap.write_acl ) ) ) { + // then arg[2] ought to be an assoc list which we should iterate down + // populating the hashmap. + for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor ); + cursor = c_cdr( cursor ) ) { + struct cons_pointer pair = c_car( cursor ); + struct cons_pointer key = c_car( pair ); + struct cons_pointer val = c_cdr( pair ); + + uint32_t bucket_no = + get_hash( key ) % + ( (struct hashmap_payload *)&( map->payload ) )->n_buckets; + + map->payload.hashmap.buckets[bucket_no] = + inc_ref( make_cons( make_cons( key, val ), + map->payload.hashmap.buckets[bucket_no] )); } } + } - return result; + return result; +} + +/** + * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; + * else return `NIL`. TODO: should return an exception if ptr is not a + * readable hashmap. + */ +struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { + struct cons_pointer result = NIL; + + if ( truep( authorised( ptr, NIL ) ) ) { + if ( hashmapp( ptr ) ) { + struct vector_space_object *from = pointer_to_vso( ptr ); + + if ( from != NULL ) { + struct hashmap_payload from_pl = from->payload.hashmap; + result = make_hashmap( from_pl.n_buckets, from_pl.hash_fn, from_pl.write_acl ); + struct vector_space_object *to = pointer_to_vso( result ); + struct hashmap_payload to_pl = to->payload.hashmap; + + for ( int i = 0; i < to_pl.n_buckets; i++ ) { + to_pl.buckets[i] = from_pl.buckets[i]; + inc_ref( to_pl.buckets[i] ); + } + } + } + } + // TODO: else exception? + + return result; +} + +/** + * Store this `val` as the value of this `key` in this hashmap `mapp`. If + * current user is authorised to write to this hashmap, modifies the hashmap and + * returns it; if not, clones the hashmap, modifies the clone, and returns that. + */ +struct cons_pointer hashmap_put( struct cons_pointer mapp, + struct cons_pointer key, + struct cons_pointer val ) { + // TODO: if current user has write access to this hashmap + if ( hashmapp( mapp ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + + if (nilp(authorised(mapp, map->payload.hashmap.write_acl))) { + mapp = clone_hashmap( mapp); + map = pointer_to_vso( mapp ); + } + uint32_t bucket_no = + get_hash( key ) % + map->payload.hashmap.n_buckets; + + map->payload.hashmap.buckets[bucket_no] = + inc_ref( make_cons( make_cons( key, val ), + map->payload.hashmap.buckets[bucket_no] )); + } + + return mapp; +} + +/** + * Expects `frame->arg[1]` to be a hashmap or namespace; `frame->arg[2]` to be + * a string-like-thing (perhaps necessarily a keyword); frame->arg[3] to be + * any value. If + * current user is authorised to write to this hashmap, modifies the hashmap and + * returns it; if not, clones the hashmap, modifies the clone, and returns that. + */ +struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer mapp = frame->arg[0]; + struct cons_pointer key = frame->arg[1]; + struct cons_pointer val = frame->arg[2]; + + return hashmap_put(mapp, key, val); +} + +/** + * Copy all key/value pairs in this association list `assoc` into this hashmap `mapp`. If + * current user is authorised to write to this hashmap, modifies the hashmap and + * returns it; if not, clones the hashmap, modifies the clone, and returns that. + */ +struct cons_pointer hashmap_put_all( struct cons_pointer mapp, + struct cons_pointer assoc ) { + // TODO: if current user has write access to this hashmap + if ( hashmapp( mapp ) && !nilp( assoc ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + + if ( hashmapp( mapp ) && consp( assoc ) ) { + for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair ); + pair = c_car( assoc ) ) { + /* TODO: this is really hammering the memory management system, because + * it will make a new lone for every key/value pair added. Fix. */ + mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) ); + } + } + } + + return mapp; +} + +/** + * Lisp function expecting two arguments, a hashmap and an assoc list. Copies all + * key/value pairs from the assoc list into the map. + */ +struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return hashmap_put_all( frame->arg[0], frame->arg[1] ); } diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h index 813211b..579b56d 100644 --- a/src/memory/hashmap.h +++ b/src/memory/hashmap.h @@ -15,24 +15,24 @@ #include "memory/consspaceobject.h" #include "memory/vectorspace.h" -/** - * The payload of a hashmap. The number of buckets is assigned at run-time, - * and is stored in n_buckets. Each bucket is something ASSOC can consume: - * i.e. either an assoc list or a further hashmap. - */ -struct hashmap_payload { - struct cons_pointer hash_fn; - uint32_t n_buckets; - uint32_t unused; /* for word alignment and possible later expansion */ - struct cons_pointer buckets[]; -}; +uint32_t get_hash( struct cons_pointer ptr ); -uint32_t get_hash(struct cons_pointer ptr); +void free_hashmap( struct cons_pointer ptr ); -struct cons_pointer lisp_get_hash(struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env); +struct cons_pointer lisp_get_hash( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); -struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn); +struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif \ No newline at end of file diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 480effb..b3e64c6 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -22,6 +22,8 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "hashmap.h" +#include "stack.h" #include "vectorspace.h" @@ -112,3 +114,27 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { return result; } + +/** for vector space pointers, free the actual vector-space + * object. Dangerous! */ + +void free_vso( struct cons_pointer pointer ) { + struct cons_space_object * cell = &pointer2cell( pointer); + + debug_printf( DEBUG_ALLOC, L"About to free vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); + struct vector_space_object *vso = cell->payload.vectorp.address; + + switch ( vso->header.tag.value ) { + case HASHTV: + free_hashmap( pointer ); + break; + case STACKFRAMETV: + free_stack_frame( get_stack_frame( pointer ) ); + break; + } + + free( (void *)cell->payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); +} \ No newline at end of file diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 15740ac..ed050bc 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -18,6 +18,7 @@ #include #include "consspaceobject.h" +#include "hashmap.h" #ifndef __vectorspace_h #define __vectorspace_h @@ -58,6 +59,8 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ); +void free_vso(struct cons_pointer pointer); + /** * the header which forms the start of every vector space object. */ @@ -75,6 +78,27 @@ struct vector_space_header { uint64_t size; }; +/** + * The payload of a hashmap. The number of buckets is assigned at run-time, + * and is stored in n_buckets. Each bucket is something ASSOC can consume: + * i.e. either an assoc list or a further hashmap. + */ +struct hashmap_payload { + struct cons_pointer + hash_fn; /* function for hashing values in this hashmap, or `NIL` to use + the default hashing function */ + struct cons_pointer write_acl; /* it seems to me that it is likely that the + * principal difference between a hashmap and a + * namespace is that a hashmap has a write ACL + * of `NIL`, meaning not writeable by anyone */ + uint32_t n_buckets; /* number of hash buckets */ + uint32_t unused; /* for word alignment and possible later expansion */ + struct cons_pointer + buckets[]; /* actual hash buckets, which should be `NIL` + * or assoc lists or (possibly) further hashmaps. */ +}; + + /** a vector_space_object is just a vector_space_header followed by a * lump of bytes; what we deem to be in there is a function of the tag, * and at this stage we don't have a good picture of what these may be. @@ -87,7 +111,11 @@ struct vector_space_object { struct vector_space_header header; /** we'll malloc `size` bytes for payload, `payload` is just the first of these. * \todo this is almost certainly not idiomatic C. */ - char payload; + union { + /** the payload considered as bytes */ + char bytes; + struct hashmap_payload hashmap; + } payload; }; #endif diff --git a/src/ops/intern.c b/src/ops/intern.c index cf86e6b..802bc82 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -23,6 +23,7 @@ #include "consspaceobject.h" #include "debug.h" #include "equal.h" +#include "hashmap.h" #include "lispops.h" #include "map.h" #include "print.h" @@ -107,8 +108,10 @@ struct cons_pointer c_assoc( struct cons_pointer key, break; } } - } else if (vectorpointp( store)) { + } else if (hashmapp( store)) { result = assoc_in_map( key, store); + } else { + result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL); } debug_print( L"c_assoc returning ", DEBUG_BIND); From 4fc9545be8610b94b4bc55e19cbcce696f576446 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 16 Aug 2021 18:55:02 +0100 Subject: [PATCH 083/101] Hashmaps sort-of work but there are still bugs and one test is failing that wasn't. --- src/init.c | 8 +- src/io/print.c | 46 +++---- src/io/read.c | 48 +++---- src/memory/dump.c | 8 +- src/memory/hashmap.c | 70 +++++++++- src/memory/hashmap.h | 17 +++ src/memory/map.c | 289 --------------------------------------- src/memory/map.h | 96 ------------- src/memory/vectorspace.h | 8 +- src/ops/intern.c | 8 +- src/ops/lispops.c | 23 +++- src/ops/lispops.h | 72 +++++----- 12 files changed, 206 insertions(+), 487 deletions(-) delete mode 100644 src/memory/map.c delete mode 100644 src/memory/map.h diff --git a/src/init.c b/src/init.c index dbfdd5d..7b1649c 100644 --- a/src/init.c +++ b/src/init.c @@ -23,10 +23,10 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "hashmap.h" #include "intern.h" #include "io.h" #include "lispops.h" -#include "map.h" #include "meta.h" #include "peano.h" #include "print.h" @@ -225,8 +225,10 @@ int main( int argc, char *argv[] ) { bind_function( L"equal", &lisp_equal ); bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); + bind_function( L"gethash", &lisp_get_hash); + bind_function(L"hashmap", lisp_make_hashmap); bind_function( L"inspect", &lisp_inspect ); - bind_function( L"make-map", &lisp_make_map); + bind_function( L"keys", &lisp_keys); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); bind_function( L"multiply", &lisp_multiply ); @@ -235,6 +237,8 @@ int main( int argc, char *argv[] ) { bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); + bind_function( L"put", lisp_hashmap_put); + bind_function( L"put-all", &lisp_hashmap_put_all); bind_function( L"read", &lisp_read ); bind_function( L"read-char", &lisp_read_char ); bind_function( L"repl", &lisp_repl ); diff --git a/src/io/print.c b/src/io/print.c index c68c03e..3f33252 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -19,9 +19,9 @@ #include "conspage.h" #include "consspaceobject.h" +#include "hashmap.h" #include "integer.h" #include "intern.h" -#include "map.h" #include "stack.h" #include "print.h" #include "psse_time.h" @@ -88,40 +88,38 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) { url_fputws( L")", output ); } +void print_map( URL_FILE *output, struct cons_pointer map ) { + if ( hashmapp( map ) ) { + struct vector_space_object *vso = pointer_to_vso( map ); -void print_map( URL_FILE * output, struct cons_pointer map) { - if ( vectorpointp( map)) { - struct vector_space_object *vso = pointer_to_vso( map); + url_fputwc( btowc( '{' ), output ); - if ( mapp( vso ) ) { - url_fputwc( btowc( '{' ), output ); + for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); + ks = c_cdr( ks ) ) { + struct cons_pointer key = c_car( ks); + print( output, key ); + url_fputwc( btowc( ' ' ), output ); + print( output, hashmap_get( map, key ) ); - for ( struct cons_pointer ks = keys( map); - !nilp( ks); ks = c_cdr( ks)) { - print( output, c_car( ks)); - url_fputwc( btowc( ' ' ), output ); - print( output, c_assoc( c_car( ks), map)); - - if ( !nilp( c_cdr( ks))) { - url_fputws( L", ", output ); - } - } - - url_fputwc( btowc( '}' ), output ); - } + if ( !nilp( c_cdr( ks ) ) ) { + url_fputws( L", ", output ); + } } + + url_fputwc( btowc( '}' ), output ); + } } - void print_vso( URL_FILE * output, struct cons_pointer pointer) { - struct vector_space_object *vso = - pointer2cell( pointer ).payload.vectorp.address; - + struct vector_space_object *vso = pointer_to_vso(pointer); switch ( vso->header.tag.value) { - case MAPTV: + case HASHTV: print_map( output, pointer); break; // \todo: others. + default: + fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", + vso->header.tag.value ); } } diff --git a/src/io/read.c b/src/io/read.c index 0f32815..ede44ad 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -20,11 +20,11 @@ #include "consspaceobject.h" #include "debug.h" #include "dump.h" +#include "hashmap.h" #include "integer.h" #include "intern.h" #include "io.h" #include "lispops.h" -#include "map.h" #include "peano.h" #include "print.h" #include "ratio.h" @@ -323,37 +323,39 @@ struct cons_pointer read_list( struct stack_frame *frame, return result; } - struct cons_pointer read_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - URL_FILE * input, wint_t initial ) { - struct cons_pointer result = make_empty_map( NIL); - wint_t c = initial; + struct cons_pointer frame_pointer, + URL_FILE *input, wint_t initial ) { + // set write ACL to true whilst creating to prevent GC churn + struct cons_pointer result = make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE ); + wint_t c = initial; - while ( c != L'}' ) { - struct cons_pointer key = - read_continuation( frame, frame_pointer, input, c ); + while ( c != L'}' ) { + struct cons_pointer key = + read_continuation( frame, frame_pointer, input, c ); - /* skip whitespace */ - for (c = url_fgetwc( input ); - iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input )); + /* skip whitespace */ + for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ) + ; - struct cons_pointer value = - read_continuation( frame, frame_pointer, input, c ); + struct cons_pointer value = + read_continuation( frame, frame_pointer, input, c ); - /* skip commaa and whitespace at this point. */ - for (c = url_fgetwc( input ); - c == L',' || iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input )); + /* skip commaa and whitespace at this point. */ + for ( c = url_fgetwc( input ); c == L',' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ) + ; - result = merge_into_map( result, make_cons( make_cons( key, value), NIL)); - } + result = hashmap_put( result, key, value ); + } - return result; + // default write ACL for maps should be NIL. + pointer_to_vso( result )->payload.hashmap.write_acl = NIL; + + return result; } - /** * Read a string. This means either a string delimited by double quotes * (is_quoted == true), in which case it may contain whitespace but may diff --git a/src/memory/dump.c b/src/memory/dump.c index 074d1c4..b992bb2 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -21,8 +21,8 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "hashmap.h" #include "intern.h" -#include "map.h" #include "print.h" #include "stack.h" #include "vectorspace.h" @@ -141,14 +141,12 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { 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; - case MAPTV: + case HASHTV: dump_map( output, pointer); break; } diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index 9be7d64..11a03f0 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -11,6 +11,8 @@ #include "arith/peano.h" #include "authorise.h" #include "debug.h" +#include "intern.h" +#include "memory/conspage.h" #include "memory/consspaceobject.h" #include "memory/hashmap.h" #include "memory/vectorspace.h" @@ -81,10 +83,12 @@ void free_hashmap( struct cons_pointer pointer ) { dec_ref( payload.write_acl ); for ( int i = 0; i < payload.n_buckets; i++ ) { - debug_printf( DEBUG_ALLOC, - L"Decrementing buckets[%d] of hashmap at 0x%lx\n", i, - cell->payload.vectorp.address ); - dec_ref( payload.buckets[i] ); + if ( !nilp( payload.buckets[i] ) ) { + debug_printf( DEBUG_ALLOC, + L"Decrementing bucket [%d] of hashmap at 0x%lx\n", i, + cell->payload.vectorp.address ); + dec_ref( payload.buckets[i] ); + } } } else { debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); @@ -137,7 +141,7 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - uint32_t n = 32; + uint32_t n = DFLT_HASHMAP_BUCKETS; struct cons_pointer hash_fn = NIL; struct cons_pointer result = NIL; @@ -185,6 +189,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, return result; } + + /** * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; * else return `NIL`. TODO: should return an exception if ptr is not a @@ -243,6 +249,19 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp, return mapp; } +struct cons_pointer hashmap_get( struct cons_pointer mapp, + struct cons_pointer key ) { + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; + + result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] ); + } + + return result; +} + /** * Expects `frame->arg[1]` to be a hashmap or namespace; `frame->arg[2]` to be * a string-like-thing (perhaps necessarily a keyword); frame->arg[3] to be @@ -294,3 +313,44 @@ struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, return hashmap_put_all( frame->arg[0], frame->arg[1] ); } +/** + * return a flat list of all the keys in the hashmap indicated by `map`. + */ +struct cons_pointer hashmap_keys( struct cons_pointer mapp) { + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) )) { + struct vector_space_object *map = pointer_to_vso( mapp ); + + for (int i = 0; i < map->payload.hashmap.n_buckets; i++) { + for (struct cons_pointer c = map->payload.hashmap.buckets[i]; + !nilp(c); + c = c_cdr(c)) { + result = make_cons(c_car( c_car(c)), result); + } + + } + } + + return result; +} + +struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return hashmap_keys( frame->arg[0] ); +} + +void dump_map( URL_FILE *output, struct cons_pointer pointer ) { + struct hashmap_payload *payload = &pointer_to_vso( pointer )->payload.hashmap; + url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); + url_fwprintf( output, L"\tHash function: " ); + print( output, payload->hash_fn ); + url_fwprintf( output, L"\n\tWrite ACL: " ); + print( output, payload->write_acl ); + url_fwprintf( output, L"\n\tBuckets:" ); + for ( int i = 0; i < payload->n_buckets; i++ ) { + url_fwprintf( output, L"\n\t\t[%d]: ", i ); + print( output, payload->buckets[i] ); + } + url_fwprintf( output, L"\n" ); +} diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h index 579b56d..4602f3e 100644 --- a/src/memory/hashmap.h +++ b/src/memory/hashmap.h @@ -15,14 +15,27 @@ #include "memory/consspaceobject.h" #include "memory/vectorspace.h" +#define DFLT_HASHMAP_BUCKETS 32 + uint32_t get_hash( struct cons_pointer ptr ); void free_hashmap( struct cons_pointer ptr ); +void dump_map( URL_FILE *output, struct cons_pointer pointer ); + +struct cons_pointer hashmap_get( struct cons_pointer mapp, + struct cons_pointer key ); + +struct cons_pointer hashmap_put( struct cons_pointer mapp, + struct cons_pointer key, + struct cons_pointer val ); + struct cons_pointer lisp_get_hash( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer hashmap_keys( struct cons_pointer map ); + struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -35,4 +48,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer make_hashmap( uint32_t n_buckets, + struct cons_pointer hash_fn, + struct cons_pointer write_acl ); + #endif \ No newline at end of file diff --git a/src/memory/map.c b/src/memory/map.c deleted file mode 100644 index cbad3df..0000000 --- a/src/memory/map.c +++ /dev/null @@ -1,289 +0,0 @@ -/* - * map.c - * - * An immutable hashmap in vector space. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include - -#include "consspaceobject.h" -#include "conspage.h" -#include "debug.h" -#include "dump.h" -#include "fopen.h" -#include "intern.h" -#include "io.h" -#include "lookup3.h" -#include "map.h" -#include "print.h" -#include "vectorspace.h" - -/* \todo: a lot of this will be inherited by namespaces, regularities and - * homogeneities. Exactly how I don't yet know. */ - -/** - * Get a hash value for this key. - */ -uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) { - uint32_t result = 0; - int l = c_length(key); - - if (keywordp(key) || stringp(key) || symbolp( key)) { - if ( l > 0) { - uint32_t buffer[l]; - - if (!nilp(f)) { - fputws(L"Custom hashing functions are not yet implemented.\n", stderr); - } - for (int i = 0; i < l; i++) { - buffer[i] = (uint32_t)pointer2cell(key).payload.string.character; - } - - result = hashword( buffer, l, 0); - } - } else { - fputws(L"Hashing is thus far implemented only for keys, strings and symbols.\n", stderr); - } - - return result; -} - -/** - * get the actual map object from this `pointer`, or NULL if - * `pointer` is not a map pointer. - */ -struct map_payload *get_map_payload( struct cons_pointer pointer ) { - struct map_payload *result = NULL; - struct vector_space_object *vso = - pointer2cell( pointer ).payload.vectorp.address; - - if (vectorpointp(pointer) && mapp( vso ) ) { - result = ( struct map_payload * ) &( vso->payload ); - debug_printf( DEBUG_BIND, - L"get_map_payload: all good, returning %p\n", result ); - } else { - debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_BIND ); - } - - return result; -} - - -/** - * Make an empty immutable map, and return it. - * - * @param hash_function a pointer to a function of one argument, which - * returns an integer; or (more usually) `nil`. - * @return the new map, or NULL if memory is exhausted. - */ -struct cons_pointer make_empty_map( struct cons_pointer hash_function ) { - debug_print( L"Entering make_empty_map\n", DEBUG_BIND ); - struct cons_pointer result = - make_vso( MAPTAG, sizeof( struct map_payload ) ); - - if ( !nilp( result ) ) { - struct map_payload *payload = get_map_payload( result ); - - payload->hash_function = functionp( hash_function) ? hash_function : NIL; - inc_ref(hash_function); - - for ( int i = 0; i < BUCKETSINMAP; i++) { - payload->buckets[i] = NIL; - } - } - - debug_print( L"Leaving make_empty_map\n", DEBUG_BIND ); - return result; -} - - -struct cons_pointer make_duplicate_map( struct cons_pointer parent) { - struct cons_pointer result = NIL; - struct map_payload * parent_payload = get_map_payload(parent); - - if (parent_payload != NULL) { - result = - make_vso( MAPTAG, sizeof( struct map_payload ) ); - - if ( !nilp( result ) ) { - struct map_payload *payload = get_map_payload( result ); - - payload->hash_function = parent_payload->hash_function; - inc_ref(payload->hash_function); - - for ( int i = 0; i < BUCKETSINMAP; i++) { - payload->buckets[i] = parent_payload->buckets[i]; - inc_ref(payload->buckets[i]); - } - } - } - - return result; -} - - -struct cons_pointer bind_in_map( struct cons_pointer parent, - struct cons_pointer key, - struct cons_pointer value) { - struct cons_pointer result = make_duplicate_map(parent); - - if ( !nilp( result)) { - struct map_payload * payload = get_map_payload( result ); - int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; - - payload->buckets[bucket] = make_cons( - make_cons(key, value), payload->buckets[bucket]); - - inc_ref(payload->buckets[bucket]); - } - - return result; -} - - -struct cons_pointer keys( struct cons_pointer store) { - debug_print( L"Entering keys\n", DEBUG_BIND ); - struct cons_pointer result = NIL; - - struct cons_space_object cell = pointer2cell( store ); - - switch (pointer2cell( store ).tag.value) { - case CONSTV: - for (struct cons_pointer c = store; !nilp(c); c = c_cdr(c)) { - result = make_cons( c_car( c_car( c)), result); - } - break; - case VECTORPOINTTV: { - struct vector_space_object *vso = - pointer2cell( store ).payload.vectorp.address; - - if ( mapp( vso ) ) { - struct map_payload * payload = get_map_payload( store ); - - for (int bucket = 0; bucket < BUCKETSINMAP; bucket++) { - for (struct cons_pointer c = payload->buckets[bucket]; - !nilp(c); c = c_cdr(c)) { - debug_print( L"keys: c is ", DEBUG_BIND); - debug_print_object( c, DEBUG_BIND); - - result = make_cons( c_car( c_car( c)), result); - debug_print( L"; result is ", DEBUG_BIND); - debug_print_object( result, DEBUG_BIND); - debug_println( DEBUG_BIND); - } - } - } - } - break; - } - debug_print( L"keys returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND); - - return result; -} - -/** - * Return a new map which represents the merger of `to_merge` into - * `parent`. `parent` must be a map, but `to_merge` may be a map or - * an assoc list. - * - * @param parent a map; - * @param to_merge an association from which key/value pairs will be merged. - * @result a new map, containing all key/value pairs from `to_merge` - * together with those key/value pairs from `parent` whose keys did not - * collide. - */ -struct cons_pointer merge_into_map( struct cons_pointer parent, - struct cons_pointer to_merge) { - debug_print( L"Entering merge_into_map\n", DEBUG_BIND ); - struct cons_pointer result = make_duplicate_map(parent); - - if (!nilp(result)) { - struct map_payload *payload = get_map_payload( result ); - for (struct cons_pointer c = keys(to_merge); - !nilp(c); c = c_cdr(c)) { - struct cons_pointer key = c_car( c); - int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; - - payload->buckets[bucket] = make_cons( - make_cons( key, c_assoc( key, to_merge)), - payload->buckets[bucket]); - } - } - - debug_print( L"Leaving merge_into_map\n", DEBUG_BIND ); - - return result; -} - - -struct cons_pointer assoc_in_map( struct cons_pointer key, - struct cons_pointer map) { - debug_print( L"Entering assoc_in_map\n", DEBUG_BIND ); - struct cons_pointer result = NIL; - struct map_payload *payload = get_map_payload( map ); - - if (payload != NULL) { - int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; - result = c_assoc(key, payload->buckets[bucket]); - } - - debug_print( L"assoc_in_map returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND); - debug_println( DEBUG_BIND); - - return result; -} - - -/** - * Function: create a map initialised with key/value pairs from my - * first argument. - * - * * (make-map) - * * (make-map store) - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which it is to be intepreted. - * @return a new containing all the key/value pairs from store. - */ -struct cons_pointer -lisp_make_map( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return merge_into_map( make_empty_map( NIL), frame->arg[0]); -} - -/** - * Dump a map to this stream for debugging - * @param output the stream - * @param map_pointer the pointer to the frame - */ -void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) { - struct vector_space_object *vso = - pointer2cell( map_pointer ).payload.vectorp.address; - - if (vectorpointp(map_pointer) && mapp( vso ) ) { - struct map_payload *payload = get_map_payload( map_pointer ); - - if ( payload != NULL ) { - url_fputws( L"Immutable map; hash function: ", output ); - - if (nilp(payload->hash_function)) { - url_fputws( L"default", output); - } else { - dump_object( output, payload->hash_function); - } - - for (int i = 0; i < BUCKETSINMAP; i++) { - url_fwprintf(output, L"\n\tBucket %d: ", i); - print( output, payload->buckets[i]); - } - } - } -} - diff --git a/src/memory/map.h b/src/memory/map.h deleted file mode 100644 index c9b5cfc..0000000 --- a/src/memory/map.h +++ /dev/null @@ -1,96 +0,0 @@ -/* - * map.h - * - * An immutable hashmap in vector space. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_map_h -#define __psse_map_h - -#include "consspaceobject.h" -#include "conspage.h" - -/** - * macros for the tag of a mutable map. - */ -#define MAPTAG "IMAP" -#define MAPTV 1346456905 - -/** - * Number of buckets in a single tier map. - */ -#define BUCKETSINMAP 256 - -/** - * Maximum number of entries in an association-list bucket. - */ -#define MAXENTRIESINASSOC 16 - -/** - * true if this vector_space_object is a map, else false. - */ -#define mapp( vso) (((struct vector_space_object *)vso)->header.tag.value == MAPTV) - -/** - * The vector-space payload of a map object. Essentially a vector of - * `BUCKETSINMAP` + 1 `cons_pointer`s, but the first one is considered - * special. - */ -struct map_payload { - /** - * There is a default hash function, which is used if `hash_function` is - * `nil` (which it normally should be); and keywords will probably carry - * their own hash values. But it will be possible to override the hash - * function by putting a function of one argument returning an integer - * here. */ - struct cons_pointer hash_function; - - /** - * Obviously the number of buckets in a map is a trade off, and this may need - * tuning - or it may even be necessary to have different sized base maps. The - * idea here is that the value of a bucket is - * - * 1. `nil`; or - * 2. an association list; or - * 3. a map. - * - * All buckets are initially `nil`. Adding a value to a `nil` bucket returns - * a map with a new bucket in the form of an assoc list. Subsequent additions - * cons new key/value pairs onto the assoc list, until there are - * `MAXENTRIESINASSOC` pairs, at which point if a further value is added to - * the same bucket the bucket returned will be in the form of a second level - * map. My plan is that buckets the first level map will be indexed on the - * first sixteen bits of the hash value, those in the second on the second - * sixteen, and, potentially, so on. - */ - struct cons_pointer buckets[BUCKETSINMAP]; -}; - -uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key); - -struct map_payload *get_map_payload( struct cons_pointer pointer ); - -struct cons_pointer make_empty_map( struct cons_pointer hash_function ); - -struct cons_pointer bind_in_map( struct cons_pointer parent, - struct cons_pointer key, - struct cons_pointer value); - -struct cons_pointer keys( struct cons_pointer store); - -struct cons_pointer merge_into_map( struct cons_pointer parent, - struct cons_pointer to_merge); - -struct cons_pointer assoc_in_map( struct cons_pointer key, - struct cons_pointer map); - -struct cons_pointer lisp_make_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -void dump_map( URL_FILE * output, struct cons_pointer map_pointer ); - -#endif diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index ed050bc..2c163e8 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -27,15 +27,17 @@ * part of the implementation structure of a namespace. */ #define HASHTAG "HASH" -#define HASHTV 0 +#define HASHTV 1213415752 #define hashmapp(conspoint)((check_tag(conspoint,HASHTAG))) /* * a namespace (i.e. a binding of names to values, implemented as a hashmap) + * TODO: but note that a namespace is now essentially a hashmap with a write ACL + * whose name is interned. */ #define NAMESPACETAG "NMSP" -#define NAMESPACETV 0 +#define NAMESPACETV 1347636558 #define namespacep(conspoint)(check_tag(conspoint,NAMESPACETAG)) @@ -43,7 +45,7 @@ * a vector of cons pointers. */ #define VECTORTAG "VECT" -#define VECTORTV 0 +#define VECTORTV 1413694806 #define vectorp(conspoint)(check_tag(conspoint,VECTORTAG)) diff --git a/src/ops/intern.c b/src/ops/intern.c index 802bc82..07b9693 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -25,7 +25,6 @@ #include "equal.h" #include "hashmap.h" #include "lispops.h" -#include "map.h" #include "print.h" /** @@ -109,7 +108,7 @@ struct cons_pointer c_assoc( struct cons_pointer key, } } } else if (hashmapp( store)) { - result = assoc_in_map( key, store); + result = hashmap_get( store, key); } else { result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL); } @@ -140,8 +139,8 @@ struct cons_pointer if (nilp( store) || consp(store)) { result = make_cons( make_cons( key, value ), store ); - } else if (vectorpointp( store)) { - result = bind_in_map( store, key, value); + } else if (hashmapp( store)) { + result = hashmap_put( store, key, value); } debug_print( L"set returning ", DEBUG_BIND); @@ -196,3 +195,4 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { return result; } + diff --git a/src/ops/lispops.c b/src/ops/lispops.c index c96b1be..3a972a5 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -33,7 +33,6 @@ #include "intern.h" #include "io.h" #include "lispops.h" -#include "map.h" #include "print.h" #include "read.h" #include "stack.h" @@ -378,7 +377,7 @@ struct cons_pointer case VECTORPOINTTV: switch ( pointer_to_vso(fn_pointer)->header.tag.value) { - case MAPTV: + case HASHTV: /* \todo: if arg[0] is a CONS, treat it as a path */ result = c_assoc( eval_form(frame, frame_pointer, @@ -803,6 +802,26 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, return c_assoc( frame->arg[0], frame->arg[1] ); } +struct cons_pointer c_keys(struct cons_pointer store) { + struct cons_pointer result = NIL; + + if ( hashmapp( store ) ) { + result = hashmap_keys( store ); + } else if ( consp( store ) ) { + for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) { + result = make_cons( c_car( c ), result ); + } + } + + return result; +} + +struct cons_pointer lisp_keys( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_keys( frame->arg[0]); +} + /** * Function; are these two objects the same object? Shallow, cheap equality. * diff --git a/src/ops/lispops.h b/src/ops/lispops.h index f359252..4669493 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -26,12 +26,14 @@ * utilities */ +struct cons_pointer c_keys( struct cons_pointer store ); struct cons_pointer c_reverse( struct cons_pointer arg ); -struct cons_pointer -c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer expressions, struct cons_pointer env ); +struct cons_pointer c_progn( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer expressions, + struct cons_pointer env ); /** * Useful building block; evaluate this single form in the context of this @@ -56,7 +58,6 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer list, struct cons_pointer env ); - /* * special forms */ @@ -67,17 +68,21 @@ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_keys( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); -struct cons_pointer -lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_oblist( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); -struct cons_pointer -lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_set( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_set_shriek( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Construct an interpretable function. @@ -90,17 +95,17 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_length( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Construct an interpretable special form. * * @param frame the stack frame in which the expression is to be interpreted; * @param env the environment in which it is to be intepreted. */ -struct cons_pointer -lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_nlambda( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -146,10 +151,9 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, * @param env My environment (ignored). * @return As a Lisp string, the tag of the object which is the argument. */ -struct cons_pointer -lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); - +struct cons_pointer lisp_type( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Function; evaluate the forms which are listed in my single argument @@ -161,9 +165,9 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, * @return the value of the last form on the sequence which is my single * argument. */ -struct cons_pointer -lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_progn( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Special form: conditional. Each arg is expected to be a list; if the first @@ -174,22 +178,22 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, * @param env My environment (ignored). * @return the value of the last form of the first successful clause. */ -struct cons_pointer -lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_cond( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Throw an exception. - * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a - * lisp function; but it is nevertheless to be preferred to make_exception. A - * real `throw_exception`, which does, will be needed. + * `throw_exception` is a misnomer, because it doesn't obey the calling + * signature of a lisp function; but it is nevertheless to be preferred to + * make_exception. A real `throw_exception`, which does, will be needed. */ struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer ); -struct cons_pointer -lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_exception( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, From eadb125b83665f60dba28b97e92ebc2bc05c2eed Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 16 Aug 2021 23:23:03 +0100 Subject: [PATCH 084/101] Hashmaps now *mostly* work --- .gitignore | 2 + src/init.c | 2 +- src/io/io.c | 30 ++++- src/io/io.h | 2 + src/memory/consspaceobject.c | 9 +- src/memory/dump.c | 208 +++++++++++++++++------------------ src/memory/hashmap.c | 1 + src/memory/vectorspace.c | 23 +++- src/ops/lispops.c | 134 ++++++++++++---------- src/ops/lispops.h | 13 +-- 10 files changed, 238 insertions(+), 186 deletions(-) diff --git a/.gitignore b/.gitignore index 3bf3906..a85ac01 100644 --- a/.gitignore +++ b/.gitignore @@ -40,3 +40,5 @@ src/io/fopen hi\.* .vscode/ + +core diff --git a/src/init.c b/src/init.c index 7b1649c..4126783 100644 --- a/src/init.c +++ b/src/init.c @@ -225,7 +225,7 @@ int main( int argc, char *argv[] ) { bind_function( L"equal", &lisp_equal ); bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); - bind_function( L"gethash", &lisp_get_hash); + bind_function( L"get-hash", &lisp_get_hash); bind_function(L"hashmap", lisp_make_hashmap); bind_function( L"inspect", &lisp_inspect ); bind_function( L"keys", &lisp_keys); diff --git a/src/io/io.c b/src/io/io.c index 5065044..9976373 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -177,13 +177,13 @@ wint_t url_fgetwc( URL_FILE * input ) { * E0 to EF hex (224 to 239): first byte of a three-byte sequence. * F0 to FF hex (240 to 255): first byte of a four-byte sequence. */ - if ( c <= 0x07 ) { + if ( c <= 0xf7 ) { count = 1; - } else if ( c >= '0xc2' && c <= '0xdf' ) { + } else if ( c >= 0xc2 && c <= 0xdf ) { count = 2; - } else if ( c >= '0xe0' && c <= '0xef' ) { + } else if ( c >= 0xe0 && c <= 0xef ) { count = 3; - } else if ( c >= '0xf0' && c <= '0xff' ) { + } else if ( c >= 0xf0 && c <= 0xff ) { count = 4; } @@ -395,6 +395,24 @@ void collect_meta( struct cons_pointer stream, char *url ) { cell->payload.stream.meta = meta; } +/** + * Resutn the current default input, or of `inputp` is false, output stream from + * this `env`ironment. + */ +struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer stream_name = + c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); + + inc_ref( stream_name ); + + result = c_assoc( stream_name, env ); + + dec_ref( stream_name ); + + return result; +} + /** * Function: return a stream open on the URL indicated by the first argument; @@ -423,8 +441,8 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE *stream = url_fopen( url, "r" ); debug_printf( DEBUG_IO, - L"lisp_open: stream @ %d, stream type = %d, stream handle = %d\n", - (int) &stream, (int)stream->type, (int)stream->handle.file); + L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n", + (long int) &stream, (int)stream->type, (long int)stream->handle.file); switch (stream->type) { case CFTYPE_NONE: diff --git a/src/io/io.h b/src/io/io.h index 33f733f..f350c13 100644 --- a/src/io/io.h +++ b/src/io/io.h @@ -21,6 +21,8 @@ URL_FILE *file_to_url_file( FILE * f ); wint_t url_fgetwc( URL_FILE * input ); wint_t url_ungetwc( wint_t wc, URL_FILE * input ); +struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ); + struct cons_pointer lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index ee82956..9e956f4 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -35,15 +35,15 @@ bool check_tag( struct cons_pointer pointer, char *tag ) { bool result = false; struct cons_space_object cell = pointer2cell( pointer ); - + result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; if ( result == false ) { - if ( strncmp( &cell.tag.bytes[0], VECTORPOINTTAG, TAGLENGTH ) == 0 ) { + if ( cell.tag.value == VECTORPOINTTV ) { struct vector_space_object *vec = pointer_to_vso( pointer ); if ( vec != NULL ) { - result = strncmp( &vec->header.tag.bytes[0], tag, TAGLENGTH ) == 0; + result = strncmp( &(vec->header.tag.bytes[0]), tag, TAGLENGTH ) == 0; } } } @@ -286,7 +286,7 @@ uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) case KEYTV: case STRINGTV: case SYMBOLTV: - if (nilp(ptr)) + if (nilp(cell->payload.string.cdr)) { result = (uint32_t)c; } @@ -296,6 +296,7 @@ uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) cell->payload.string.hash) & 0xffffffff; } + break; } return result; diff --git a/src/memory/dump.c b/src/memory/dump.c index b992bb2..2dc6658 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -23,6 +23,7 @@ #include "debug.h" #include "hashmap.h" #include "intern.h" +#include "io.h" #include "print.h" #include "stack.h" #include "vectorspace.h" @@ -39,12 +40,14 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, cell.payload.string.cdr.offset, cell.count ); } else { url_fwprintf( output, - L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", + L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", prefix, ( wint_t ) cell.payload.string.character, cell.payload.string.character, + cell.payload.string.hash, cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, cell.count ); + cell.payload.string.cdr.offset, + cell.count ); url_fwprintf( output, L"\t\t value: " ); print( output, pointer ); url_fwprintf( output, L"\n" ); @@ -54,108 +57,105 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, /** * dump the object at this cons_pointer to this output stream. */ -void dump_object( URL_FILE * output, struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - url_fwprintf( output, - 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 ); +void dump_object( URL_FILE *output, struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + url_fwprintf( output, 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 ) { - case CONSTV: - url_fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :", - cell.payload.cons.car.page, - cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset, cell.count ); - print( output, pointer ); - url_fputws( L"\n", output ); - break; - case EXCEPTIONTV: - url_fwprintf( output, L"\t\tException cell: " ); - dump_stack_trace( output, pointer ); - break; - case FREETV: - url_fwprintf( output, - L"\t\tFree cell: next at page %d offset %d\n", - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset ); - break; - case INTEGERTV: - url_fwprintf( output, - L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); - if ( !nilp( cell.payload.integer.more ) ) { - url_fputws( L"\t\tBIGNUM! More at:\n", output ); - dump_object( output, cell.payload.integer.more ); - } - break; - case LAMBDATV: - url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); - print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case NILTV: - break; - case NLAMBDATV: - url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); - print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case RATIOTV: - url_fwprintf( output, - L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); - break; - case READTV: - url_fputws( L"\t\tInput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - case REALTV: - url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", - cell.payload.real.value, cell.count ); - break; - case STRINGTV: - dump_string_cell( output, L"String", pointer ); - break; - case SYMBOLTV: - dump_string_cell( output, L"Symbol", pointer ); - break; - case TRUETV: - break; - case VECTORPOINTTV:{ - url_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; - url_fwprintf( output, - 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 ); + switch ( cell.tag.value ) { + case CONSTV: + url_fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d " + L"offset %d, count %u :", + cell.payload.cons.car.page, cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset, + cell.count ); + print( output, pointer ); + url_fputws( L"\n", output ); + break; + case EXCEPTIONTV: + url_fwprintf( output, L"\t\tException cell: " ); + dump_stack_trace( output, pointer ); + break; + case FREETV: + url_fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", + cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset ); + break; + case INTEGERTV: + url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); + if ( !nilp( cell.payload.integer.more ) ) { + url_fputws( L"\t\tBIGNUM! More at:\n", output ); + dump_object( output, cell.payload.integer.more ); + } + break; + case KEYTV: + dump_string_cell( output, L"Keyword", pointer ); + break; + case LAMBDATV: + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); + print( output, cell.payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case NILTV: + break; + case NLAMBDATV: + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); + print( output, cell.payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case RATIOTV: + url_fwprintf( + output, L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer2cell( cell.payload.ratio.dividend ).payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload.integer.value, + cell.count ); + break; + case READTV: + url_fputws( L"\t\tInput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); + break; + case REALTV: + url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); + break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; + case TRUETV: + break; + case VECTORPOINTTV: { + url_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; + url_fwprintf( output, + L"\t\tVector space object of type %4.4s (%d), payload size " + L"%d bytes\n", + &vso->header.tag.bytes, vso->header.tag.value, + vso->header.size ); - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - dump_frame( output, pointer ); - break; - case HASHTV: - dump_map( output, pointer); - break; - } - } - break; - case WRITETV: - url_fputws( L"\t\tOutput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - } + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + dump_frame( output, pointer ); + break; + case HASHTV: + dump_map( output, pointer ); + break; + } + } break; + case WRITETV: + url_fputws( L"\t\tOutput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); + break; + } } diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index 11a03f0..73d3905 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -12,6 +12,7 @@ #include "authorise.h" #include "debug.h" #include "intern.h" +#include "io/print.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" #include "memory/hashmap.h" diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index b3e64c6..a6e292d 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -119,11 +119,11 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { * object. Dangerous! */ void free_vso( struct cons_pointer pointer ) { - struct cons_space_object * cell = &pointer2cell( pointer); + struct cons_space_object cell = pointer2cell( pointer ); debug_printf( DEBUG_ALLOC, L"About to free vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); - struct vector_space_object *vso = cell->payload.vectorp.address; + cell.payload.vectorp.address ); + struct vector_space_object *vso = cell.payload.vectorp.address; switch ( vso->header.tag.value ) { case HASHTV: @@ -134,7 +134,18 @@ void free_vso( struct cons_pointer pointer ) { break; } - free( (void *)cell->payload.vectorp.address ); +// free( (void *)cell.payload.vectorp.address ); debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); -} \ No newline at end of file + cell.payload.vectorp.address ); +} + +// bool check_vso_tag( struct cons_pointer pointer, char * tag) { +// bool result = false; + +// if (check_tag(pointer, VECTORPOINTTAG)) { +// struct vector_space_object * vso = pointer_to_vso(pointer); +// result = strncmp( vso->header.tag.bytes[0], tag, TAGLENGTH); +// } + +// return result; +// } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 3a972a5..0c495f9 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -854,26 +854,6 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } - -/** - * Resutn the current default input, or of `inputp` is false, output stream from - * this `env`ironment. - */ -struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_pointer stream_name = - c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); - - inc_ref( stream_name ); - - result = c_assoc( stream_name, env ); - - dec_ref( stream_name ); - - return result; -} - - /** * Function; read one complete lisp form and return it. If read-stream is specified and * is a read stream, then read from that stream, else the stream which is the value of @@ -965,6 +945,44 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, return c_reverse( frame->arg[0] ); } +/** + * Function: dump/inspect one complete lisp expression and return NIL. If + * write-stream is specified and is a write stream, then print to that stream, + * else the stream which is the value of + * `*out*` in the environment. + * + * * (inspect expr) + * * (inspect expr write-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (from which the stream may be extracted). + * @return NIL. + */ +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); + struct cons_pointer result = NIL; + struct cons_pointer out_stream = writep( frame->arg[1] ) + ? frame->arg[1] + : get_default_stream( false, env ); + URL_FILE *output; + + if ( writep( out_stream ) ) { + debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + } else { + output = file_to_url_file( stderr ); + } + + dump_object( output, frame->arg[0] ); + + debug_print( L"Leaving lisp_inspect", DEBUG_IO ); + + return result; +} /** * Function; print one complete lisp expression and return NIL. If write-stream is specified and @@ -976,8 +994,8 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, * * @param frame my stack_frame. * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the value of `expr`. + * @param env my environment (from which the stream may be extracted). + * @return NIL. */ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -1332,43 +1350,43 @@ struct cons_pointer lisp_source( struct stack_frame *frame, } -/** - * Function; print the internal representation of the object indicated by `frame->arg[0]` to the - * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. - * - * * (inspect expression) - * * (inspect expression ) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment. - * @return the value of the first argument - `expression`. - */ -struct cons_pointer lisp_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Entering print\n", DEBUG_IO ); - URL_FILE *output; - struct cons_pointer out_stream = writep( frame->arg[1] ) ? - frame->arg[1] : get_default_stream( false, env ); +// /** +// * Function; print the internal representation of the object indicated by `frame->arg[0]` to the +// * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. +// * +// * * (inspect expression) +// * * (inspect expression ) +// * +// * @param frame my stack frame. +// * @param frame_pointer a pointer to my stack_frame. +// * @param env the environment. +// * @return the value of the first argument - `expression`. +// */ +// struct cons_pointer lisp_inspect( struct stack_frame *frame, +// struct cons_pointer frame_pointer, +// struct cons_pointer env ) { +// debug_print( L"Entering print\n", DEBUG_IO ); +// URL_FILE *output; +// struct cons_pointer out_stream = writep( frame->arg[1] ) ? +// frame->arg[1] : get_default_stream( false, env ); - if ( writep( out_stream ) ) { - debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); - debug_dump_object( out_stream, DEBUG_IO ); - output = pointer2cell( out_stream ).payload.stream.stream; - inc_ref( out_stream ); - } else { - output = file_to_url_file( stdout ); - } +// if ( writep( out_stream ) ) { +// debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); +// debug_dump_object( out_stream, DEBUG_IO ); +// output = pointer2cell( out_stream ).payload.stream.stream; +// inc_ref( out_stream ); +// } else { +// output = file_to_url_file( stdout ); +// } - dump_object( output, frame->arg[0] ); - url_fputws( L"\n", output ); +// dump_object( output, frame->arg[0] ); +// url_fputws( L"\n", output ); - if ( writep( out_stream ) ) { - dec_ref( out_stream ); - } else { - free( output ); - } +// if ( writep( out_stream ) ) { +// dec_ref( out_stream ); +// } else { +// free( output ); +// } - return frame->arg[0]; -} +// return frame->arg[0]; +// } diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 4669493..014df2e 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -114,6 +114,9 @@ struct cons_pointer lisp_quote( struct stack_frame *frame, /* * functions */ +struct cons_pointer lisp_assoc( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -123,9 +126,9 @@ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_assoc( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -199,8 +202,4 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - #endif From 93d4bd14a081783c5ff082579ac6fddb159ccc74 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 17 Aug 2021 16:09:00 +0100 Subject: [PATCH 085/101] Generally, changed working with tags as strings to as values. This seems both cheaper and safer; what's not to like? --- Makefile | 5 ++-- src/arith/integer.c | 3 +-- src/arith/ratio.c | 2 +- src/arith/real.c | 2 +- src/io/read.c | 12 ++++----- src/memory/conspage.c | 6 ++--- src/memory/conspage.h | 2 +- src/memory/consspaceobject.c | 40 +++++++++++++-------------- src/memory/consspaceobject.h | 52 ++++++++++++++++++------------------ src/memory/hashmap.c | 13 +++++---- src/memory/stack.c | 2 +- src/memory/vectorspace.c | 12 ++++----- src/memory/vectorspace.h | 8 +++--- src/ops/lispops.c | 2 +- src/time/psse_time.c | 2 +- unit-tests/lambda.sh | 2 +- unit-tests/map.sh | 10 +++---- 17 files changed, 87 insertions(+), 88 deletions(-) diff --git a/Makefile b/Makefile index c4c4ef3..d8e6e81 100644 --- a/Makefile +++ b/Makefile @@ -17,11 +17,12 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm -lcurl +DEBUGFLAGS := -g3 all: $(TARGET) $(TARGET): $(OBJS) Makefile - $(CC) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) + $(CC) $(DEBUGFLAGS) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) doc: $(SRCS) Makefile Doxyfile doxygen @@ -38,7 +39,7 @@ test: $(OBJS) $(TESTS) Makefile .PHONY: clean clean: - $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ + $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ core repl: $(TARGET) -p 2> psse.log diff --git a/src/arith/integer.c b/src/arith/integer.c index e02d30e..5f47532 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -46,11 +46,10 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { debug_print( L"Entering make_integer\n", DEBUG_ALLOC ); if ( integerp( more ) || nilp( more ) ) { - result = allocate_cell( INTEGERTAG ); + result = allocate_cell( INTEGERTV ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; cell->payload.integer.more = more; - } debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 8976e38..f4c8056 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -315,7 +315,7 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, if ( integerp( dividend ) && integerp( divisor ) ) { inc_ref( dividend ); inc_ref( divisor ); - result = allocate_cell( RATIOTAG ); + result = allocate_cell( RATIOTV ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.ratio.dividend = dividend; cell->payload.ratio.divisor = divisor; diff --git a/src/arith/real.c b/src/arith/real.c index 84ba899..a59a125 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -19,7 +19,7 @@ * @return a real number cell wrapping this value. */ struct cons_pointer make_real( long double value ) { - struct cons_pointer result = allocate_cell( REALTAG ); + struct cons_pointer result = allocate_cell( REALTV ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; diff --git a/src/io/read.c b/src/io/read.c index ede44ad..2395cbc 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -49,7 +49,7 @@ struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); -struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag, +struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, wint_t initial ); /** @@ -119,7 +119,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, read_number( frame, frame_pointer, input, c, false ); } else { - result = read_symbol_or_key( input, SYMBOLTAG, c ); + result = read_symbol_or_key( input, SYMBOLTV, c ); } } break; @@ -139,20 +139,20 @@ struct cons_pointer read_continuation( struct stack_frame *frame, debug_print( L"read_continuation: dotted pair; read cdr ", DEBUG_IO); } else { - read_symbol_or_key( input, SYMBOLTAG, c ); + read_symbol_or_key( input, SYMBOLTV, c ); } } break; case ':': result = - read_symbol_or_key( input, KEYTAG, url_fgetwc( input ) ); + read_symbol_or_key( input, KEYTV, url_fgetwc( input ) ); break; default: if ( iswdigit( c ) ) { result = read_number( frame, frame_pointer, input, c, false ); } else if ( iswprint( c ) ) { - result = read_symbol_or_key( input, SYMBOLTAG, c ); + result = read_symbol_or_key( input, SYMBOLTV, c ); } else { result = throw_exception( make_cons( c_string_to_lisp_string @@ -386,7 +386,7 @@ struct cons_pointer read_string( URL_FILE * input, wint_t initial ) { return result; } -struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag, +struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; diff --git a/src/memory/conspage.c b/src/memory/conspage.c index c9c224d..0b4bf7d 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -140,7 +140,7 @@ void free_cell( struct cons_pointer pointer ) { debug_printf( DEBUG_ALLOC, L"Freeing cell " ); debug_dump_object( pointer, DEBUG_ALLOC ); - if ( !check_tag( pointer, FREETAG ) ) { + if ( !check_tag( pointer, FREETV ) ) { if ( cell->count == 0 ) { switch ( cell->tag.value ) { case CONSTV: @@ -209,7 +209,7 @@ void free_cell( struct cons_pointer pointer ) { * return an exception. Which, as we cannot create such an exception when * cons space is exhausted, means we must construct it at init time. */ -struct cons_pointer allocate_cell( char *tag ) { +struct cons_pointer allocate_cell( uint32_t tag ) { struct cons_pointer result = freelist; @@ -222,7 +222,7 @@ struct cons_pointer allocate_cell( char *tag ) { if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) { freelist = cell->payload.free.cdr; - strncpy( &cell->tag.bytes[0], tag, TAGLENGTH ); + cell->tag.value = tag; cell->count = 0; cell->payload.cons.car = NIL; diff --git a/src/memory/conspage.h b/src/memory/conspage.h index 9eab748..260794e 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -55,7 +55,7 @@ extern struct cons_page *conspages[NCONSPAGES]; void free_cell( struct cons_pointer pointer ); -struct cons_pointer allocate_cell( char *tag ); +struct cons_pointer allocate_cell( uint32_t tag ); void initialise_cons_pages( ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 9e956f4..32c777f 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -28,22 +28,22 @@ #include "vectorspace.h" /** - * True if the tag on the cell at this `pointer` is this `tag`, or, if the tag - * of the cell is `VECP`, if the tag of the vectorspace object indicated by the - * cell is this `tag`, else false. + * True if the value of the tag on the cell at this `pointer` is this `value`, + * or, if the tag of the cell is `VECP`, if the value of the tag of the + * vectorspace object indicated by the cell is this `value`, else false. */ -bool check_tag( struct cons_pointer pointer, char *tag ) { +bool check_tag( struct cons_pointer pointer, uint32_t value ) { bool result = false; + struct cons_space_object cell = pointer2cell( pointer ); - - result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; + result = cell.tag.value == value; if ( result == false ) { if ( cell.tag.value == VECTORPOINTTV ) { struct vector_space_object *vec = pointer_to_vso( pointer ); if ( vec != NULL ) { - result = strncmp( &(vec->header.tag.bytes[0]), tag, TAGLENGTH ) == 0; + result = vec->header.tag.value == value; } } } @@ -177,7 +177,7 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ) { struct cons_pointer pointer = NIL; - pointer = allocate_cell( CONSTAG ); + pointer = allocate_cell( CONSTV ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -197,7 +197,7 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer frame_pointer ) { struct cons_pointer result = NIL; - struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); + struct cons_pointer pointer = allocate_cell( EXCEPTIONTV ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( message ); @@ -218,7 +218,7 @@ struct cons_pointer make_function( struct cons_pointer meta, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); + struct cons_pointer pointer = allocate_cell( FUNCTIONTV ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( meta ); @@ -233,7 +233,7 @@ make_function( struct cons_pointer meta, struct cons_pointer ( *executable ) */ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ) { - struct cons_pointer pointer = allocate_cell( LAMBDATAG ); + struct cons_pointer pointer = allocate_cell( LAMBDATV ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ @@ -252,7 +252,7 @@ struct cons_pointer make_lambda( struct cons_pointer args, */ struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ) { - struct cons_pointer pointer = allocate_cell( NLAMBDATAG ); + struct cons_pointer pointer = allocate_cell( NLAMBDATV ); inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ @@ -309,10 +309,10 @@ uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) * pointer to next is NIL. */ struct cons_pointer -make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { +make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { struct cons_pointer pointer = NIL; - if ( check_tag( tail, tag ) || check_tag( tail, NILTAG ) ) { + if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) { pointer = allocate_cell( tag ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -344,7 +344,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { * @param tail the string which is being built. */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { - return make_string_like_thing( c, tail, STRINGTAG ); + return make_string_like_thing( c, tail, STRINGTV ); } /** @@ -356,10 +356,10 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { * @param tag the tag to use: expected to be "SYMB" or "KEYW" */ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, - char *tag ) { + uint32_t tag ) { struct cons_pointer result = make_string_like_thing( c, tail, tag ); - if ( strncmp( tag, KEYTAG, 4 ) == 0 ) { + if ( tag == KEYTV ) { struct cons_pointer r = internedp( result, oblist ); if ( nilp( r ) ) { @@ -379,7 +379,7 @@ struct cons_pointer make_special( struct cons_pointer meta, struct cons_pointer ( *executable ) ( struct stack_frame * frame, struct cons_pointer, struct cons_pointer env ) ) { - struct cons_pointer pointer = allocate_cell( SPECIALTAG ); + struct cons_pointer pointer = allocate_cell( SPECIALTV ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( meta ); @@ -397,7 +397,7 @@ make_special( struct cons_pointer meta, struct cons_pointer ( *executable ) */ struct cons_pointer make_read_stream( URL_FILE * input, struct cons_pointer metadata ) { - struct cons_pointer pointer = allocate_cell( READTAG ); + struct cons_pointer pointer = allocate_cell( READTV ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = input; @@ -414,7 +414,7 @@ struct cons_pointer make_read_stream( URL_FILE * input, */ struct cons_pointer make_write_stream( URL_FILE * output, struct cons_pointer metadata ) { - struct cons_pointer pointer = allocate_cell( WRITETAG ); + struct cons_pointer pointer = allocate_cell( WRITETV ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = output; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 98a5a24..0efa0a6 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -276,114 +276,114 @@ * true if `conspoint` points to the special cell NIL, else false * (there should only be one of these so it's slightly redundant). */ -#define nilp(conspoint) (check_tag(conspoint,NILTAG)) +#define nilp(conspoint) (check_tag(conspoint,NILTV)) /** * true if `conspoint` points to a cons cell, else false */ -#define consp(conspoint) (check_tag(conspoint,CONSTAG)) +#define consp(conspoint) (check_tag(conspoint,CONSTV)) /** * true if `conspoint` points to an exception, else false */ -#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG)) +#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTV)) /** * true if `conspoint` points to a function cell, else false */ -#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) +#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTV)) /** * true if `conspoint` points to a keyword, else false */ -#define keywordp(conspoint) (check_tag(conspoint,KEYTAG)) +#define keywordp(conspoint) (check_tag(conspoint,KEYTV)) /** * true if `conspoint` points to a Lambda binding cell, else false */ -#define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) +#define lambdap(conspoint) (check_tag(conspoint,LAMBDATV)) /** * true if `conspoint` points to a loop exit exception, else false. */ -#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTAG)) +#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTV)) /** * true if `conspoint` points to a special form cell, else false */ -#define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) +#define specialp(conspoint) (check_tag(conspoint,SPECIALTV)) /** * true if `conspoint` points to a string cell, else false */ -#define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) +#define stringp(conspoint) (check_tag(conspoint,STRINGTV)) /** * true if `conspoint` points to a symbol cell, else false */ -#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) +#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTV)) /** * true if `conspoint` points to an integer cell, else false */ -#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) +#define integerp(conspoint) (check_tag(conspoint,INTEGERTV)) /** * true if `conspoint` points to a rational number cell, else false */ -#define ratiop(conspoint) (check_tag(conspoint,RATIOTAG)) +#define ratiop(conspoint) (check_tag(conspoint,RATIOTV)) /** * true if `conspoint` points to a read stream cell, else false */ -#define readp(conspoint) (check_tag(conspoint,READTAG)) +#define readp(conspoint) (check_tag(conspoint,READTV)) /** * true if `conspoint` points to a real number cell, else false */ -#define realp(conspoint) (check_tag(conspoint,REALTAG)) +#define realp(conspoint) (check_tag(conspoint,REALTV)) /** * true if `conspoint` points to some sort of a number cell, * else false */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)) +#define numberp(conspoint) (check_tag(conspoint,INTEGERTV)||check_tag(conspoint,RATIOTV)||check_tag(conspoint,REALTV)) /** * true if `conspoint` points to a sequence (list, string or, later, vector), * else false. */ -#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) +#define sequencep(conspoint) (check_tag(conspoint,CONSTV)||check_tag(conspoint,STRINGTV)||check_tag(conspoint,SYMBOLTV)) /** * true if `conspoint` points to a vector pointer, else false. */ -#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) +#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTV)) /** * true if `conspoint` points to a write stream cell, else false. */ -#define writep(conspoint) (check_tag(conspoint,WRITETAG)) +#define writep(conspoint) (check_tag(conspoint,WRITETV)) -#define streamp(conspoint) (check_tag(conspoint,READTAG)||check_tag(conspoint,WRITETAG)) +#define streamp(conspoint) (check_tag(conspoint,READTV)||check_tag(conspoint,WRITETV)) /** * true if `conspoint` points to a true cell, else false * (there should only be one of these so it's slightly redundant). * Also note that anything that is not NIL is truthy. */ -#define tp(conspoint) (check_tag(conspoint,TRUETAG)) +#define tp(conspoint) (check_tag(conspoint,TRUETV)) /** * true if `conspoint` points to a time cell, else false. */ -#define timep(conspoint) (check_tag(conspoint,TIMETAG)) +#define timep(conspoint) (check_tag(conspoint,TIMETV)) /** * true if `conspoint` points to something that is truthy, i.e. * anything but NIL. */ -#define truep(conspoint) (!check_tag(conspoint,NILTAG)) +#define truep(conspoint) (!check_tag(conspoint,NILTV)) /** * An indirect pointer to a cons cell @@ -673,7 +673,7 @@ struct cons_space_object { } payload; }; -bool check_tag( struct cons_pointer pointer, char *tag ); +bool check_tag( struct cons_pointer pointer, uint32_t value ); struct cons_pointer inc_ref( struct cons_pointer pointer ); @@ -716,11 +716,11 @@ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, - char *tag ); + uint32_t tag ); -#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTAG)) +#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTV)) -#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTAG)) +#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTV)) struct cons_pointer make_read_stream( URL_FILE * input, struct cons_pointer metadata ); diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index 73d3905..ae15461 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -78,17 +78,16 @@ void free_hashmap( struct cons_pointer pointer ) { if ( hashmapp( pointer ) ) { struct vector_space_object *vso = cell->payload.vectorp.address; - struct hashmap_payload payload = vso->payload.hashmap; - dec_ref( payload.hash_fn ); - dec_ref( payload.write_acl ); + dec_ref( vso->payload.hashmap.hash_fn ); + dec_ref( vso->payload.hashmap.write_acl ); - for ( int i = 0; i < payload.n_buckets; i++ ) { - if ( !nilp( payload.buckets[i] ) ) { + for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) { + if ( !nilp( vso->payload.hashmap.buckets[i] ) ) { debug_printf( DEBUG_ALLOC, L"Decrementing bucket [%d] of hashmap at 0x%lx\n", i, cell->payload.vectorp.address ); - dec_ref( payload.buckets[i] ); + dec_ref( vso->payload.hashmap.buckets[i] ); } } } else { @@ -114,7 +113,7 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn, struct cons_pointer write_acl ) { struct cons_pointer result = - make_vso( HASHTAG, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + + make_vso( HASHTV, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + ( sizeof( uint32_t ) * 2 ) ); struct hashmap_payload *payload = diff --git a/src/memory/stack.c b/src/memory/stack.c index e26bd0e..8b0e610 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -75,7 +75,7 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { struct cons_pointer make_empty_frame( struct cons_pointer previous ) { debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC ); struct cons_pointer result = - make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) ); + make_vso( STACKFRAMETV, sizeof( struct stack_frame ) ); debug_dump_object( result, DEBUG_ALLOC ); diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index a6e292d..02fd239 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -33,15 +33,15 @@ * * @address the address of the vector_space_object to point to. * @tag the vector-space tag of the particular type of vector-space object, - * NOT `VECTORPOINTTAG`. + * NOT `VECTORPOINTTV`. * * @return a cons_pointer to the object, or NIL if the object could not be * allocated due to memory exhaustion. */ struct cons_pointer make_vec_pointer( struct vector_space_object *address, - char *tag ) { + uint32_t tag ) { debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); - struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); + struct cons_pointer pointer = allocate_cell( VECTORPOINTTV ); struct cons_space_object *cell = &pointer2cell( pointer ); debug_printf( DEBUG_ALLOC, @@ -49,7 +49,7 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address, address ); cell->payload.vectorp.address = address; - strncpy( &cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH ); + cell->payload.vectorp.tag.value = tag; debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", @@ -71,7 +71,7 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address, * @return a cons_pointer to the object, or NIL if the object could not be * allocated due to memory exhaustion. */ -struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { +struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) { 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; @@ -87,7 +87,7 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { 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 ); + vso->header.tag.value = tag; result = make_vec_pointer( vso, tag ); debug_dump_object( result, DEBUG_ALLOC ); vso->header.vecp = result; diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 2c163e8..2eea84d 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -29,7 +29,7 @@ #define HASHTAG "HASH" #define HASHTV 1213415752 -#define hashmapp(conspoint)((check_tag(conspoint,HASHTAG))) +#define hashmapp(conspoint)((check_tag(conspoint,HASHTV))) /* * a namespace (i.e. a binding of names to values, implemented as a hashmap) @@ -39,7 +39,7 @@ #define NAMESPACETAG "NMSP" #define NAMESPACETV 1347636558 -#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETAG)) +#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETV)) /* * a vector of cons pointers. @@ -47,7 +47,7 @@ #define VECTORTAG "VECT" #define VECTORTV 1413694806 -#define vectorp(conspoint)(check_tag(conspoint,VECTORTAG)) +#define vectorp(conspoint)(check_tag(conspoint,VECTORTV)) /** * given a pointer to a vector space object, return the object. @@ -59,7 +59,7 @@ */ #define vso_get_vecp(vso)((((vector_space_object)vso)->header.vecp)) -struct cons_pointer make_vso( char *tag, uint64_t payload_size ); +struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ); void free_vso(struct cons_pointer pointer); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 0c495f9..474784d 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -920,7 +920,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) { case SYMBOLTV: result = make_symbol_or_key( o.payload.string.character, result, - SYMBOLTAG ); + SYMBOLTV ); break; } } diff --git a/src/time/psse_time.c b/src/time/psse_time.c index 76f52a9..e37e522 100644 --- a/src/time/psse_time.c +++ b/src/time/psse_time.c @@ -56,7 +56,7 @@ unsigned __int128 unix_time_to_lisp_time( time_t t) { } struct cons_pointer make_time( struct cons_pointer integer_or_nil) { - struct cons_pointer pointer = allocate_cell( TIMETAG ); + struct cons_pointer pointer = allocate_cell( TIMETV ); struct cons_space_object *cell = &pointer2cell( pointer ); if (integerp(integer_or_nil)) { diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh index b7f1707..9695e6c 100755 --- a/unit-tests/lambda.sh +++ b/unit-tests/lambda.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(lambda (l) l) (1 2 3 4 5 6 7 8 9 10)' +expected=' (1 2 3 4 5 6 7 8 9 10)' output=`target/psse 2>/dev/null < Date: Tue, 17 Aug 2021 16:37:04 +0100 Subject: [PATCH 086/101] Restandardised formatting. --- src/arith/integer.c | 85 +- src/arith/integer.h | 18 +- src/arith/peano.c | 49 +- src/arith/peano.h | 2 +- src/arith/ratio.c | 80 +- src/arith/ratio.h | 2 +- src/authorise.c | 8 +- src/authorise.h | 5 +- src/init.c | 57 +- src/io/fopen.c | 2 +- src/io/io.c | 36 +- src/io/print.c | 88 +- src/io/read.c | 83 +- src/memory/conspage.c | 2 +- src/memory/consspaceobject.c | 142 ++- src/memory/consspaceobject.h | 2 +- src/memory/dump.c | 207 ++--- src/memory/hashmap.c | 369 ++++---- src/memory/hashmap.h | 6 +- src/memory/lookup3.c | 1594 ++++++++++++++++++++-------------- src/memory/lookup3.h | 5 +- src/memory/vectorspace.c | 28 +- src/memory/vectorspace.h | 24 +- src/ops/equal.c | 169 ++-- src/ops/intern.c | 45 +- src/ops/lispops.c | 295 +++---- src/ops/lispops.h | 4 +- src/time/psse_time.c | 51 +- src/time/psse_time.h | 7 +- 29 files changed, 1861 insertions(+), 1604 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 5f47532..db486d2 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -218,18 +218,19 @@ struct cons_pointer base_partial( int depth ) { /** * destructively modify this `partial` by appending this `digit`. */ -struct cons_pointer append_digit( struct cons_pointer partial, struct cons_pointer digit) { +struct cons_pointer append_digit( struct cons_pointer partial, + struct cons_pointer digit ) { struct cons_pointer c = partial; struct cons_pointer result = partial; - if (nilp( partial)) { + if ( nilp( partial ) ) { result = digit; } else { - while ( !nilp( pointer2cell(c).payload.integer.more)) { - c = pointer2cell(c).payload.integer.more; + while ( !nilp( pointer2cell( c ).payload.integer.more ) ) { + c = pointer2cell( c ).payload.integer.more; } - (&pointer2cell(c))->payload.integer.more = digit; + ( &pointer2cell( c ) )->payload.integer.more = digit; } return result; } @@ -248,8 +249,8 @@ struct cons_pointer append_digit( struct cons_pointer partial, struct cons_point * @param b an integer. */ struct cons_pointer multiply_integers( struct cons_pointer a, - struct cons_pointer b ) { - struct cons_pointer result = make_integer( 0, NIL); + struct cons_pointer b ) { + struct cons_pointer result = make_integer( 0, NIL ); bool neg = is_negative( a ) != is_negative( b ); bool is_first_b = true; int i = 0; @@ -264,7 +265,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, /* for each digit in a, starting with the least significant (ai) */ for ( struct cons_pointer ai = a; !nilp( ai ); - ai = pointer2cell(ai).payload.integer.more) { + ai = pointer2cell( ai ).payload.integer.more ) { /* set carry to 0 */ __int128_t carry = 0; @@ -274,41 +275,41 @@ struct cons_pointer multiply_integers( struct cons_pointer a, /* for each digit in b, starting with the least significant (bj) */ for ( struct cons_pointer bj = b; !nilp( bj ); - bj = pointer2cell(bj).payload.integer.more) { + bj = pointer2cell( bj ).payload.integer.more ) { debug_printf( DEBUG_ARITH, - L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n", - pointer2cell(ai).payload.integer.value, - pointer2cell(bj).payload.integer.value, i); + L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n", + pointer2cell( ai ).payload.integer.value, + pointer2cell( bj ).payload.integer.value, i ); /* multiply ai with bj and add the carry, resulting in a * value xj which may exceed one digit */ - __int128_t xj = pointer2cell(ai).payload.integer.value * - pointer2cell(bj).payload.integer.value; + __int128_t xj = pointer2cell( ai ).payload.integer.value * + pointer2cell( bj ).payload.integer.value; xj += carry; /* if xj exceeds one digit, break it into the digit dj and * the carry */ carry = xj >> 60; - struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL); + struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL ); /* destructively modify ri by appending dj */ - ri = append_digit( ri, dj); - } /* end for bj */ + ri = append_digit( ri, dj ); + } /* end for bj */ /* if carry is not equal to zero, append it as a final digit * to ri */ - if (carry != 0) { - ri = append_digit( ri, make_integer( carry, NIL)); + if ( carry != 0 ) { + ri = append_digit( ri, make_integer( carry, NIL ) ); } /* add ri to result */ - result = add_integers( result, ri); + result = add_integers( result, ri ); debug_print( L"multiply_integers: result is ", DEBUG_ARITH ); debug_print_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); - } /* end for ai */ + } /* end for ai */ } debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); @@ -342,13 +343,16 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, * to be looking to the next. H'mmmm. */ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, - int base ) { + int base ) { struct cons_pointer result = NIL; if ( integerp( int_pointer ) ) { - struct cons_pointer next = pointer2cell( int_pointer ).payload.integer.more; - __int128_t accumulator = llabs( pointer2cell( int_pointer ).payload.integer.value ); - bool is_negative = pointer2cell( int_pointer ).payload.integer.value < 0; + struct cons_pointer next = + pointer2cell( int_pointer ).payload.integer.more; + __int128_t accumulator = + llabs( pointer2cell( int_pointer ).payload.integer.value ); + bool is_negative = + pointer2cell( int_pointer ).payload.integer.value < 0; int digits = 0; if ( accumulator == 0 && nilp( next ) ) { @@ -356,13 +360,14 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, } else { while ( accumulator > 0 || !nilp( next ) ) { if ( accumulator < MAX_INTEGER && !nilp( next ) ) { - accumulator += (pointer2cell(next).payload.integer.value << 60); - next = pointer2cell(next).payload.integer.more; + accumulator += + ( pointer2cell( next ).payload.integer.value << 60 ); + next = pointer2cell( next ).payload.integer.more; } int offset = ( int ) ( accumulator % base ); debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", - offset, hex_digits[offset] ); + L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", + offset, hex_digits[offset] ); debug_print_128bit( accumulator, DEBUG_IO ); debug_print( L"; result is: ", DEBUG_IO ); debug_print_object( result, DEBUG_IO ); @@ -374,7 +379,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, } if ( stringp( result ) - && pointer2cell( result ).payload.string.character == L',' ) { + && pointer2cell( result ).payload.string.character == L',' ) { /* if the number of digits in the string is divisible by 3, there will be * an unwanted comma on the front. */ result = pointer2cell( result ).payload.string.cdr; @@ -393,14 +398,15 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, /** * true if a and be are both integers whose value is the same value. */ -bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) { +bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) { bool result = false; - if (integerp(a) && integerp(b)){ + if ( integerp( a ) && integerp( b ) ) { struct cons_space_object *cell_a = &pointer2cell( a ); struct cons_space_object *cell_b = &pointer2cell( b ); - result = cell_a->payload.integer.value == cell_b->payload.integer.value; + result = + cell_a->payload.integer.value == cell_b->payload.integer.value; } return result; @@ -410,17 +416,16 @@ bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) { * true if `a` is an integer, and `b` is a real number whose value is the * value of that integer. */ -bool equal_integer_real(struct cons_pointer a, struct cons_pointer b) { +bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) { bool result = false; - if (integerp(a) && realp(b)) - { - long double bv = pointer2cell(b).payload.real.value; + if ( integerp( a ) && realp( b ) ) { + long double bv = pointer2cell( b ).payload.real.value; - if (floor(bv) == bv) { - result = pointer2cell(a).payload.integer.value == (int64_t)bv; + if ( floor( bv ) == bv ) { + result = pointer2cell( a ).payload.integer.value == ( int64_t ) bv; } } return result; -} \ No newline at end of file +} diff --git a/src/arith/integer.h b/src/arith/integer.h index 4ce58d5..09a7a83 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -14,19 +14,19 @@ #include #include -struct cons_pointer make_integer(int64_t value, struct cons_pointer more); +struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); -struct cons_pointer add_integers(struct cons_pointer a, - struct cons_pointer b); +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ); -struct cons_pointer multiply_integers(struct cons_pointer a, - struct cons_pointer b); +struct cons_pointer multiply_integers( struct cons_pointer a, + struct cons_pointer b ); -struct cons_pointer integer_to_string(struct cons_pointer int_pointer, - int base); +struct cons_pointer integer_to_string( struct cons_pointer int_pointer, + int base ); -bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b); +bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ); -bool equal_integer_real(struct cons_pointer a, struct cons_pointer b); +bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index 8fe63fb..5589f1f 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -247,8 +247,7 @@ struct cons_pointer add_2( struct stack_frame *frame, result = add_integers( arg1, arg2 ); break; case RATIOTV: - result = - add_integer_ratio( arg1, arg2 ); + result = add_integer_ratio( arg1, arg2 ); break; case REALTV: result = @@ -268,8 +267,7 @@ struct cons_pointer add_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = - add_integer_ratio( arg2, arg1 ); + result = add_integer_ratio( arg2, arg1 ); break; case RATIOTV: result = add_ratio_ratio( arg1, arg2 ); @@ -380,9 +378,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = multiply_integers( arg1, arg2 ); break; case RATIOTV: - result = - multiply_integer_ratio( arg1, - arg2 ); + result = multiply_integer_ratio( arg1, arg2 ); break; case REALTV: result = @@ -405,13 +401,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = - multiply_integer_ratio( arg2, - arg1 ); + result = multiply_integer_ratio( arg2, arg1 ); break; case RATIOTV: - result = - multiply_ratio_ratio( arg1, arg2 ); + result = multiply_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -564,20 +557,18 @@ struct cons_pointer subtract_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV:{ - struct cons_pointer i = - negative( arg2 ); + struct cons_pointer i = negative( arg2 ); inc_ref( i ); result = add_integers( arg1, i ); dec_ref( i ); } break; case RATIOTV:{ - struct cons_pointer tmp = - make_ratio( arg1, - make_integer( 1, NIL ) ); + struct cons_pointer tmp = make_ratio( arg1, + make_integer( 1, + NIL ) ); inc_ref( tmp ); - result = - subtract_ratio_ratio( tmp, arg2 ); + result = subtract_ratio_ratio( tmp, arg2 ); dec_ref( tmp ); } break; @@ -599,12 +590,11 @@ struct cons_pointer subtract_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV:{ - struct cons_pointer tmp = - make_ratio( arg2, - make_integer( 1, NIL ) ); + struct cons_pointer tmp = make_ratio( arg2, + make_integer( 1, + NIL ) ); inc_ref( tmp ); - result = - subtract_ratio_ratio( arg1, tmp ); + result = subtract_ratio_ratio( arg1, tmp ); dec_ref( tmp ); } break; @@ -696,9 +686,7 @@ struct cons_pointer lisp_divide( struct struct cons_pointer ratio = make_ratio( frame->arg[0], one ); inc_ref( ratio ); - result = - divide_ratio_ratio( ratio, - frame->arg[1] ); + result = divide_ratio_ratio( ratio, frame->arg[1] ); dec_ref( ratio ); } break; @@ -725,17 +713,14 @@ struct cons_pointer lisp_divide( struct struct cons_pointer ratio = make_ratio( frame->arg[1], one ); inc_ref( ratio ); - result = - divide_ratio_ratio( frame->arg[0], - ratio ); + result = divide_ratio_ratio( frame->arg[0], ratio ); dec_ref( ratio ); dec_ref( one ); } break; case RATIOTV: result = - divide_ratio_ratio( frame->arg[0], - frame->arg[1] ); + divide_ratio_ratio( frame->arg[0], frame->arg[1] ); break; case REALTV: result = diff --git a/src/arith/peano.h b/src/arith/peano.h index 9bcd9e4..3076391 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -27,7 +27,7 @@ struct cons_pointer absolute( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg ); -int64_t to_long_int( struct cons_pointer arg ) ; +int64_t to_long_int( struct cons_pointer arg ); struct cons_pointer lisp_absolute( struct stack_frame *frame, struct cons_pointer frame_pointer, struct diff --git a/src/arith/ratio.c b/src/arith/ratio.c index f4c8056..8100ec2 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -43,42 +43,36 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { return m / greatest_common_divisor( m, n ) * n; } -struct cons_pointer simplify_ratio( struct cons_pointer pointer) { +struct cons_pointer simplify_ratio( struct cons_pointer pointer ) { struct cons_pointer result = pointer; - struct cons_space_object cell = pointer2cell(pointer); - struct cons_space_object dividend = pointer2cell(cell.payload.ratio.dividend); - struct cons_space_object divisor = pointer2cell(cell.payload.ratio.divisor); + struct cons_space_object cell = pointer2cell( pointer ); + struct cons_space_object dividend = + pointer2cell( cell.payload.ratio.dividend ); + struct cons_space_object divisor = + pointer2cell( cell.payload.ratio.divisor ); - if (divisor.payload.integer.value == 1) - { - result = pointer2cell(pointer).payload.ratio.dividend; - } - else - { - if (ratiop(pointer)) - { + if ( divisor.payload.integer.value == 1 ) { + result = pointer2cell( pointer ).payload.ratio.dividend; + } else { + if ( ratiop( pointer ) ) { int64_t ddrv = dividend.payload.integer.value, - drrv = divisor.payload.integer.value, - gcd = greatest_common_divisor(ddrv, drrv); + drrv = divisor.payload.integer.value, + gcd = greatest_common_divisor( ddrv, drrv ); - if (gcd > 1) - { - if (drrv / gcd == 1) - { - result = make_integer(ddrv / gcd, NIL); - } - else - { + if ( gcd > 1 ) { + if ( drrv / gcd == 1 ) { + result = make_integer( ddrv / gcd, NIL ); + } else { result = - make_ratio(make_integer(ddrv / gcd, NIL), - make_integer(drrv / gcd, NIL)); + make_ratio( make_integer( ddrv / gcd, NIL ), + make_integer( drrv / gcd, NIL ) ); } } } } return result; - + } @@ -181,8 +175,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, ( L"Shouldn't happen: bad arg to add_integer_ratio" ), make_cons( intarg, make_cons( ratarg, - NIL ) ) ), - NIL ); + NIL ) ) ), NIL ); } return result; @@ -196,11 +189,10 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, */ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - // TODO: this now has to work if `arg1` is an integer - struct cons_pointer i = make_ratio( pointer2cell( arg2 ).payload. - ratio.divisor, - pointer2cell( arg2 ).payload. - ratio.dividend ), result = + // TODO: this now has to work if `arg1` is an integer + struct cons_pointer i = + make_ratio( pointer2cell( arg2 ).payload.ratio.divisor, + pointer2cell( arg2 ).payload.ratio.dividend ), result = multiply_ratio_ratio( arg1, i ); dec_ref( i ); @@ -217,7 +209,7 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - // TODO: this now has to work if arg1 is an integer + // TODO: this now has to work if arg1 is an integer struct cons_pointer result; debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH ); @@ -294,7 +286,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, */ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = negative( arg2), + struct cons_pointer i = negative( arg2 ), result = add_ratio_ratio( arg1, i ); dec_ref( i ); @@ -333,20 +325,18 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, /** * True if a and be are identical ratios, else false. */ -bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b) -{ +bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) { bool result = false; - if (ratiop(a) && ratiop(b)) - { - struct cons_space_object *cell_a = &pointer2cell(a); - struct cons_space_object *cell_b = &pointer2cell(b); + if ( ratiop( a ) && ratiop( b ) ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); - result = equal_integer_integer(cell_a->payload.ratio.dividend, - cell_b->payload.ratio.dividend) && - equal_integer_integer(cell_a->payload.ratio.divisor, - cell_b->payload.ratio.divisor); + result = equal_integer_integer( cell_a->payload.ratio.dividend, + cell_b->payload.ratio.dividend ) && + equal_integer_integer( cell_a->payload.ratio.divisor, + cell_b->payload.ratio.divisor ); } return result; -} \ No newline at end of file +} diff --git a/src/arith/ratio.h b/src/arith/ratio.h index d440530..9068bfb 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -34,6 +34,6 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer divisor ); -bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b); +bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ); #endif diff --git a/src/authorise.c b/src/authorise.c index 5574db9..afd730d 100644 --- a/src/authorise.c +++ b/src/authorise.c @@ -15,10 +15,10 @@ * TODO: does nothing, yet. What it should do is access a magic value in the * runtime environment and check that it is identical to something on this `acl` */ -struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl) { - if (nilp(acl)) { - acl = pointer2cell(target).access; +struct cons_pointer authorised( struct cons_pointer target, + struct cons_pointer acl ) { + if ( nilp( acl ) ) { + acl = pointer2cell( target ).access; } return TRUE; } - diff --git a/src/authorise.h b/src/authorise.h index c67977d..6c55b32 100644 --- a/src/authorise.h +++ b/src/authorise.h @@ -10,6 +10,7 @@ #ifndef __psse_authorise_h #define __psse_authorise_h -struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl); +struct cons_pointer authorised( struct cons_pointer target, + struct cons_pointer acl ); -#endif \ No newline at end of file +#endif diff --git a/src/init.c b/src/init.c index 4126783..ca48b9d 100644 --- a/src/init.c +++ b/src/init.c @@ -84,8 +84,9 @@ void bind_value( wchar_t *name, struct cons_pointer value ) { dec_ref( n ); } -void print_banner() { - fwprintf(stdout, L"Post-Scarcity Software Environment version %s\n\n", VERSION); +void print_banner( ) { + fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", + VERSION ); } /** @@ -93,22 +94,24 @@ void print_banner() { * * @stream the stream to print to. */ -void print_options(FILE* stream) { - fwprintf(stream, L"Expected options are:\n"); - fwprintf(stream, L"\t-d\tDump memory to standard out at end of run (copious!);\n"); - fwprintf(stream, L"\t-h\tPrint this message and exit;\n"); - fwprintf(stream, L"\t-p\tShow a prompt (default is no prompt);\n"); - fwprintf(stream, L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n"); - fwprintf(stream, L"\t\tWhere bits are interpreted as follows:\n"); - fwprintf(stream, L"\t\t1\tALLOC;\n"); - fwprintf(stream, L"\t\t2\tARITH;\n"); - fwprintf(stream, L"\t\t4\tBIND;\n"); - fwprintf(stream, L"\t\t8\tBOOTSTRAP;\n"); - fwprintf(stream, L"\t\t16\tEVAL;\n"); - fwprintf(stream, L"\t\t32\tINPUT/OUTPUT;\n"); - fwprintf(stream, L"\t\t64\tLAMBDA;\n"); - fwprintf(stream, L"\t\t128\tREPL;\n"); - fwprintf(stream, L"\t\t256\tSTACK.\n"); +void print_options( FILE * stream ) { + fwprintf( stream, L"Expected options are:\n" ); + fwprintf( stream, + L"\t-d\tDump memory to standard out at end of run (copious!);\n" ); + fwprintf( stream, L"\t-h\tPrint this message and exit;\n" ); + fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" ); + fwprintf( stream, + L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" ); + fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" ); + fwprintf( stream, L"\t\t1\tALLOC;\n" ); + fwprintf( stream, L"\t\t2\tARITH;\n" ); + fwprintf( stream, L"\t\t4\tBIND;\n" ); + fwprintf( stream, L"\t\t8\tBOOTSTRAP;\n" ); + fwprintf( stream, L"\t\t16\tEVAL;\n" ); + fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" ); + fwprintf( stream, L"\t\t64\tLAMBDA;\n" ); + fwprintf( stream, L"\t\t128\tREPL;\n" ); + fwprintf( stream, L"\t\t256\tSTACK.\n" ); } /** @@ -132,8 +135,8 @@ int main( int argc, char *argv[] ) { dump_at_end = true; break; case 'h': - print_banner(); - print_options(stdout); + print_banner( ); + print_options( stdout ); exit( 0 ); break; case 'p': @@ -144,14 +147,14 @@ int main( int argc, char *argv[] ) { break; default: fwprintf( stderr, L"Unexpected option %c\n", option ); - print_options(stderr); + print_options( stderr ); exit( 1 ); break; } } if ( show_prompt ) { - print_banner(); + print_banner( ); } debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP ); @@ -225,10 +228,10 @@ int main( int argc, char *argv[] ) { bind_function( L"equal", &lisp_equal ); bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); - bind_function( L"get-hash", &lisp_get_hash); - bind_function(L"hashmap", lisp_make_hashmap); + bind_function( L"get-hash", &lisp_get_hash ); + bind_function( L"hashmap", lisp_make_hashmap ); bind_function( L"inspect", &lisp_inspect ); - bind_function( L"keys", &lisp_keys); + bind_function( L"keys", &lisp_keys ); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); bind_function( L"multiply", &lisp_multiply ); @@ -237,8 +240,8 @@ int main( int argc, char *argv[] ) { bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); - bind_function( L"put", lisp_hashmap_put); - bind_function( L"put-all", &lisp_hashmap_put_all); + bind_function( L"put", lisp_hashmap_put ); + bind_function( L"put-all", &lisp_hashmap_put_all ); bind_function( L"read", &lisp_read ); bind_function( L"read-char", &lisp_read_char ); bind_function( L"repl", &lisp_repl ); diff --git a/src/io/fopen.c b/src/io/fopen.c index d3ece5c..3a66806 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -213,7 +213,7 @@ URL_FILE *url_fopen( const char *url, const char *operation ) { file->handle.file = fopen( url, operation ); if ( file->handle.file ) { file->type = CFTYPE_FILE; /* marked as file */ - } else if ( index_of(':', url ) > -1 ) { + } else if ( index_of( ':', url ) > -1 ) { file->type = CFTYPE_CURL; /* marked as URL */ file->handle.curl = curl_easy_init( ); diff --git a/src/io/io.c b/src/io/io.c index 9976373..f621539 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -265,7 +265,7 @@ struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key, struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, char *value ) { - value = trim( value); + value = trim( value ); wchar_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); @@ -280,9 +280,8 @@ struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key, char datestring[256]; strftime( datestring, - sizeof( datestring ), - nl_langinfo( D_T_FMT ), - localtime( value ) ); + sizeof( datestring ), + nl_langinfo( D_T_FMT ), localtime( value ) ); return add_meta_string( meta, key, datestring ); } @@ -391,7 +390,7 @@ void collect_meta( struct cons_pointer stream, char *url ) { } /* this is destructive change before the cell is released into the - * wild, and consequently permissible, just. */ + * wild, and consequently permissible, just. */ cell->payload.stream.meta = meta; } @@ -441,20 +440,23 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE *stream = url_fopen( url, "r" ); debug_printf( DEBUG_IO, - L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n", - (long int) &stream, (int)stream->type, (long int)stream->handle.file); + L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n", + ( long int ) &stream, ( int ) stream->type, + ( long int ) stream->handle.file ); - switch (stream->type) { + switch ( stream->type ) { case CFTYPE_NONE: - return make_exception( - c_string_to_lisp_string( L"Could not open stream"), - frame_pointer); + return + make_exception( c_string_to_lisp_string + ( L"Could not open stream" ), + frame_pointer ); break; case CFTYPE_FILE: - if (stream->handle.file == NULL) { - return make_exception( - c_string_to_lisp_string( L"Could not open file"), - frame_pointer); + if ( stream->handle.file == NULL ) { + return + make_exception( c_string_to_lisp_string + ( L"Could not open file" ), + frame_pointer ); } break; case CFTYPE_CURL: @@ -501,8 +503,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload. - stream.stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); } return result; diff --git a/src/io/print.c b/src/io/print.c index 3f33252..64d7b37 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -88,38 +88,38 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) { url_fputws( L")", output ); } -void print_map( URL_FILE *output, struct cons_pointer map ) { - if ( hashmapp( map ) ) { - struct vector_space_object *vso = pointer_to_vso( map ); +void print_map( URL_FILE * output, struct cons_pointer map ) { + if ( hashmapp( map ) ) { + struct vector_space_object *vso = pointer_to_vso( map ); - url_fputwc( btowc( '{' ), output ); + url_fputwc( btowc( '{' ), output ); - for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); - ks = c_cdr( ks ) ) { - struct cons_pointer key = c_car( ks); - print( output, key ); - url_fputwc( btowc( ' ' ), output ); - print( output, hashmap_get( map, key ) ); + for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); + ks = c_cdr( ks ) ) { + struct cons_pointer key = c_car( ks ); + print( output, key ); + url_fputwc( btowc( ' ' ), output ); + print( output, hashmap_get( map, key ) ); - if ( !nilp( c_cdr( ks ) ) ) { - url_fputws( L", ", output ); - } + if ( !nilp( c_cdr( ks ) ) ) { + url_fputws( L", ", output ); + } + } + + url_fputwc( btowc( '}' ), output ); } - - url_fputwc( btowc( '}' ), output ); - } } -void print_vso( URL_FILE * output, struct cons_pointer pointer) { - struct vector_space_object *vso = pointer_to_vso(pointer); - switch ( vso->header.tag.value) { +void print_vso( URL_FILE * output, struct cons_pointer pointer ) { + struct vector_space_object *vso = pointer_to_vso( pointer ); + switch ( vso->header.tag.value ) { case HASHTV: - print_map( output, pointer); + print_map( output, pointer ); break; - // \todo: others. + // \todo: others. default: - fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", - vso->header.tag.value ); + fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", + vso->header.tag.value ); } } @@ -130,14 +130,14 @@ void print_128bit( URL_FILE * output, __int128_t n ) { if ( n == 0 ) { fwprintf( stderr, L"0" ); } else { - char str[40] = { 0 }; // log10(1 << 128) + '\0' + char str[40] = { 0 }; // log10(1 << 128) + '\0' char *s = str + sizeof( str ) - 1; // start at the end while ( n != 0 ) { if ( s == str ) - return; // never happens + return; // never happens *--s = "0123456789"[n % 10]; // save last digit - n /= 10; // drop it + n /= 10; // drop it } url_fwprintf( output, L"%s", s ); } @@ -165,9 +165,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { dump_stack_trace( output, pointer ); break; case FUNCTIONTV: - url_fputws( L"', output); + url_fputws( L"', output ); break; case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); @@ -181,7 +181,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_string_contents( output, pointer ); break; case LAMBDATV:{ - url_fputws( L"', output); + url_fputwc( L'>', output ); } break; case NILTV: url_fwprintf( output, L"nil" ); break; case NLAMBDATV:{ - url_fputws( L"', output); + url_fputwc( L'>', output ); } break; case RATIOTV: @@ -218,8 +218,8 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; case READTV: url_fwprintf( output, L"', output); + print( output, cell.payload.stream.meta ); + url_fputwc( L'>', output ); break; case REALTV: /* \todo using the C heap is a bad plan because it will fragment. @@ -245,26 +245,26 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; case SPECIALTV: url_fwprintf( output, L"', output); + print( output, cell.payload.special.meta ); + url_fputwc( L'>', output ); break; case TIMETV: url_fwprintf( output, L"', output); + print_string( output, time_to_string( pointer ) ); + url_fputws( L"; ", output ); + print_128bit( output, pointer2cell( pointer ).payload.time.value ); + url_fputwc( L'>', output ); break; case TRUETV: url_fwprintf( output, L"t" ); break; case VECTORPOINTTV: - print_vso( output, pointer); + print_vso( output, pointer ); break; case WRITETV: url_fwprintf( output, L"', output); + print( output, cell.payload.stream.meta ); + url_fputwc( L'>', output ); break; default: fwprintf( stderr, diff --git a/src/io/read.c b/src/io/read.c index 2395cbc..9c87932 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -46,8 +46,8 @@ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE * input, wint_t initial ); struct cons_pointer read_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - URL_FILE * input, wint_t initial ); + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, wint_t initial ); @@ -106,7 +106,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, break; case '{': result = read_map( frame, frame_pointer, input, - url_fgetwc( input ) ); + url_fgetwc( input ) ); break; case '"': result = read_string( input, url_fgetwc( input ) ); @@ -134,10 +134,12 @@ struct cons_pointer read_continuation( struct stack_frame *frame, } else if ( iswblank( next ) ) { /* dotted pair. \todo this isn't right, we * really need to backtrack up a level. */ - result = read_continuation( frame, frame_pointer, input, + result = + read_continuation( frame, frame_pointer, input, url_fgetwc( input ) ); - debug_print( L"read_continuation: dotted pair; read cdr ", - DEBUG_IO); + debug_print + ( L"read_continuation: dotted pair; read cdr ", + DEBUG_IO ); } else { read_symbol_or_key( input, SYMBOLTV, c ); } @@ -284,37 +286,34 @@ struct cons_pointer read_number( struct stack_frame *frame, * left parenthesis. */ struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - URL_FILE * input, wint_t initial ) { + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ) { struct cons_pointer result = NIL; wint_t c; if ( initial != ')' ) { debug_printf( DEBUG_IO, - L"read_list starting '%C' (%d)\n", initial, initial ); + L"read_list starting '%C' (%d)\n", initial, initial ); struct cons_pointer car = read_continuation( frame, frame_pointer, input, - initial ); + initial ); /* skip whitespace */ - for (c = url_fgetwc( input ); - iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input )); + for ( c = url_fgetwc( input ); + iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) ); - if ( c == L'.') { + if ( c == L'.' ) { /* might be a dotted pair; indeed, if we rule out numbers with * initial periods, it must be a dotted pair. \todo Ought to check, * howerver, that there's only one form after the period. */ result = make_cons( car, - c_car( read_list( frame, - frame_pointer, - input, - url_fgetwc( input ) ) ) ); + c_car( read_list( frame, + frame_pointer, + input, url_fgetwc( input ) ) ) ); } else { result = - make_cons( car, - read_list( frame, frame_pointer, input, c ) ); + make_cons( car, read_list( frame, frame_pointer, input, c ) ); } } else { debug_print( L"End of list detected\n", DEBUG_IO ); @@ -325,35 +324,35 @@ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer frame_pointer, - URL_FILE *input, wint_t initial ) { - // set write ACL to true whilst creating to prevent GC churn - struct cons_pointer result = make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE ); - wint_t c = initial; + URL_FILE * input, wint_t initial ) { + // set write ACL to true whilst creating to prevent GC churn + struct cons_pointer result = + make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE ); + wint_t c = initial; - while ( c != L'}' ) { - struct cons_pointer key = - read_continuation( frame, frame_pointer, input, c ); + while ( c != L'}' ) { + struct cons_pointer key = + read_continuation( frame, frame_pointer, input, c ); - /* skip whitespace */ - for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input ) ) - ; + /* skip whitespace */ + for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ); - struct cons_pointer value = - read_continuation( frame, frame_pointer, input, c ); + struct cons_pointer value = + read_continuation( frame, frame_pointer, input, c ); - /* skip commaa and whitespace at this point. */ - for ( c = url_fgetwc( input ); c == L',' || iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input ) ) - ; + /* skip commaa and whitespace at this point. */ + for ( c = url_fgetwc( input ); + c == L',' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ); - result = hashmap_put( result, key, value ); - } + result = hashmap_put( result, key, value ); + } - // default write ACL for maps should be NIL. - pointer_to_vso( result )->payload.hashmap.write_acl = NIL; + // default write ACL for maps should be NIL. + pointer_to_vso( result )->payload.hashmap.write_acl = NIL; - return result; + return result; } /** diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 0b4bf7d..d8d54f9 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -179,7 +179,7 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.string.cdr ); break; case VECTORPOINTTV: - free_vso( pointer); + free_vso( pointer ); break; } diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 32c777f..5b04699 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -33,22 +33,22 @@ * vectorspace object indicated by the cell is this `value`, else false. */ bool check_tag( struct cons_pointer pointer, uint32_t value ) { - bool result = false; + bool result = false; - struct cons_space_object cell = pointer2cell( pointer ); - result = cell.tag.value == value; + struct cons_space_object cell = pointer2cell( pointer ); + result = cell.tag.value == value; - if ( result == false ) { - if ( cell.tag.value == VECTORPOINTTV ) { - struct vector_space_object *vec = pointer_to_vso( pointer ); + if ( result == false ) { + if ( cell.tag.value == VECTORPOINTTV ) { + struct vector_space_object *vec = pointer_to_vso( pointer ); - if ( vec != NULL ) { - result = vec->header.tag.value == value; - } + if ( vec != NULL ) { + result = vec->header.tag.value == value; + } + } } - } - return result; + return result; } /** @@ -99,22 +99,24 @@ struct cons_pointer dec_ref( struct cons_pointer 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 result = NIL; - struct cons_space_object cell = pointer2cell( pointer ); + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( pointer ); - if ( strncmp( (char *)&cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { - struct vector_space_object *vec = pointer_to_vso( pointer ); + if ( strncmp( ( char * ) &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == + 0 ) { + struct vector_space_object *vec = pointer_to_vso( pointer ); - for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( (wchar_t)vec->header.tag.bytes[i], result ); + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = + make_string( ( wchar_t ) vec->header.tag.bytes[i], result ); + } + } else { + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = make_string( ( wchar_t ) cell.tag.bytes[i], result ); + } } - } else { - for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( (wchar_t)cell.tag.bytes[i], result ); - } - } - return result; + return result; } /** @@ -122,13 +124,13 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { * authorised to read it, does not error but returns nil. */ struct cons_pointer c_car( struct cons_pointer arg ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { - result = pointer2cell( arg ).payload.cons.car; - } + if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { + result = pointer2cell( arg ).payload.cons.car; + } - return result; + return result; } /** @@ -136,34 +138,34 @@ struct cons_pointer c_car( struct cons_pointer arg ) { * not authorised to read it,does not error but returns nil. */ struct cons_pointer c_cdr( struct cons_pointer arg ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if ( truep( authorised( arg, NIL ) ) ) { - struct cons_space_object *cell = &pointer2cell( arg ); + if ( truep( authorised( arg, NIL ) ) ) { + struct cons_space_object *cell = &pointer2cell( arg ); - switch ( cell->tag.value ) { - case CONSTV: - result = cell->payload.cons.cdr; - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - result = cell->payload.string.cdr; - break; + switch ( cell->tag.value ) { + case CONSTV: + result = cell->payload.cons.cdr; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = cell->payload.string.cdr; + break; + } } - } - return result; + return result; } /** * Implementation of `length` in C. If arg is not a cons, does not error but returns 0. */ -int c_length( struct cons_pointer arg) { +int c_length( struct cons_pointer arg ) { int result = 0; - for (struct cons_pointer c = arg; !nilp(c); c = c_cdr(c)) { - result ++; + for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) { + result++; } return result; @@ -276,27 +278,21 @@ struct cons_pointer make_nlambda( struct cons_pointer args, * * returns 0 for things which are not string like. */ -uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) -{ - struct cons_space_object *cell = &pointer2cell(ptr); +uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) { + struct cons_space_object *cell = &pointer2cell( ptr ); uint32_t result = 0; - switch (cell->tag.value) - { - case KEYTV: - case STRINGTV: - case SYMBOLTV: - if (nilp(cell->payload.string.cdr)) - { - result = (uint32_t)c; - } - else - { - result = ((uint32_t)c * - cell->payload.string.hash) & - 0xffffffff; - } - break; + switch ( cell->tag.value ) { + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if ( nilp( cell->payload.string.cdr ) ) { + result = ( uint32_t ) c; + } else { + result = ( ( uint32_t ) c * + cell->payload.string.hash ) & 0xffffffff; + } + break; } return result; @@ -324,7 +320,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { * cell->payload.string.cdr = tail */ cell->payload.string.cdr.offset = tail.offset; - cell->payload.string.hash = calculate_hash(c, tail); + cell->payload.string.hash = calculate_hash( c, tail ); } else { // \todo should throw an exception! debug_printf( DEBUG_ALLOC, @@ -430,12 +426,12 @@ struct cons_pointer make_write_stream( URL_FILE * output, struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { struct cons_pointer result = NIL; - for ( int i = wcslen( symbol ) -1; i >= 0; i-- ) { - wchar_t c = towlower(symbol[i]); + for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { + wchar_t c = towlower( symbol[i] ); - if (iswalnum(c) || c == L'-') { - result = make_keyword( c, result ); - } + if ( iswalnum( c ) || c == L'-' ) { + result = make_keyword( c, result ); + } } return result; @@ -448,9 +444,9 @@ struct cons_pointer c_string_to_lisp_string( wchar_t *string ) { struct cons_pointer result = NIL; for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { - if (iswprint(string[i]) && string[i] != '"') { - result = make_string( string[i], result ); - } + if ( iswprint( string[i] ) && string[i] != '"' ) { + result = make_string( string[i], result ); + } } return result; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 0efa0a6..2817e69 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -685,7 +685,7 @@ struct cons_pointer c_car( struct cons_pointer arg ); struct cons_pointer c_cdr( struct cons_pointer arg ); -int c_length( struct cons_pointer arg); +int c_length( struct cons_pointer arg ); struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ); diff --git a/src/memory/dump.c b/src/memory/dump.c index 2dc6658..086f8c8 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -46,8 +46,7 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, cell.payload.string.character, cell.payload.string.hash, cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, - cell.count ); + cell.payload.string.cdr.offset, cell.count ); url_fwprintf( output, L"\t\t value: " ); print( output, pointer ); url_fwprintf( output, L"\n" ); @@ -57,105 +56,111 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, /** * dump the object at this cons_pointer to this output stream. */ -void dump_object( URL_FILE *output, struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - url_fwprintf( output, 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 ); +void dump_object( URL_FILE * output, struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + url_fwprintf( output, 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 ) { - case CONSTV: - url_fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d " - L"offset %d, count %u :", - cell.payload.cons.car.page, cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset, - cell.count ); - print( output, pointer ); - url_fputws( L"\n", output ); - break; - case EXCEPTIONTV: - url_fwprintf( output, L"\t\tException cell: " ); - dump_stack_trace( output, pointer ); - break; - case FREETV: - url_fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", - cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset ); - break; - case INTEGERTV: - url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); - if ( !nilp( cell.payload.integer.more ) ) { - url_fputws( L"\t\tBIGNUM! More at:\n", output ); - dump_object( output, cell.payload.integer.more ); - } - break; - case KEYTV: - dump_string_cell( output, L"Keyword", pointer ); - break; - case LAMBDATV: - url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); - print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case NILTV: - break; - case NLAMBDATV: - url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); - print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case RATIOTV: - url_fwprintf( - output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload.integer.value, - cell.count ); - break; - case READTV: - url_fputws( L"\t\tInput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - case REALTV: - url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", - cell.payload.real.value, cell.count ); - break; - case STRINGTV: - dump_string_cell( output, L"String", pointer ); - break; - case SYMBOLTV: - dump_string_cell( output, L"Symbol", pointer ); - break; - case TRUETV: - break; - case VECTORPOINTTV: { - url_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; - url_fwprintf( output, - L"\t\tVector space object of type %4.4s (%d), payload size " - L"%d bytes\n", - &vso->header.tag.bytes, vso->header.tag.value, - vso->header.size ); + switch ( cell.tag.value ) { + case CONSTV: + url_fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d " + L"offset %d, count %u :", + cell.payload.cons.car.page, + cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); + print( output, pointer ); + url_fputws( L"\n", output ); + break; + case EXCEPTIONTV: + url_fwprintf( output, L"\t\tException cell: " ); + dump_stack_trace( output, pointer ); + break; + case FREETV: + url_fwprintf( output, + L"\t\tFree cell: next at page %d offset %d\n", + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset ); + break; + case INTEGERTV: + url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); + if ( !nilp( cell.payload.integer.more ) ) { + url_fputws( L"\t\tBIGNUM! More at:\n", output ); + dump_object( output, cell.payload.integer.more ); + } + break; + case KEYTV: + dump_string_cell( output, L"Keyword", pointer ); + break; + case LAMBDATV: + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); + print( output, cell.payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case NILTV: + break; + case NLAMBDATV: + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); + print( output, cell.payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case RATIOTV: + url_fwprintf( output, + L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); + break; + case READTV: + url_fputws( L"\t\tInput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); + break; + case REALTV: + url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); + break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; + case TRUETV: + break; + case VECTORPOINTTV:{ + url_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; + url_fwprintf( output, + L"\t\tVector space object of type %4.4s (%d), payload size " + L"%d bytes\n", + &vso->header.tag.bytes, vso->header.tag.value, + vso->header.size ); - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - dump_frame( output, pointer ); - break; - case HASHTV: - dump_map( output, pointer ); - break; - } - } break; - case WRITETV: - url_fputws( L"\t\tOutput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - } + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + dump_frame( output, pointer ); + break; + case HASHTV: + dump_map( output, pointer ); + break; + } + } + break; + case WRITETV: + url_fputws( L"\t\tOutput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); + break; + } } diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index ae15461..2e68cda 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -24,47 +24,46 @@ * then `(sxhash x)` and `(sxhash y)` will always be equal. */ uint32_t sxhash( struct cons_pointer ptr ) { - // TODO: Not Yet Implemented - /* TODO: should look at the implementation of Common Lisp sxhash? - * My current implementation of `print` only addresses URL_FILE - * streams. It would be better if it also addressed strings but - * currently it doesn't. Creating a print string of the structure - * and taking the hash of that would be one simple (but not necessarily - * cheap) solution. - */ - /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp - * and is EXTREMELY complex, and essentially has a different dispatch for - * every type of object. It's likely we need to do the same. - */ - return 0; + // TODO: Not Yet Implemented + /* TODO: should look at the implementation of Common Lisp sxhash? + * My current implementation of `print` only addresses URL_FILE + * streams. It would be better if it also addressed strings but + * currently it doesn't. Creating a print string of the structure + * and taking the hash of that would be one simple (but not necessarily + * cheap) solution. + */ + /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp + * and is EXTREMELY complex, and essentially has a different dispatch for + * every type of object. It's likely we need to do the same. + */ + return 0; } /** * Get the hash value for the cell indicated by this `ptr`; currently only * implemented for string like things and integers. */ -uint32_t get_hash(struct cons_pointer ptr) -{ - struct cons_space_object *cell = &pointer2cell(ptr); +uint32_t get_hash( struct cons_pointer ptr ) { + struct cons_space_object *cell = &pointer2cell( ptr ); uint32_t result = 0; switch ( cell->tag.value ) { - case INTEGERTV: - /* Note that we're only hashing on the least significant word of an - * integer. */ - result = cell->payload.integer.value & 0xffffffff; - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - result = cell->payload.string.hash; - break; - case TRUETV: - result = 1; // arbitrarily - break; - default: - result = sxhash( ptr ); - break; + case INTEGERTV: + /* Note that we're only hashing on the least significant word of an + * integer. */ + result = cell->payload.integer.value & 0xffffffff; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = cell->payload.string.hash; + break; + case TRUETV: + result = 1; // arbitrarily + break; + default: + result = sxhash( ptr ); + break; } return result; @@ -74,35 +73,34 @@ uint32_t get_hash(struct cons_pointer ptr) * Free the hashmap indicated by this `pointer`. */ void free_hashmap( struct cons_pointer pointer ) { - struct cons_space_object *cell = &pointer2cell( pointer ); + struct cons_space_object *cell = &pointer2cell( pointer ); - if ( hashmapp( pointer ) ) { - struct vector_space_object *vso = cell->payload.vectorp.address; + if ( hashmapp( pointer ) ) { + struct vector_space_object *vso = cell->payload.vectorp.address; - dec_ref( vso->payload.hashmap.hash_fn ); - dec_ref( vso->payload.hashmap.write_acl ); + dec_ref( vso->payload.hashmap.hash_fn ); + dec_ref( vso->payload.hashmap.write_acl ); - for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) { - if ( !nilp( vso->payload.hashmap.buckets[i] ) ) { - debug_printf( DEBUG_ALLOC, - L"Decrementing bucket [%d] of hashmap at 0x%lx\n", i, - cell->payload.vectorp.address ); - dec_ref( vso->payload.hashmap.buckets[i] ); - } + for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) { + if ( !nilp( vso->payload.hashmap.buckets[i] ) ) { + debug_printf( DEBUG_ALLOC, + L"Decrementing bucket [%d] of hashmap at 0x%lx\n", + i, cell->payload.vectorp.address ); + dec_ref( vso->payload.hashmap.buckets[i] ); + } + } + } else { + debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); } - } else { - debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); - } } /** * A lisp function signature conforming wrapper around get_hash, q.v.. */ -struct cons_pointer lisp_get_hash(struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env) -{ - return make_integer(get_hash(frame->arg[0]), NIL); +struct cons_pointer lisp_get_hash( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_integer( get_hash( frame->arg[0] ), NIL ); } /** @@ -112,22 +110,23 @@ struct cons_pointer lisp_get_hash(struct stack_frame *frame, struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn, struct cons_pointer write_acl ) { - struct cons_pointer result = - make_vso( HASHTV, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + - ( sizeof( uint32_t ) * 2 ) ); + struct cons_pointer result = + make_vso( HASHTV, + ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + + ( sizeof( uint32_t ) * 2 ) ); - struct hashmap_payload *payload = - (struct hashmap_payload *)&pointer_to_vso( result )->payload; + struct hashmap_payload *payload = + ( struct hashmap_payload * ) &pointer_to_vso( result )->payload; - payload->hash_fn = inc_ref(hash_fn); - payload->write_acl = inc_ref(write_acl); + payload->hash_fn = inc_ref( hash_fn ); + payload->write_acl = inc_ref( write_acl ); - payload->n_buckets = n_buckets; - for ( int i = 0; i < n_buckets; i++ ) { - payload->buckets[i] = NIL; - } + payload->n_buckets = n_buckets; + for ( int i = 0; i < n_buckets; i++ ) { + payload->buckets[i] = NIL; + } - return result; + return result; } /** @@ -141,52 +140,54 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - uint32_t n = DFLT_HASHMAP_BUCKETS; - struct cons_pointer hash_fn = NIL; - struct cons_pointer result = NIL; + uint32_t n = DFLT_HASHMAP_BUCKETS; + struct cons_pointer hash_fn = NIL; + struct cons_pointer result = NIL; - if ( frame->args > 0 ) { - if ( integerp( frame->arg[0] ) ) { - n = to_long_int( frame->arg[0] ) % UINT32_MAX; - } else if ( !nilp( frame->arg[0] ) ) { - result = make_exception( - c_string_to_lisp_string( L"First arg to `hashmap`, if passed, must " - L"be an integer or `nil`.`" ), - NIL ); + if ( frame->args > 0 ) { + if ( integerp( frame->arg[0] ) ) { + n = to_long_int( frame->arg[0] ) % UINT32_MAX; + } else if ( !nilp( frame->arg[0] ) ) { + result = + make_exception( c_string_to_lisp_string + ( L"First arg to `hashmap`, if passed, must " + L"be an integer or `nil`.`" ), NIL ); + } } - } - if ( frame->args > 1 ) { - hash_fn = frame->arg[1]; - } - - if ( nilp( result ) ) { - /* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which - * is fine */ - result = make_hashmap( n, hash_fn, frame->arg[3] ); - struct vector_space_object *map = pointer_to_vso( result ); - - if ( frame->args > 2 && - truep( authorised( result, map->payload.hashmap.write_acl ) ) ) { - // then arg[2] ought to be an assoc list which we should iterate down - // populating the hashmap. - for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor ); - cursor = c_cdr( cursor ) ) { - struct cons_pointer pair = c_car( cursor ); - struct cons_pointer key = c_car( pair ); - struct cons_pointer val = c_cdr( pair ); - - uint32_t bucket_no = - get_hash( key ) % - ( (struct hashmap_payload *)&( map->payload ) )->n_buckets; - - map->payload.hashmap.buckets[bucket_no] = - inc_ref( make_cons( make_cons( key, val ), - map->payload.hashmap.buckets[bucket_no] )); - } + if ( frame->args > 1 ) { + hash_fn = frame->arg[1]; } - } - return result; + if ( nilp( result ) ) { + /* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which + * is fine */ + result = make_hashmap( n, hash_fn, frame->arg[3] ); + struct vector_space_object *map = pointer_to_vso( result ); + + if ( frame->args > 2 && + truep( authorised( result, map->payload.hashmap.write_acl ) ) ) { + // then arg[2] ought to be an assoc list which we should iterate down + // populating the hashmap. + for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor ); + cursor = c_cdr( cursor ) ) { + struct cons_pointer pair = c_car( cursor ); + struct cons_pointer key = c_car( pair ); + struct cons_pointer val = c_cdr( pair ); + + uint32_t bucket_no = + get_hash( key ) % + ( ( struct hashmap_payload * ) &( map->payload ) )-> + n_buckets; + + map->payload.hashmap.buckets[bucket_no] = + inc_ref( make_cons( make_cons( key, val ), + map->payload.hashmap. + buckets[bucket_no] ) ); + } + } + } + + return result; } @@ -197,28 +198,30 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, * readable hashmap. */ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if ( truep( authorised( ptr, NIL ) ) ) { - if ( hashmapp( ptr ) ) { - struct vector_space_object *from = pointer_to_vso( ptr ); + if ( truep( authorised( ptr, NIL ) ) ) { + if ( hashmapp( ptr ) ) { + struct vector_space_object *from = pointer_to_vso( ptr ); - if ( from != NULL ) { - struct hashmap_payload from_pl = from->payload.hashmap; - result = make_hashmap( from_pl.n_buckets, from_pl.hash_fn, from_pl.write_acl ); - struct vector_space_object *to = pointer_to_vso( result ); - struct hashmap_payload to_pl = to->payload.hashmap; + if ( from != NULL ) { + struct hashmap_payload from_pl = from->payload.hashmap; + result = + make_hashmap( from_pl.n_buckets, from_pl.hash_fn, + from_pl.write_acl ); + struct vector_space_object *to = pointer_to_vso( result ); + struct hashmap_payload to_pl = to->payload.hashmap; - for ( int i = 0; i < to_pl.n_buckets; i++ ) { - to_pl.buckets[i] = from_pl.buckets[i]; - inc_ref( to_pl.buckets[i] ); + for ( int i = 0; i < to_pl.n_buckets; i++ ) { + to_pl.buckets[i] = from_pl.buckets[i]; + inc_ref( to_pl.buckets[i] ); + } + } } - } } - } - // TODO: else exception? + // TODO: else exception? - return result; + return result; } /** @@ -229,37 +232,35 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { struct cons_pointer hashmap_put( struct cons_pointer mapp, struct cons_pointer key, struct cons_pointer val ) { - // TODO: if current user has write access to this hashmap - if ( hashmapp( mapp ) && !nilp( key ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); + // TODO: if current user has write access to this hashmap + if ( hashmapp( mapp ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); - if (nilp(authorised(mapp, map->payload.hashmap.write_acl))) { - mapp = clone_hashmap( mapp); - map = pointer_to_vso( mapp ); - } - uint32_t bucket_no = - get_hash( key ) % - map->payload.hashmap.n_buckets; + if ( nilp( authorised( mapp, map->payload.hashmap.write_acl ) ) ) { + mapp = clone_hashmap( mapp ); + map = pointer_to_vso( mapp ); + } + uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; map->payload.hashmap.buckets[bucket_no] = inc_ref( make_cons( make_cons( key, val ), - map->payload.hashmap.buckets[bucket_no] )); - } + map->payload.hashmap.buckets[bucket_no] ) ); + } - return mapp; + return mapp; } struct cons_pointer hashmap_get( struct cons_pointer mapp, struct cons_pointer key ) { - struct cons_pointer result = NIL; - if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); - uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; - result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] ); - } + result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] ); + } - return result; + return result; } /** @@ -272,11 +273,11 @@ struct cons_pointer hashmap_get( struct cons_pointer mapp, struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer mapp = frame->arg[0]; - struct cons_pointer key = frame->arg[1]; - struct cons_pointer val = frame->arg[2]; + struct cons_pointer mapp = frame->arg[0]; + struct cons_pointer key = frame->arg[1]; + struct cons_pointer val = frame->arg[2]; - return hashmap_put(mapp, key, val); + return hashmap_put( mapp, key, val ); } /** @@ -286,21 +287,21 @@ struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, */ struct cons_pointer hashmap_put_all( struct cons_pointer mapp, struct cons_pointer assoc ) { - // TODO: if current user has write access to this hashmap - if ( hashmapp( mapp ) && !nilp( assoc ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); + // TODO: if current user has write access to this hashmap + if ( hashmapp( mapp ) && !nilp( assoc ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); - if ( hashmapp( mapp ) && consp( assoc ) ) { - for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair ); - pair = c_car( assoc ) ) { - /* TODO: this is really hammering the memory management system, because - * it will make a new lone for every key/value pair added. Fix. */ - mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) ); - } + if ( hashmapp( mapp ) && consp( assoc ) ) { + for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair ); + pair = c_car( assoc ) ) { + /* TODO: this is really hammering the memory management system, because + * it will make a new lone for every key/value pair added. Fix. */ + mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) ); + } + } } - } - return mapp; + return mapp; } /** @@ -310,47 +311,47 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp, struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return hashmap_put_all( frame->arg[0], frame->arg[1] ); + return hashmap_put_all( frame->arg[0], frame->arg[1] ); } /** * return a flat list of all the keys in the hashmap indicated by `map`. */ -struct cons_pointer hashmap_keys( struct cons_pointer mapp) { - struct cons_pointer result = NIL; - if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) )) { +struct cons_pointer hashmap_keys( struct cons_pointer mapp ) { + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) ) { struct vector_space_object *map = pointer_to_vso( mapp ); - for (int i = 0; i < map->payload.hashmap.n_buckets; i++) { - for (struct cons_pointer c = map->payload.hashmap.buckets[i]; - !nilp(c); - c = c_cdr(c)) { - result = make_cons(c_car( c_car(c)), result); - } + for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) { + for ( struct cons_pointer c = map->payload.hashmap.buckets[i]; + !nilp( c ); c = c_cdr( c ) ) { + result = make_cons( c_car( c_car( c ) ), result ); + } + } } - } - return result; + return result; } struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return hashmap_keys( frame->arg[0] ); + return hashmap_keys( frame->arg[0] ); } -void dump_map( URL_FILE *output, struct cons_pointer pointer ) { - struct hashmap_payload *payload = &pointer_to_vso( pointer )->payload.hashmap; - url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); - url_fwprintf( output, L"\tHash function: " ); - print( output, payload->hash_fn ); - url_fwprintf( output, L"\n\tWrite ACL: " ); - print( output, payload->write_acl ); - url_fwprintf( output, L"\n\tBuckets:" ); - for ( int i = 0; i < payload->n_buckets; i++ ) { - url_fwprintf( output, L"\n\t\t[%d]: ", i ); - print( output, payload->buckets[i] ); - } - url_fwprintf( output, L"\n" ); +void dump_map( URL_FILE * output, struct cons_pointer pointer ) { + struct hashmap_payload *payload = + &pointer_to_vso( pointer )->payload.hashmap; + url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); + url_fwprintf( output, L"\tHash function: " ); + print( output, payload->hash_fn ); + url_fwprintf( output, L"\n\tWrite ACL: " ); + print( output, payload->write_acl ); + url_fwprintf( output, L"\n\tBuckets:" ); + for ( int i = 0; i < payload->n_buckets; i++ ) { + url_fwprintf( output, L"\n\t\t[%d]: ", i ); + print( output, payload->buckets[i] ); + } + url_fwprintf( output, L"\n" ); } diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h index 4602f3e..b6c4a74 100644 --- a/src/memory/hashmap.h +++ b/src/memory/hashmap.h @@ -15,13 +15,13 @@ #include "memory/consspaceobject.h" #include "memory/vectorspace.h" -#define DFLT_HASHMAP_BUCKETS 32 +#define DFLT_HASHMAP_BUCKETS 32 uint32_t get_hash( struct cons_pointer ptr ); void free_hashmap( struct cons_pointer ptr ); -void dump_map( URL_FILE *output, struct cons_pointer pointer ); +void dump_map( URL_FILE * output, struct cons_pointer pointer ); struct cons_pointer hashmap_get( struct cons_pointer mapp, struct cons_pointer key ); @@ -52,4 +52,4 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn, struct cons_pointer write_acl ); -#endif \ No newline at end of file +#endif diff --git a/src/memory/lookup3.c b/src/memory/lookup3.c index 006d513..359cff2 100644 --- a/src/memory/lookup3.c +++ b/src/memory/lookup3.c @@ -35,12 +35,12 @@ on 1 byte), but shoehorning those bytes into integers efficiently is messy. */ // #define SELF_TEST 1 -#include /* defines printf for tests */ -#include /* defines time_t for timings in the test */ -#include /* defines uint32_t etc */ -#include /* attempt to define endianness */ +#include /* defines printf for tests */ +#include /* defines time_t for timings in the test */ +#include /* defines uint32_t etc */ +#include /* attempt to define endianness */ #ifdef linux -# include /* attempt to define endianness */ +#include /* attempt to define endianness */ #endif /* @@ -51,16 +51,16 @@ on 1 byte), but shoehorning those bytes into integers efficiently is messy. __BYTE_ORDER == __LITTLE_ENDIAN) || \ (defined(i386) || defined(__i386__) || defined(__i486__) || \ defined(__i586__) || defined(__i686__) || defined(vax) || defined(MIPSEL)) -# define HASH_LITTLE_ENDIAN 1 -# define HASH_BIG_ENDIAN 0 +#define HASH_LITTLE_ENDIAN 1 +#define HASH_BIG_ENDIAN 0 #elif (defined(__BYTE_ORDER) && defined(__BIG_ENDIAN) && \ __BYTE_ORDER == __BIG_ENDIAN) || \ (defined(sparc) || defined(POWERPC) || defined(mc68000) || defined(sel)) -# define HASH_LITTLE_ENDIAN 0 -# define HASH_BIG_ENDIAN 1 +#define HASH_LITTLE_ENDIAN 0 +#define HASH_BIG_ENDIAN 1 #else -# define HASH_LITTLE_ENDIAN 0 -# define HASH_BIG_ENDIAN 0 +#define HASH_LITTLE_ENDIAN 0 +#define HASH_BIG_ENDIAN 0 #endif #define hashsize(n) ((uint32_t)1<<(n)) @@ -170,39 +170,38 @@ and these came close: hashlittle() has to dance around fitting the key bytes into registers. -------------------------------------------------------------------- */ -uint32_t hashword( -const uint32_t *k, /* the key, an array of uint32_t values */ -size_t length, /* the length of the key, in uint32_ts */ -uint32_t initval) /* the previous hash, or an arbitrary value */ -{ - uint32_t a,b,c; +uint32_t hashword( const uint32_t * k, /* the key, an array of uint32_t values */ + size_t length, /* the length of the key, in uint32_ts */ + uint32_t initval ) { /* the previous hash, or an arbitrary value */ + uint32_t a, b, c; - /* Set up the internal state */ - a = b = c = 0xdeadbeef + (((uint32_t)length)<<2) + initval; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( ( uint32_t ) length ) << 2 ) + initval; /*------------------------------------------------- handle most of the key */ - while (length > 3) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 3; - k += 3; - } + while ( length > 3 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 3; + k += 3; + } /*------------------------------------------- handle the last 3 uint32_t's */ - switch(length) /* all the case statements fall through */ - { - case 3 : c+=k[2]; - case 2 : b+=k[1]; - case 1 : a+=k[0]; - final(a,b,c); - case 0: /* case 0: nothing left to add */ - break; - } + switch ( length ) { /* all the case statements fall through */ + case 3: + c += k[2]; + case 2: + b += k[1]; + case 1: + a += k[0]; + final( a, b, c ); + case 0: /* case 0: nothing left to add */ + break; + } /*------------------------------------------------------ report the result */ - return c; + return c; } @@ -214,41 +213,41 @@ both be initialized with seeds. If you pass in (*pb)==0, the output (*pc) will be the same as the return value from hashword(). -------------------------------------------------------------------- */ -void hashword2 ( -const uint32_t *k, /* the key, an array of uint32_t values */ -size_t length, /* the length of the key, in uint32_ts */ -uint32_t *pc, /* IN: seed OUT: primary hash value */ -uint32_t *pb) /* IN: more seed OUT: secondary hash value */ -{ - uint32_t a,b,c; +void hashword2( const uint32_t * k, /* the key, an array of uint32_t values */ + size_t length, /* the length of the key, in uint32_ts */ + uint32_t * pc, /* IN: seed OUT: primary hash value */ + uint32_t * pb ) { /* IN: more seed OUT: secondary hash value */ + uint32_t a, b, c; - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ((uint32_t)(length<<2)) + *pc; - c += *pb; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( uint32_t ) ( length << 2 ) ) + *pc; + c += *pb; /*------------------------------------------------- handle most of the key */ - while (length > 3) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 3; - k += 3; - } + while ( length > 3 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 3; + k += 3; + } /*------------------------------------------- handle the last 3 uint32_t's */ - switch(length) /* all the case statements fall through */ - { - case 3 : c+=k[2]; - case 2 : b+=k[1]; - case 1 : a+=k[0]; - final(a,b,c); - case 0: /* case 0: nothing left to add */ - break; - } + switch ( length ) { /* all the case statements fall through */ + case 3: + c += k[2]; + case 2: + b += k[1]; + case 1: + a += k[0]; + final( a, b, c ); + case 0: /* case 0: nothing left to add */ + break; + } /*------------------------------------------------------ report the result */ - *pc=c; *pb=b; + *pc = c; + *pb = b; } @@ -279,173 +278,251 @@ acceptable. Do NOT use for cryptographic purposes. ------------------------------------------------------------------------------- */ -uint32_t hashlittle( const void *key, size_t length, uint32_t initval) -{ - uint32_t a,b,c; /* internal state */ - union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */ +uint32_t hashlittle( const void *key, size_t length, uint32_t initval ) { + uint32_t a, b, c; /* internal state */ + union { + const void *ptr; + size_t i; + } u; /* needed for Mac Powerbook G4 */ - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ((uint32_t)length) + initval; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + initval; - u.ptr = key; - if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) { - const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ - const uint8_t *k8; + u.ptr = key; + if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { + const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ + const uint8_t *k8; /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 12; - k += 3; - } + while ( length > 12 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 12; + k += 3; + } /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ + /* + * "k[2]&0xffffff" actually reads beyond the end of the string, but + * then masks off the part it's not allowed to read. Because the + * string is aligned, the masked-off tail is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ #ifndef VALGRIND - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break; - case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break; - case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break; - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=k[1]&0xffffff; a+=k[0]; break; - case 6 : b+=k[1]&0xffff; a+=k[0]; break; - case 5 : b+=k[1]&0xff; a+=k[0]; break; - case 4 : a+=k[0]; break; - case 3 : a+=k[0]&0xffffff; break; - case 2 : a+=k[0]&0xffff; break; - case 1 : a+=k[0]&0xff; break; - case 0 : return c; /* zero length strings require no mixing */ - } + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += k[2] & 0xffffff; + b += k[1]; + a += k[0]; + break; + case 10: + c += k[2] & 0xffff; + b += k[1]; + a += k[0]; + break; + case 9: + c += k[2] & 0xff; + b += k[1]; + a += k[0]; + break; + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += k[1] & 0xffffff; + a += k[0]; + break; + case 6: + b += k[1] & 0xffff; + a += k[0]; + break; + case 5: + b += k[1] & 0xff; + a += k[0]; + break; + case 4: + a += k[0]; + break; + case 3: + a += k[0] & 0xffffff; + break; + case 2: + a += k[0] & 0xffff; + break; + case 1: + a += k[0] & 0xff; + break; + case 0: + return c; /* zero length strings require no mixing */ + } #else /* make valgrind happy */ - k8 = (const uint8_t *)k; - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ - case 10: c+=((uint32_t)k8[9])<<8; /* fall through */ - case 9 : c+=k8[8]; /* fall through */ - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ - case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */ - case 5 : b+=k8[4]; /* fall through */ - case 4 : a+=k[0]; break; - case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ - case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */ - case 1 : a+=k8[0]; break; - case 0 : return c; - } + k8 = ( const uint8_t * ) k; + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ + case 10: + c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ + case 9: + c += k8[8]; /* fall through */ + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ + case 6: + b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ + case 5: + b += k8[4]; /* fall through */ + case 4: + a += k[0]; + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ + case 2: + a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ + case 1: + a += k8[0]; + break; + case 0: + return c; + } #endif /* !valgrind */ - } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) { - const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ - const uint8_t *k8; + } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { + const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ + const uint8_t *k8; /*--------------- all but last block: aligned reads and different mixing */ - while (length > 12) - { - a += k[0] + (((uint32_t)k[1])<<16); - b += k[2] + (((uint32_t)k[3])<<16); - c += k[4] + (((uint32_t)k[5])<<16); - mix(a,b,c); - length -= 12; - k += 6; - } + while ( length > 12 ) { + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); + mix( a, b, c ); + length -= 12; + k += 6; + } /*----------------------------- handle the last (probably partial) block */ - k8 = (const uint8_t *)k; - switch(length) - { - case 12: c+=k[4]+(((uint32_t)k[5])<<16); - b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ - case 10: c+=k[4]; - b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 9 : c+=k8[8]; /* fall through */ - case 8 : b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ - case 6 : b+=k[2]; - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 5 : b+=k8[4]; /* fall through */ - case 4 : a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ - case 2 : a+=k[0]; - break; - case 1 : a+=k8[0]; - break; - case 0 : return c; /* zero length requires no mixing */ - } + k8 = ( const uint8_t * ) k; + switch ( length ) { + case 12: + c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ + case 10: + c += k[4]; + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 9: + c += k8[8]; /* fall through */ + case 8: + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ + case 6: + b += k[2]; + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 5: + b += k8[4]; /* fall through */ + case 4: + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ + case 2: + a += k[0]; + break; + case 1: + a += k8[0]; + break; + case 0: + return c; /* zero length requires no mixing */ + } - } else { /* need to read the key one byte at a time */ - const uint8_t *k = (const uint8_t *)key; + } else { /* need to read the key one byte at a time */ + const uint8_t *k = ( const uint8_t * ) key; /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - a += ((uint32_t)k[1])<<8; - a += ((uint32_t)k[2])<<16; - a += ((uint32_t)k[3])<<24; - b += k[4]; - b += ((uint32_t)k[5])<<8; - b += ((uint32_t)k[6])<<16; - b += ((uint32_t)k[7])<<24; - c += k[8]; - c += ((uint32_t)k[9])<<8; - c += ((uint32_t)k[10])<<16; - c += ((uint32_t)k[11])<<24; - mix(a,b,c); - length -= 12; - k += 12; - } + while ( length > 12 ) { + a += k[0]; + a += ( ( uint32_t ) k[1] ) << 8; + a += ( ( uint32_t ) k[2] ) << 16; + a += ( ( uint32_t ) k[3] ) << 24; + b += k[4]; + b += ( ( uint32_t ) k[5] ) << 8; + b += ( ( uint32_t ) k[6] ) << 16; + b += ( ( uint32_t ) k[7] ) << 24; + c += k[8]; + c += ( ( uint32_t ) k[9] ) << 8; + c += ( ( uint32_t ) k[10] ) << 16; + c += ( ( uint32_t ) k[11] ) << 24; + mix( a, b, c ); + length -= 12; + k += 12; + } /*-------------------------------- last block: affect all 32 bits of (c) */ - switch(length) /* all the case statements fall through */ - { - case 12: c+=((uint32_t)k[11])<<24; - case 11: c+=((uint32_t)k[10])<<16; - case 10: c+=((uint32_t)k[9])<<8; - case 9 : c+=k[8]; - case 8 : b+=((uint32_t)k[7])<<24; - case 7 : b+=((uint32_t)k[6])<<16; - case 6 : b+=((uint32_t)k[5])<<8; - case 5 : b+=k[4]; - case 4 : a+=((uint32_t)k[3])<<24; - case 3 : a+=((uint32_t)k[2])<<16; - case 2 : a+=((uint32_t)k[1])<<8; - case 1 : a+=k[0]; - break; - case 0 : return c; + switch ( length ) { /* all the case statements fall through */ + case 12: + c += ( ( uint32_t ) k[11] ) << 24; + case 11: + c += ( ( uint32_t ) k[10] ) << 16; + case 10: + c += ( ( uint32_t ) k[9] ) << 8; + case 9: + c += k[8]; + case 8: + b += ( ( uint32_t ) k[7] ) << 24; + case 7: + b += ( ( uint32_t ) k[6] ) << 16; + case 6: + b += ( ( uint32_t ) k[5] ) << 8; + case 5: + b += k[4]; + case 4: + a += ( ( uint32_t ) k[3] ) << 24; + case 3: + a += ( ( uint32_t ) k[2] ) << 16; + case 2: + a += ( ( uint32_t ) k[1] ) << 8; + case 1: + a += k[0]; + break; + case 0: + return c; + } } - } - final(a,b,c); - return c; + final( a, b, c ); + return c; } @@ -459,178 +536,264 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval) * the key. *pc is better mixed than *pb, so use *pc first. If you want * a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)". */ -void hashlittle2( - const void *key, /* the key to hash */ - size_t length, /* length of the key */ - uint32_t *pc, /* IN: primary initval, OUT: primary hash */ - uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */ -{ - uint32_t a,b,c; /* internal state */ - union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */ +void hashlittle2( const void *key, /* the key to hash */ + size_t length, /* length of the key */ + uint32_t * pc, /* IN: primary initval, OUT: primary hash */ + uint32_t * pb ) { /* IN: secondary initval, OUT: secondary hash */ + uint32_t a, b, c; /* internal state */ + union { + const void *ptr; + size_t i; + } u; /* needed for Mac Powerbook G4 */ - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ((uint32_t)length) + *pc; - c += *pb; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + *pc; + c += *pb; - u.ptr = key; - if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) { - const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ - const uint8_t *k8; + u.ptr = key; + if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { + const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ + const uint8_t *k8; /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 12; - k += 3; - } + while ( length > 12 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 12; + k += 3; + } /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ + /* + * "k[2]&0xffffff" actually reads beyond the end of the string, but + * then masks off the part it's not allowed to read. Because the + * string is aligned, the masked-off tail is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ #ifndef VALGRIND - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break; - case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break; - case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break; - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=k[1]&0xffffff; a+=k[0]; break; - case 6 : b+=k[1]&0xffff; a+=k[0]; break; - case 5 : b+=k[1]&0xff; a+=k[0]; break; - case 4 : a+=k[0]; break; - case 3 : a+=k[0]&0xffffff; break; - case 2 : a+=k[0]&0xffff; break; - case 1 : a+=k[0]&0xff; break; - case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ - } + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += k[2] & 0xffffff; + b += k[1]; + a += k[0]; + break; + case 10: + c += k[2] & 0xffff; + b += k[1]; + a += k[0]; + break; + case 9: + c += k[2] & 0xff; + b += k[1]; + a += k[0]; + break; + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += k[1] & 0xffffff; + a += k[0]; + break; + case 6: + b += k[1] & 0xffff; + a += k[0]; + break; + case 5: + b += k[1] & 0xff; + a += k[0]; + break; + case 4: + a += k[0]; + break; + case 3: + a += k[0] & 0xffffff; + break; + case 2: + a += k[0] & 0xffff; + break; + case 1: + a += k[0] & 0xff; + break; + case 0: + *pc = c; + *pb = b; + return; /* zero length strings require no mixing */ + } #else /* make valgrind happy */ - k8 = (const uint8_t *)k; - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ - case 10: c+=((uint32_t)k8[9])<<8; /* fall through */ - case 9 : c+=k8[8]; /* fall through */ - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ - case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */ - case 5 : b+=k8[4]; /* fall through */ - case 4 : a+=k[0]; break; - case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ - case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */ - case 1 : a+=k8[0]; break; - case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ - } + k8 = ( const uint8_t * ) k; + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ + case 10: + c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ + case 9: + c += k8[8]; /* fall through */ + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ + case 6: + b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ + case 5: + b += k8[4]; /* fall through */ + case 4: + a += k[0]; + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ + case 2: + a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ + case 1: + a += k8[0]; + break; + case 0: + *pc = c; + *pb = b; + return; /* zero length strings require no mixing */ + } #endif /* !valgrind */ - } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) { - const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ - const uint8_t *k8; + } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { + const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ + const uint8_t *k8; /*--------------- all but last block: aligned reads and different mixing */ - while (length > 12) - { - a += k[0] + (((uint32_t)k[1])<<16); - b += k[2] + (((uint32_t)k[3])<<16); - c += k[4] + (((uint32_t)k[5])<<16); - mix(a,b,c); - length -= 12; - k += 6; - } + while ( length > 12 ) { + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); + mix( a, b, c ); + length -= 12; + k += 6; + } /*----------------------------- handle the last (probably partial) block */ - k8 = (const uint8_t *)k; - switch(length) - { - case 12: c+=k[4]+(((uint32_t)k[5])<<16); - b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ - case 10: c+=k[4]; - b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 9 : c+=k8[8]; /* fall through */ - case 8 : b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ - case 6 : b+=k[2]; - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 5 : b+=k8[4]; /* fall through */ - case 4 : a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ - case 2 : a+=k[0]; - break; - case 1 : a+=k8[0]; - break; - case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ - } + k8 = ( const uint8_t * ) k; + switch ( length ) { + case 12: + c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ + case 10: + c += k[4]; + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 9: + c += k8[8]; /* fall through */ + case 8: + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ + case 6: + b += k[2]; + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 5: + b += k8[4]; /* fall through */ + case 4: + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ + case 2: + a += k[0]; + break; + case 1: + a += k8[0]; + break; + case 0: + *pc = c; + *pb = b; + return; /* zero length strings require no mixing */ + } - } else { /* need to read the key one byte at a time */ - const uint8_t *k = (const uint8_t *)key; + } else { /* need to read the key one byte at a time */ + const uint8_t *k = ( const uint8_t * ) key; /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - a += ((uint32_t)k[1])<<8; - a += ((uint32_t)k[2])<<16; - a += ((uint32_t)k[3])<<24; - b += k[4]; - b += ((uint32_t)k[5])<<8; - b += ((uint32_t)k[6])<<16; - b += ((uint32_t)k[7])<<24; - c += k[8]; - c += ((uint32_t)k[9])<<8; - c += ((uint32_t)k[10])<<16; - c += ((uint32_t)k[11])<<24; - mix(a,b,c); - length -= 12; - k += 12; - } + while ( length > 12 ) { + a += k[0]; + a += ( ( uint32_t ) k[1] ) << 8; + a += ( ( uint32_t ) k[2] ) << 16; + a += ( ( uint32_t ) k[3] ) << 24; + b += k[4]; + b += ( ( uint32_t ) k[5] ) << 8; + b += ( ( uint32_t ) k[6] ) << 16; + b += ( ( uint32_t ) k[7] ) << 24; + c += k[8]; + c += ( ( uint32_t ) k[9] ) << 8; + c += ( ( uint32_t ) k[10] ) << 16; + c += ( ( uint32_t ) k[11] ) << 24; + mix( a, b, c ); + length -= 12; + k += 12; + } /*-------------------------------- last block: affect all 32 bits of (c) */ - switch(length) /* all the case statements fall through */ - { - case 12: c+=((uint32_t)k[11])<<24; - case 11: c+=((uint32_t)k[10])<<16; - case 10: c+=((uint32_t)k[9])<<8; - case 9 : c+=k[8]; - case 8 : b+=((uint32_t)k[7])<<24; - case 7 : b+=((uint32_t)k[6])<<16; - case 6 : b+=((uint32_t)k[5])<<8; - case 5 : b+=k[4]; - case 4 : a+=((uint32_t)k[3])<<24; - case 3 : a+=((uint32_t)k[2])<<16; - case 2 : a+=((uint32_t)k[1])<<8; - case 1 : a+=k[0]; - break; - case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + switch ( length ) { /* all the case statements fall through */ + case 12: + c += ( ( uint32_t ) k[11] ) << 24; + case 11: + c += ( ( uint32_t ) k[10] ) << 16; + case 10: + c += ( ( uint32_t ) k[9] ) << 8; + case 9: + c += k[8]; + case 8: + b += ( ( uint32_t ) k[7] ) << 24; + case 7: + b += ( ( uint32_t ) k[6] ) << 16; + case 6: + b += ( ( uint32_t ) k[5] ) << 8; + case 5: + b += k[4]; + case 4: + a += ( ( uint32_t ) k[3] ) << 24; + case 3: + a += ( ( uint32_t ) k[2] ) << 16; + case 2: + a += ( ( uint32_t ) k[1] ) << 8; + case 1: + a += k[0]; + break; + case 0: + *pc = c; + *pb = b; + return; /* zero length strings require no mixing */ + } } - } - final(a,b,c); - *pc=c; *pb=b; + final( a, b, c ); + *pc = c; + *pb = b; } @@ -641,147 +804,214 @@ void hashlittle2( * from hashlittle() on all machines. hashbig() takes advantage of * big-endian byte ordering. */ -uint32_t hashbig( const void *key, size_t length, uint32_t initval) -{ - uint32_t a,b,c; - union { const void *ptr; size_t i; } u; /* to cast key to (size_t) happily */ +uint32_t hashbig( const void *key, size_t length, uint32_t initval ) { + uint32_t a, b, c; + union { + const void *ptr; + size_t i; + } u; /* to cast key to (size_t) happily */ - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ((uint32_t)length) + initval; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + initval; - u.ptr = key; - if (HASH_BIG_ENDIAN && ((u.i & 0x3) == 0)) { - const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ - const uint8_t *k8; + u.ptr = key; + if ( HASH_BIG_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { + const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ + const uint8_t *k8; /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 12; - k += 3; - } + while ( length > 12 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 12; + k += 3; + } /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]<<8" actually reads beyond the end of the string, but - * then shifts out the part it's not allowed to read. Because the - * string is aligned, the illegal read is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ + /* + * "k[2]<<8" actually reads beyond the end of the string, but + * then shifts out the part it's not allowed to read. Because the + * string is aligned, the illegal read is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ #ifndef VALGRIND - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=k[2]&0xffffff00; b+=k[1]; a+=k[0]; break; - case 10: c+=k[2]&0xffff0000; b+=k[1]; a+=k[0]; break; - case 9 : c+=k[2]&0xff000000; b+=k[1]; a+=k[0]; break; - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=k[1]&0xffffff00; a+=k[0]; break; - case 6 : b+=k[1]&0xffff0000; a+=k[0]; break; - case 5 : b+=k[1]&0xff000000; a+=k[0]; break; - case 4 : a+=k[0]; break; - case 3 : a+=k[0]&0xffffff00; break; - case 2 : a+=k[0]&0xffff0000; break; - case 1 : a+=k[0]&0xff000000; break; - case 0 : return c; /* zero length strings require no mixing */ - } + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += k[2] & 0xffffff00; + b += k[1]; + a += k[0]; + break; + case 10: + c += k[2] & 0xffff0000; + b += k[1]; + a += k[0]; + break; + case 9: + c += k[2] & 0xff000000; + b += k[1]; + a += k[0]; + break; + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += k[1] & 0xffffff00; + a += k[0]; + break; + case 6: + b += k[1] & 0xffff0000; + a += k[0]; + break; + case 5: + b += k[1] & 0xff000000; + a += k[0]; + break; + case 4: + a += k[0]; + break; + case 3: + a += k[0] & 0xffffff00; + break; + case 2: + a += k[0] & 0xffff0000; + break; + case 1: + a += k[0] & 0xff000000; + break; + case 0: + return c; /* zero length strings require no mixing */ + } -#else /* make valgrind happy */ +#else /* make valgrind happy */ - k8 = (const uint8_t *)k; - switch(length) /* all the case statements fall through */ - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=((uint32_t)k8[10])<<8; /* fall through */ - case 10: c+=((uint32_t)k8[9])<<16; /* fall through */ - case 9 : c+=((uint32_t)k8[8])<<24; /* fall through */ - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=((uint32_t)k8[6])<<8; /* fall through */ - case 6 : b+=((uint32_t)k8[5])<<16; /* fall through */ - case 5 : b+=((uint32_t)k8[4])<<24; /* fall through */ - case 4 : a+=k[0]; break; - case 3 : a+=((uint32_t)k8[2])<<8; /* fall through */ - case 2 : a+=((uint32_t)k8[1])<<16; /* fall through */ - case 1 : a+=((uint32_t)k8[0])<<24; break; - case 0 : return c; - } + k8 = ( const uint8_t * ) k; + switch ( length ) { /* all the case statements fall through */ + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 8; /* fall through */ + case 10: + c += ( ( uint32_t ) k8[9] ) << 16; /* fall through */ + case 9: + c += ( ( uint32_t ) k8[8] ) << 24; /* fall through */ + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 8; /* fall through */ + case 6: + b += ( ( uint32_t ) k8[5] ) << 16; /* fall through */ + case 5: + b += ( ( uint32_t ) k8[4] ) << 24; /* fall through */ + case 4: + a += k[0]; + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 8; /* fall through */ + case 2: + a += ( ( uint32_t ) k8[1] ) << 16; /* fall through */ + case 1: + a += ( ( uint32_t ) k8[0] ) << 24; + break; + case 0: + return c; + } #endif /* !VALGRIND */ - } else { /* need to read the key one byte at a time */ - const uint8_t *k = (const uint8_t *)key; + } else { /* need to read the key one byte at a time */ + const uint8_t *k = ( const uint8_t * ) key; /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while (length > 12) - { - a += ((uint32_t)k[0])<<24; - a += ((uint32_t)k[1])<<16; - a += ((uint32_t)k[2])<<8; - a += ((uint32_t)k[3]); - b += ((uint32_t)k[4])<<24; - b += ((uint32_t)k[5])<<16; - b += ((uint32_t)k[6])<<8; - b += ((uint32_t)k[7]); - c += ((uint32_t)k[8])<<24; - c += ((uint32_t)k[9])<<16; - c += ((uint32_t)k[10])<<8; - c += ((uint32_t)k[11]); - mix(a,b,c); - length -= 12; - k += 12; - } + while ( length > 12 ) { + a += ( ( uint32_t ) k[0] ) << 24; + a += ( ( uint32_t ) k[1] ) << 16; + a += ( ( uint32_t ) k[2] ) << 8; + a += ( ( uint32_t ) k[3] ); + b += ( ( uint32_t ) k[4] ) << 24; + b += ( ( uint32_t ) k[5] ) << 16; + b += ( ( uint32_t ) k[6] ) << 8; + b += ( ( uint32_t ) k[7] ); + c += ( ( uint32_t ) k[8] ) << 24; + c += ( ( uint32_t ) k[9] ) << 16; + c += ( ( uint32_t ) k[10] ) << 8; + c += ( ( uint32_t ) k[11] ); + mix( a, b, c ); + length -= 12; + k += 12; + } /*-------------------------------- last block: affect all 32 bits of (c) */ - switch(length) /* all the case statements fall through */ - { - case 12: c+=k[11]; - case 11: c+=((uint32_t)k[10])<<8; - case 10: c+=((uint32_t)k[9])<<16; - case 9 : c+=((uint32_t)k[8])<<24; - case 8 : b+=k[7]; - case 7 : b+=((uint32_t)k[6])<<8; - case 6 : b+=((uint32_t)k[5])<<16; - case 5 : b+=((uint32_t)k[4])<<24; - case 4 : a+=k[3]; - case 3 : a+=((uint32_t)k[2])<<8; - case 2 : a+=((uint32_t)k[1])<<16; - case 1 : a+=((uint32_t)k[0])<<24; - break; - case 0 : return c; + switch ( length ) { /* all the case statements fall through */ + case 12: + c += k[11]; + case 11: + c += ( ( uint32_t ) k[10] ) << 8; + case 10: + c += ( ( uint32_t ) k[9] ) << 16; + case 9: + c += ( ( uint32_t ) k[8] ) << 24; + case 8: + b += k[7]; + case 7: + b += ( ( uint32_t ) k[6] ) << 8; + case 6: + b += ( ( uint32_t ) k[5] ) << 16; + case 5: + b += ( ( uint32_t ) k[4] ) << 24; + case 4: + a += k[3]; + case 3: + a += ( ( uint32_t ) k[2] ) << 8; + case 2: + a += ( ( uint32_t ) k[1] ) << 16; + case 1: + a += ( ( uint32_t ) k[0] ) << 24; + break; + case 0: + return c; + } } - } - final(a,b,c); - return c; + final( a, b, c ); + return c; } #ifdef SELF_TEST /* used for timings */ -void driver1() -{ - uint8_t buf[256]; - uint32_t i; - uint32_t h=0; - time_t a,z; +void driver1( ) { + uint8_t buf[256]; + uint32_t i; + uint32_t h = 0; + time_t a, z; - time(&a); - for (i=0; i<256; ++i) buf[i] = 'x'; - for (i=0; i<1; ++i) - { - h = hashlittle(&buf[0],1,h); - } - time(&z); - if (z-a > 0) printf("time %d %.8x\n", z-a, h); + time( &a ); + for ( i = 0; i < 256; ++i ) + buf[i] = 'x'; + for ( i = 0; i < 1; ++i ) { + h = hashlittle( &buf[0], 1, h ); + } + time( &z ); + if ( z - a > 0 ) + printf( "time %d %.8x\n", z - a, h ); } /* check that every input bit changes every output bit half the time */ @@ -789,213 +1019,263 @@ void driver1() #define HASHLEN 1 #define MAXPAIR 60 #define MAXLEN 70 -void driver2() -{ - uint8_t qa[MAXLEN+1], qb[MAXLEN+2], *a = &qa[0], *b = &qb[1]; - uint32_t c[HASHSTATE], d[HASHSTATE], i=0, j=0, k, l, m=0, z; - uint32_t e[HASHSTATE],f[HASHSTATE],g[HASHSTATE],h[HASHSTATE]; - uint32_t x[HASHSTATE],y[HASHSTATE]; - uint32_t hlen; +void driver2( ) { + uint8_t qa[MAXLEN + 1], qb[MAXLEN + 2], *a = &qa[0], *b = &qb[1]; + uint32_t c[HASHSTATE], d[HASHSTATE], i = 0, j = 0, k, l, m = 0, z; + uint32_t e[HASHSTATE], f[HASHSTATE], g[HASHSTATE], h[HASHSTATE]; + uint32_t x[HASHSTATE], y[HASHSTATE]; + uint32_t hlen; - printf("No more than %d trials should ever be needed \n",MAXPAIR/2); - for (hlen=0; hlen < MAXLEN; ++hlen) - { - z=0; - for (i=0; i>(8-j)); - c[0] = hashlittle(a, hlen, m); - b[i] ^= ((k+1)<>(8-j)); - d[0] = hashlittle(b, hlen, m); - /* check every bit is 1, 0, set, and not set at least once */ - for (l=0; lz) z=k; - if (k==MAXPAIR) - { - printf("Some bit didn't change: "); - printf("%.8x %.8x %.8x %.8x %.8x %.8x ", - e[0],f[0],g[0],h[0],x[0],y[0]); - printf("i %d j %d m %d len %d\n", i, j, m, hlen); - } - if (z==MAXPAIR) goto done; - } - } + /*---- check that every output bit is affected by that input bit */ + for ( k = 0; k < MAXPAIR; k += 2 ) { + uint32_t finished = 1; + /* keys have one bit different */ + for ( l = 0; l < hlen + 1; ++l ) { + a[l] = b[l] = ( uint8_t ) 0; + } + /* have a and b be two keys differing in only one bit */ + a[i] ^= ( k << j ); + a[i] ^= ( k >> ( 8 - j ) ); + c[0] = hashlittle( a, hlen, m ); + b[i] ^= ( ( k + 1 ) << j ); + b[i] ^= ( ( k + 1 ) >> ( 8 - j ) ); + d[0] = hashlittle( b, hlen, m ); + /* check every bit is 1, 0, set, and not set at least once */ + for ( l = 0; l < HASHSTATE; ++l ) { + e[l] &= ( c[l] ^ d[l] ); + f[l] &= ~( c[l] ^ d[l] ); + g[l] &= c[l]; + h[l] &= ~c[l]; + x[l] &= d[l]; + y[l] &= ~d[l]; + if ( e[l] | f[l] | g[l] | h[l] | x[l] | y[l] ) + finished = 0; + } + if ( finished ) + break; + } + if ( k > z ) + z = k; + if ( k == MAXPAIR ) { + printf( "Some bit didn't change: " ); + printf( "%.8x %.8x %.8x %.8x %.8x %.8x ", + e[0], f[0], g[0], h[0], x[0], y[0] ); + printf( "i %d j %d m %d len %d\n", i, j, m, hlen ); + } + if ( z == MAXPAIR ) + goto done; + } + } + } + done: + if ( z < MAXPAIR ) { + printf( "Mix success %2d bytes %2d initvals ", i, m ); + printf( "required %d trials\n", z / 2 ); + } } - done: - if (z < MAXPAIR) - { - printf("Mix success %2d bytes %2d initvals ",i,m); - printf("required %d trials\n", z/2); - } - } - printf("\n"); + printf( "\n" ); } /* Check for reading beyond the end of the buffer and alignment problems */ -void driver3() -{ - uint8_t buf[MAXLEN+20], *b; - uint32_t len; - uint8_t q[] = "This is the time for all good men to come to the aid of their country..."; - uint32_t h; - uint8_t qq[] = "xThis is the time for all good men to come to the aid of their country..."; - uint32_t i; - uint8_t qqq[] = "xxThis is the time for all good men to come to the aid of their country..."; - uint32_t j; - uint8_t qqqq[] = "xxxThis is the time for all good men to come to the aid of their country..."; - uint32_t ref,x,y; - uint8_t *p; +void driver3( ) { + uint8_t buf[MAXLEN + 20], *b; + uint32_t len; + uint8_t q[] = + "This is the time for all good men to come to the aid of their country..."; + uint32_t h; + uint8_t qq[] = + "xThis is the time for all good men to come to the aid of their country..."; + uint32_t i; + uint8_t qqq[] = + "xxThis is the time for all good men to come to the aid of their country..."; + uint32_t j; + uint8_t qqqq[] = + "xxxThis is the time for all good men to come to the aid of their country..."; + uint32_t ref, x, y; + uint8_t *p; - printf("Endianness. These lines should all be the same (for values filled in):\n"); - printf("%.8x %.8x %.8x\n", - hashword((const uint32_t *)q, (sizeof(q)-1)/4, 13), - hashword((const uint32_t *)q, (sizeof(q)-5)/4, 13), - hashword((const uint32_t *)q, (sizeof(q)-9)/4, 13)); - p = q; - printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), - hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), - hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), - hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), - hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), - hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); - p = &qq[1]; - printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), - hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), - hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), - hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), - hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), - hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); - p = &qqq[2]; - printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), - hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), - hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), - hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), - hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), - hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); - p = &qqqq[3]; - printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), - hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), - hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), - hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), - hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), - hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); - printf("\n"); + printf + ( "Endianness. These lines should all be the same (for values filled in):\n" ); + printf + ( "%.8x %.8x %.8x\n", + hashword( ( const uint32_t * ) q, ( sizeof( q ) - 1 ) / 4, 13 ), + hashword( ( const uint32_t * ) q, ( sizeof( q ) - 5 ) / 4, 13 ), + hashword( ( const uint32_t * ) q, ( sizeof( q ) - 9 ) / 4, 13 ) ); + p = q; + printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, + sizeof( q ) - 2, + 13 ), + hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, + sizeof( q ) - 4, + 13 ), + hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, + sizeof( q ) - 6, + 13 ), + hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, + sizeof( q ) - 8, + 13 ), + hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, + sizeof( q ) - 10, + 13 ), + hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, + sizeof( q ) - + 12, 13 ) ); + p = &qq[1]; + printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, + sizeof( q ) - 2, + 13 ), + hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, + sizeof( q ) - 4, + 13 ), + hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, + sizeof( q ) - 6, + 13 ), + hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, + sizeof( q ) - 8, + 13 ), + hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, + sizeof( q ) - 10, + 13 ), + hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, + sizeof( q ) - + 12, 13 ) ); + p = &qqq[2]; + printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, + sizeof( q ) - 2, + 13 ), + hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, + sizeof( q ) - 4, + 13 ), + hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, + sizeof( q ) - 6, + 13 ), + hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, + sizeof( q ) - 8, + 13 ), + hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, + sizeof( q ) - 10, + 13 ), + hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, + sizeof( q ) - + 12, 13 ) ); + p = &qqqq[3]; + printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, + sizeof( q ) - 2, + 13 ), + hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, + sizeof( q ) - 4, + 13 ), + hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, + sizeof( q ) - 6, + 13 ), + hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, + sizeof( q ) - 8, + 13 ), + hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, + sizeof( q ) - 10, + 13 ), + hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, + sizeof( q ) - + 12, 13 ) ); + printf( "\n" ); - /* check that hashlittle2 and hashlittle produce the same results */ - i=47; j=0; - hashlittle2(q, sizeof(q), &i, &j); - if (hashlittle(q, sizeof(q), 47) != i) - printf("hashlittle2 and hashlittle mismatch\n"); + /* check that hashlittle2 and hashlittle produce the same results */ + i = 47; + j = 0; + hashlittle2( q, sizeof( q ), &i, &j ); + if ( hashlittle( q, sizeof( q ), 47 ) != i ) + printf( "hashlittle2 and hashlittle mismatch\n" ); - /* check that hashword2 and hashword produce the same results */ - len = 0xdeadbeef; - i=47, j=0; - hashword2(&len, 1, &i, &j); - if (hashword(&len, 1, 47) != i) - printf("hashword2 and hashword mismatch %x %x\n", - i, hashword(&len, 1, 47)); + /* check that hashword2 and hashword produce the same results */ + len = 0xdeadbeef; + i = 47, j = 0; + hashword2( &len, 1, &i, &j ); + if ( hashword( &len, 1, 47 ) != i ) + printf( "hashword2 and hashword mismatch %x %x\n", + i, hashword( &len, 1, 47 ) ); - /* check hashlittle doesn't read before or after the ends of the string */ - for (h=0, b=buf+1; h<8; ++h, ++b) - { - for (i=0; iheader.tag.value ) { - case HASHTV: - free_hashmap( pointer ); - break; - case STACKFRAMETV: - free_stack_frame( get_stack_frame( pointer ) ); - break; - } + switch ( vso->header.tag.value ) { + case HASHTV: + free_hashmap( pointer ); + break; + case STACKFRAMETV: + free_stack_frame( get_stack_frame( pointer ) ); + break; + } // free( (void *)cell.payload.vectorp.address ); - debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", - cell.payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", + cell.payload.vectorp.address ); } // bool check_vso_tag( struct cons_pointer pointer, char * tag) { diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 2eea84d..3265225 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -61,7 +61,7 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ); -void free_vso(struct cons_pointer pointer); +void free_vso( struct cons_pointer pointer ); /** * the header which forms the start of every vector space object. @@ -86,18 +86,16 @@ struct vector_space_header { * i.e. either an assoc list or a further hashmap. */ struct hashmap_payload { - struct cons_pointer - hash_fn; /* function for hashing values in this hashmap, or `NIL` to use - the default hashing function */ - struct cons_pointer write_acl; /* it seems to me that it is likely that the - * principal difference between a hashmap and a - * namespace is that a hashmap has a write ACL - * of `NIL`, meaning not writeable by anyone */ - uint32_t n_buckets; /* number of hash buckets */ - uint32_t unused; /* for word alignment and possible later expansion */ - struct cons_pointer - buckets[]; /* actual hash buckets, which should be `NIL` - * or assoc lists or (possibly) further hashmaps. */ + struct cons_pointer hash_fn; /* function for hashing values in this hashmap, or `NIL` to use + the default hashing function */ + struct cons_pointer write_acl; /* it seems to me that it is likely that the + * principal difference between a hashmap and a + * namespace is that a hashmap has a write ACL + * of `NIL`, meaning not writeable by anyone */ + uint32_t n_buckets; /* number of hash buckets */ + uint32_t unused; /* for word alignment and possible later expansion */ + struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL` + * or assoc lists or (possibly) further hashmaps. */ }; diff --git a/src/ops/equal.c b/src/ops/equal.c index feffb93..a02acc8 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -20,9 +20,8 @@ * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. */ -bool eq(struct cons_pointer a, struct cons_pointer b) -{ - return ((a.page == b.page) && (a.offset == b.offset)); +bool eq( struct cons_pointer a, struct cons_pointer b ) { + return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); } /** @@ -32,10 +31,9 @@ bool eq(struct cons_pointer a, struct cons_pointer b) * @return true if the objects at these two cons pointers have the same tag, * else false. */ -bool same_type(struct cons_pointer a, struct cons_pointer b) -{ - struct cons_space_object *cell_a = &pointer2cell(a); - struct cons_space_object *cell_b = &pointer2cell(b); +bool same_type( struct cons_pointer a, struct cons_pointer b ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); return cell_a->tag.value == cell_b->tag.value; } @@ -45,104 +43,95 @@ bool same_type(struct cons_pointer a, struct cons_pointer b) * @param string the string to test * @return true if it's the end of a string. */ -bool end_of_string(struct cons_pointer string) -{ - return nilp(string) || - pointer2cell(string).payload.string.character == '\0'; +bool end_of_string( struct cons_pointer string ) { + return nilp( string ) || + pointer2cell( string ).payload.string.character == '\0'; } /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal(struct cons_pointer a, struct cons_pointer b) -{ - bool result = eq(a, b); +bool equal( struct cons_pointer a, struct cons_pointer b ) { + bool result = eq( a, b ); - if (!result && same_type(a, b)) - { - struct cons_space_object *cell_a = &pointer2cell(a); - struct cons_space_object *cell_b = &pointer2cell(b); + if ( !result && same_type( a, b ) ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); - switch (cell_a->tag.value) - { - case CONSTV: - case LAMBDATV: - case NLAMBDATV: - /* TODO: it is not OK to do this on the stack since list-like - * structures can be of indefinite extent. It *must* be done by - * iteration (and even that is problematic) */ - result = - equal(cell_a->payload.cons.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr, - cell_b->payload.cons.cdr); - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - /* slightly complex because a string may or may not have a '\0' - * cell at the end, but I'll ignore that for now. I think in - * practice only the empty string will. - */ - /* TODO: it is not OK to do this on the stack since list-like - * structures can be of indefinite extent. It *must* be done by - * iteration (and even that is problematic) */ - result = - cell_a->payload.string.character == + switch ( cell_a->tag.value ) { + case CONSTV: + case LAMBDATV: + case NLAMBDATV: + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ + result = + equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) + && equal( cell_a->payload.cons.cdr, + cell_b->payload.cons.cdr ); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + /* slightly complex because a string may or may not have a '\0' + * cell at the end, but I'll ignore that for now. I think in + * practice only the empty string will. + */ + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ + result = + cell_a->payload.string.character == cell_b->payload.string.character && - (equal(cell_a->payload.string.cdr, - cell_b->payload.string.cdr) || - (end_of_string(cell_a->payload.string.cdr) && end_of_string(cell_b->payload.string.cdr))); - break; - case INTEGERTV: - result = - (cell_a->payload.integer.value == - cell_b->payload.integer.value) && - equal(cell_a->payload.integer.more, - cell_b->payload.integer.more); - break; - case RATIOTV: - result = equal_ratio_ratio(a, b); - break; - case REALTV: - { - double num_a = to_long_double(a); - double num_b = to_long_double(b); - double max = - fabs(num_a) > - fabs(num_b) - ? fabs(num_a) - : fabs(num_b); + ( equal( cell_a->payload.string.cdr, + cell_b->payload.string.cdr ) || + ( end_of_string( cell_a->payload.string.cdr ) + && end_of_string( cell_b->payload.string.cdr ) ) ); + break; + case INTEGERTV: + result = + ( cell_a->payload.integer.value == + cell_b->payload.integer.value ) && + equal( cell_a->payload.integer.more, + cell_b->payload.integer.more ); + break; + case RATIOTV: + result = equal_ratio_ratio( a, b ); + break; + case REALTV: + { + double num_a = to_long_double( a ); + double num_b = to_long_double( b ); + double max = fabs( num_a ) > fabs( num_b ) + ? fabs( num_a ) + : fabs( num_b ); - /* - * not more different than one part in a million - close enough - */ - result = fabs(num_a - num_b) < (max / 1000000.0); + /* + * not more different than one part in a million - close enough + */ + result = fabs( num_a - num_b ) < ( max / 1000000.0 ); + } + break; + default: + result = false; + break; } - break; - default: - result = false; - break; - } - } - else if (numberp(a) && numberp(b)) - { - if (integerp(a)) - { - result = equal_integer_real(a, b); - } - else if (integerp(b)) - { - result = equal_integer_real(b, a); + } else if ( numberp( a ) && numberp( b ) ) { + if ( integerp( a ) ) { + result = equal_integer_real( a, b ); + } else if ( integerp( b ) ) { + result = equal_integer_real( b, a ); } } /* - * there's only supposed ever to be one T and one NIL cell, so each - * should be caught by eq; equality of vector-space objects is a whole - * other ball game so we won't deal with it now (and indeed may never). - * I'm not certain what equality means for read and write streams, so - * I'll ignore them, too, for now. - */ + * there's only supposed ever to be one T and one NIL cell, so each + * should be caught by eq; equality of vector-space objects is a whole + * other ball game so we won't deal with it now (and indeed may never). + * I'm not certain what equality means for read and write streams, so + * I'll ignore them, too, for now. + */ return result; } diff --git a/src/ops/intern.c b/src/ops/intern.c index 07b9693..d7b81c6 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -89,16 +89,16 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { * of that key from the store; otherwise return NIL. */ struct cons_pointer c_assoc( struct cons_pointer key, - struct cons_pointer store ) { + struct cons_pointer store ) { struct cons_pointer result = NIL; - debug_print( L"c_assoc; key is `", DEBUG_BIND); - debug_print_object( key, DEBUG_BIND); - debug_print( L"`\n", DEBUG_BIND); + debug_print( L"c_assoc; key is `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); - if (consp(store)) { + if ( consp( store ) ) { for ( struct cons_pointer next = store; - consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { + consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { struct cons_space_object entry = pointer2cell( pointer2cell( next ).payload.cons.car ); @@ -107,15 +107,17 @@ struct cons_pointer c_assoc( struct cons_pointer key, break; } } - } else if (hashmapp( store)) { - result = hashmap_get( store, key); + } else if ( hashmapp( store ) ) { + result = hashmap_get( store, key ); } else { - result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL); + result = + throw_exception( c_string_to_lisp_string + ( L"Store is of unknown type" ), NIL ); } - debug_print( L"c_assoc returning ", DEBUG_BIND); - debug_print_object( result, DEBUG_BIND); - debug_println( DEBUG_BIND); + debug_print( L"c_assoc returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND ); return result; } @@ -125,8 +127,8 @@ struct cons_pointer c_assoc( struct cons_pointer key, * with this key/value pair added to the front. */ struct cons_pointer - set( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { +set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { struct cons_pointer result = NIL; debug_print( L"set: binding `", DEBUG_BIND ); @@ -134,18 +136,18 @@ struct cons_pointer debug_print( L"` to `", DEBUG_BIND ); debug_print_object( value, DEBUG_BIND ); debug_print( L"` in store ", DEBUG_BIND ); - debug_dump_object( store, DEBUG_BIND); + debug_dump_object( store, DEBUG_BIND ); debug_println( DEBUG_BIND ); - if (nilp( store) || consp(store)) { + if ( nilp( store ) || consp( store ) ) { result = make_cons( make_cons( key, value ), store ); - } else if (hashmapp( store)) { - result = hashmap_put( store, key, value); + } else if ( hashmapp( store ) ) { + result = hashmap_put( store, key, value ); } - debug_print( L"set returning ", DEBUG_BIND); - debug_print_object( result, DEBUG_BIND); - debug_println( DEBUG_BIND); + debug_print( L"set returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND ); return result; } @@ -195,4 +197,3 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { return result; } - diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 474784d..454fb9a 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -106,7 +106,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame, list = c_cdr( list ); } - return c_reverse( result); + return c_reverse( result ); } /** @@ -121,19 +121,18 @@ struct cons_pointer eval_forms( struct stack_frame *frame, * * This is experimental. It almost certainly WILL change. */ -struct cons_pointer lisp_try(struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env) { - struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); +struct cons_pointer lisp_try( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = + c_progn( frame, frame_pointer, frame->arg[0], env ); - if (exceptionp(result)) - { + if ( exceptionp( result ) ) { // TODO: need to put the exception into the environment! - result = c_progn(frame, frame_pointer, frame->arg[1], - make_cons( - make_cons(c_string_to_lisp_keyword(L"*exception*"), - result), - env)); + result = c_progn( frame, frame_pointer, frame->arg[1], + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"*exception*" ), result ), env ) ); } return result; @@ -282,8 +281,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, result = eval_form( frame, frame_pointer, sexpr, new_env ); - if (exceptionp(result)) - { + if ( exceptionp( result ) ) { break; } } @@ -306,8 +304,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, * @return the result of evaluating the function with its arguments. */ struct cons_pointer - c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { +c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { debug_print( L"Entering c_apply\n", DEBUG_EVAL ); struct cons_pointer result = NIL; @@ -322,122 +320,124 @@ struct cons_pointer switch ( fn_cell.tag.value ) { case EXCEPTIONTV: - /* just pass exceptions straight back */ - result = fn_pointer; - break; + /* just pass exceptions straight back */ + result = fn_pointer; + break; case FUNCTIONTV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); - result = - ( *fn_cell.payload.function.executable ) ( next, - next_pointer, - env ); - dec_ref( next_pointer ); - } - } - break; - - case KEYTV: - result = c_assoc( fn_pointer, - eval_form(frame, - frame_pointer, - c_car( c_cdr( frame->arg[0])), - env)); - break; - - case LAMBDATV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - if ( !exceptionp( result ) ) { + result = + ( *fn_cell.payload.function.executable ) ( next, + next_pointer, + env ); dec_ref( next_pointer ); } } - } - break; + break; + + case KEYTV: + result = c_assoc( fn_pointer, + eval_form( frame, + frame_pointer, + c_car( c_cdr( frame->arg[0] ) ), + env ) ); + break; + + case LAMBDATV: + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); + } + } + } + break; case VECTORPOINTTV: - switch ( pointer_to_vso(fn_pointer)->header.tag.value) { - case HASHTV: - /* \todo: if arg[0] is a CONS, treat it as a path */ - result = c_assoc( eval_form(frame, - frame_pointer, - c_car( c_cdr( frame->arg[0])), - env), - fn_pointer); + switch ( pointer_to_vso( fn_pointer )->header.tag.value ) { + case HASHTV: + /* \todo: if arg[0] is a CONS, treat it as a path */ + result = c_assoc( eval_form( frame, + frame_pointer, + c_car( c_cdr + ( frame-> + arg[0] ) ), + env ), fn_pointer ); + break; + } break; - } - break; case NLAMBDATV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - dec_ref( next_pointer ); + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); + } } - } - break; + break; case SPECIALTV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); - debug_print( L"Special form returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - dec_ref( next_pointer ); + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); + debug_print( L"Special form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + dec_ref( next_pointer ); + } } - } - break; + break; default: - { - 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 ); - result = throw_exception( message, frame_pointer ); - } + { + 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 ); + result = throw_exception( message, frame_pointer ); + } } } @@ -479,7 +479,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, switch ( cell.tag.value ) { case CONSTV: - result = c_apply( frame, frame_pointer, env ); + result = c_apply( frame, frame_pointer, env ); break; case SYMBOLTV: @@ -781,9 +781,10 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, * @param env my environment (ignored). * @return the length of `any`, if it is a sequence, or zero otherwise. */ -struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_integer( c_length( frame->arg[0]), NIL); +struct cons_pointer lisp_length( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_integer( c_length( frame->arg[0] ), NIL ); } /** @@ -802,24 +803,24 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, return c_assoc( frame->arg[0], frame->arg[1] ); } -struct cons_pointer c_keys(struct cons_pointer store) { - struct cons_pointer result = NIL; +struct cons_pointer c_keys( struct cons_pointer store ) { + struct cons_pointer result = NIL; - if ( hashmapp( store ) ) { - result = hashmap_keys( store ); - } else if ( consp( store ) ) { - for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) { - result = make_cons( c_car( c ), result ); + if ( hashmapp( store ) ) { + result = hashmap_keys( store ); + } else if ( consp( store ) ) { + for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) { + result = make_cons( c_car( c ), result ); + } } - } - return result; + return result; } struct cons_pointer lisp_keys( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return c_keys( frame->arg[0]); + return c_keys( frame->arg[0] ); } /** @@ -962,26 +963,26 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); - struct cons_pointer result = NIL; - struct cons_pointer out_stream = writep( frame->arg[1] ) - ? frame->arg[1] - : get_default_stream( false, env ); - URL_FILE *output; + debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); + struct cons_pointer result = NIL; + struct cons_pointer out_stream = writep( frame->arg[1] ) + ? frame->arg[1] + : get_default_stream( false, env ); + URL_FILE *output; - if ( writep( out_stream ) ) { - debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); - debug_dump_object( out_stream, DEBUG_IO ); - output = pointer2cell( out_stream ).payload.stream.stream; - } else { - output = file_to_url_file( stderr ); - } + if ( writep( out_stream ) ) { + debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + } else { + output = file_to_url_file( stderr ); + } - dump_object( output, frame->arg[0] ); + dump_object( output, frame->arg[0] ); - debug_print( L"Leaving lisp_inspect", DEBUG_IO ); + debug_print( L"Leaving lisp_inspect", DEBUG_IO ); - return result; + return result; } /** @@ -1064,7 +1065,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, result = eval_form( frame, frame_pointer, c_car( expressions ), env ); dec_ref( r ); - expressions = exceptionp(result) ? NIL : c_cdr( expressions ); + expressions = exceptionp( result ) ? NIL : c_cdr( expressions ); } return result; @@ -1332,7 +1333,7 @@ struct cons_pointer lisp_source( struct stack_frame *frame, case SPECIALTV: result = c_assoc( source_key, cell.payload.special.meta ); break; - case LAMBDATV: + case LAMBDATV: result = make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( cell.payload.lambda.args, cell.payload.lambda.body ) ); diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 014df2e..c1cc337 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -127,8 +127,8 @@ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_inspect( 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 lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/time/psse_time.c b/src/time/psse_time.c index e37e522..1f24b0e 100644 --- a/src/time/psse_time.c +++ b/src/time/psse_time.c @@ -28,42 +28,44 @@ * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before * the UNIX epoch; the value in microseconds will break the C reader. */ -unsigned __int128 epoch_offset = ((__int128)(seconds_per_year * 1000000000L) * - (__int128)(14L * 1000000000L)); +unsigned __int128 epoch_offset = + ( ( __int128 ) ( seconds_per_year * 1000000000L ) * + ( __int128 ) ( 14L * 1000000000L ) ); /** * Return the UNIX time value which represents this time, if it falls within * the period representable in UNIX time, or zero otherwise. */ -long int lisp_time_to_unix_time(struct cons_pointer t) { +long int lisp_time_to_unix_time( struct cons_pointer t ) { long int result = 0; - if (timep( t)) { - unsigned __int128 value = pointer2cell(t).payload.time.value; + if ( timep( t ) ) { + unsigned __int128 value = pointer2cell( t ).payload.time.value; - if (value > epoch_offset) { // \todo && value < UNIX time rollover - result = ((value - epoch_offset) / 1000000000); + if ( value > epoch_offset ) { // \todo && value < UNIX time rollover + result = ( ( value - epoch_offset ) / 1000000000 ); } } return result; } -unsigned __int128 unix_time_to_lisp_time( time_t t) { - unsigned __int128 result = epoch_offset + (t * 1000000000); +unsigned __int128 unix_time_to_lisp_time( time_t t ) { + unsigned __int128 result = epoch_offset + ( t * 1000000000 ); return result; } -struct cons_pointer make_time( struct cons_pointer integer_or_nil) { +struct cons_pointer make_time( struct cons_pointer integer_or_nil ) { struct cons_pointer pointer = allocate_cell( TIMETV ); struct cons_space_object *cell = &pointer2cell( pointer ); - if (integerp(integer_or_nil)) { - cell->payload.time.value = pointer2cell(integer_or_nil).payload.integer.value; + if ( integerp( integer_or_nil ) ) { + cell->payload.time.value = + pointer2cell( integer_or_nil ).payload.integer.value; // \todo: if integer is a bignum, deal with it. } else { - cell->payload.time.value = unix_time_to_lisp_time( time(NULL)); + cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); } return pointer; @@ -82,25 +84,26 @@ struct cons_pointer make_time( struct cons_pointer integer_or_nil) { * is that number of microseconds after the notional big bang; else the current * time. */ -struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_time( frame->arg[0]); +struct cons_pointer lisp_time( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_time( frame->arg[0] ); } /** * This is temporary, for bootstrapping. */ -struct cons_pointer time_to_string( struct cons_pointer pointer) { +struct cons_pointer time_to_string( struct cons_pointer pointer ) { struct cons_pointer result = NIL; - long int t = lisp_time_to_unix_time(pointer); + long int t = lisp_time_to_unix_time( pointer ); - if ( t != 0) { - char * bytes = ctime(&t); - int l = strlen(bytes) + 1; - wchar_t buffer[ l]; + if ( t != 0 ) { + char *bytes = ctime( &t ); + int l = strlen( bytes ) + 1; + wchar_t buffer[l]; - mbstowcs( buffer, bytes, l); - result = c_string_to_lisp_string( buffer); + mbstowcs( buffer, bytes, l ); + result = c_string_to_lisp_string( buffer ); } return result; diff --git a/src/time/psse_time.h b/src/time/psse_time.h index af70966..f2afdd2 100644 --- a/src/time/psse_time.h +++ b/src/time/psse_time.h @@ -13,8 +13,9 @@ #define _GNU_SOURCE #include "consspaceobject.h" -struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer time_to_string( struct cons_pointer pointer); +struct cons_pointer lisp_time( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer time_to_string( struct cons_pointer pointer ); #endif From b6ae110f66ac1c85f1f9b00e45db1610c198608d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 18 Aug 2021 11:00:47 +0100 Subject: [PATCH 087/101] Hybrid assoc lists --- docs/Hybrid-assoc-lists.md | 40 ++++++++++++++++++ src/ops/equal.c | 1 + src/ops/intern.c | 85 +++++++++++++++++++++----------------- 3 files changed, 89 insertions(+), 37 deletions(-) create mode 100644 docs/Hybrid-assoc-lists.md diff --git a/docs/Hybrid-assoc-lists.md b/docs/Hybrid-assoc-lists.md new file mode 100644 index 0000000..5bb6ca8 --- /dev/null +++ b/docs/Hybrid-assoc-lists.md @@ -0,0 +1,40 @@ +# Hybrid assoc lists + +In it's current very prototype stage, PSSE has to forms of name/value store. One is the assoc list, the other is the hashmap. + +An assoc (association) list is a list of the form: + + ((name1 . value1)(name2 . value2)(name3 . value3)...) + +Hashmaps have many very clear advantages, but assoc lists have one which is very important in the evaluation environment, and that is precisely its sequentiality. Thus, if the same name is bound twice on an assoc list, the value nearest the head is the one which will be recovered: + + (assoc :bar '((:foo . 1) (:bar . "Hello there!")(:ban . 3)(:bar . 2))) + => "Hello there!" + +Why does this matter? Well, for precisely the same reason it matters when a UNIX system searches for an executable. + +Suppose Clare is a user who trusts both Alice and Bob, but she trusts Alice more than Bob. Suppose both Alice and Bob have written implementations of a function called `froboz`. Suppose Clare invokes + + (froboz 3) + +Which implementation of `froboz` should be evaluated? An assoc list makes that simple. If Clare binds Alice's implementation into her environment later than Bob's, Alice's will be the one found. + +But an assoc list is also fearsomely inefficient, especially if we are in a system with many thousands of names, each of which may be bound multiple times in typical runtime environment. + +How to resolve this? How to get some of the benefits of sequential access of assoc lists, with some of the efficiency benefits of hashmaps? What I'm going to propose is a **hybrid assoc list**, that is to say, a list whose members are either + +1. (key . value) pairs, or else +2. hashmaps. + +So suppose we have a list, `l`, thus: + + ((:foo . 1) (:bar . 2) {:foo "not this" :ban 3} (:ban . "not this either") (:froboz . 4)) + +Then: + + (assoc :foo l) => 1 + (assoc :bar l) => 2 + (assoc :ban l) => 3 + (assoc :froboz l) => 4 + +This will make the implementation of namespaces and search paths vastly easier. \ No newline at end of file diff --git a/src/ops/equal.c b/src/ops/equal.c index a02acc8..36f73ed 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -82,6 +82,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * structures can be of indefinite extent. It *must* be done by * iteration (and even that is problematic) */ result = + cell_a->payload.string.hash == cell_b->payload.string.hash && cell_a->payload.string.character == cell_b->payload.string.character && ( equal( cell_a->payload.string.cdr, diff --git a/src/ops/intern.c b/src/ops/intern.c index d7b81c6..e541bdf 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -90,56 +90,67 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { */ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - debug_print( L"c_assoc; key is `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"`\n", DEBUG_BIND ); + debug_print( L"c_assoc; key is `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); - if ( consp( store ) ) { - for ( struct cons_pointer next = store; - consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { - struct cons_space_object entry = - pointer2cell( pointer2cell( next ).payload.cons.car ); + if ( consp( store ) ) { + for ( struct cons_pointer next = store; + nilp( result ) && ( consp( next ) || hashmapp( next ) ); + next = pointer2cell( next ).payload.cons.cdr ) { + if ( consp( next ) ) { + struct cons_pointer entry_ptr = c_car( next ); + struct cons_space_object entry = pointer2cell( entry_ptr ); + switch ( entry.tag.value ) { + case CONSTV: if ( equal( key, entry.payload.cons.car ) ) { - result = entry.payload.cons.cdr; - break; + result = entry.payload.cons.cdr; } + break; + case VECTORPOINTTV: + result = hashmap_get( entry_ptr, key ); + break; + default: + throw_exception( + c_string_to_lisp_string( L"Store entry is of unknown type" ), + NIL ); } - } else if ( hashmapp( store ) ) { - result = hashmap_get( store, key ); - } else { - result = - throw_exception( c_string_to_lisp_string - ( L"Store is of unknown type" ), NIL ); + } } + } else if ( hashmapp( store ) ) { + result = hashmap_get( store, key ); + } else if (!nilp(store)) { + result = throw_exception( + c_string_to_lisp_string( L"Store is of unknown type" ), NIL ); + } - debug_print( L"c_assoc returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"c_assoc returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND ); - return result; + return result; } -/** - * Return a new key/value store containing all the key/value pairs in this store - * with this key/value pair added to the front. - */ -struct cons_pointer -set( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { - struct cons_pointer result = NIL; + /** + * Return a new key/value store containing all the key/value pairs in this + * store with this key/value pair added to the front. + */ + struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { + struct cons_pointer result = NIL; - debug_print( L"set: binding `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"` to `", DEBUG_BIND ); - debug_print_object( value, DEBUG_BIND ); - debug_print( L"` in store ", DEBUG_BIND ); - debug_dump_object( store, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"set: binding `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` to `", DEBUG_BIND ); + debug_print_object( value, DEBUG_BIND ); + debug_print( L"` in store ", DEBUG_BIND ); + debug_dump_object( store, DEBUG_BIND ); + debug_println( DEBUG_BIND ); - if ( nilp( store ) || consp( store ) ) { + if ( nilp( store ) || consp( store ) ) { result = make_cons( make_cons( key, value ), store ); } else if ( hashmapp( store ) ) { result = hashmap_put( store, key, value ); From 5c6ac7f75dcb07478e6ade237b85be92221fe52b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 18 Aug 2021 13:40:35 +0100 Subject: [PATCH 088/101] Making progress on paths! --- docs/How-do-we-notate-paths.md | 89 +++++++++++++++++++++++++++++++++ src/memory/hashmap.c | 13 +++-- src/ops/equal.c | 16 +++--- src/ops/intern.c | 91 +++++++++++++++++----------------- src/ops/lispops.c | 6 +-- 5 files changed, 153 insertions(+), 62 deletions(-) create mode 100644 docs/How-do-we-notate-paths.md diff --git a/docs/How-do-we-notate-paths.md b/docs/How-do-we-notate-paths.md new file mode 100644 index 0000000..7cdbcb0 --- /dev/null +++ b/docs/How-do-we-notate-paths.md @@ -0,0 +1,89 @@ +# How do we notate paths? + +In order to make the namespaces thing work, we need a convenient way to notate paths from the current namespace to a target, or from the root to a target. This is similar to relative and absolute paths in UNIX, except that in PSSE there is no concept of a single or privileged ancestor namespace to the current namespace, so you have no equivalent of `../`. + +In this discussion, a **namespace** is just a named, mutable hashmap (but not necessarily mutable by all users; indeed namespaces will almost always be mutable only by selected users. I cannot presently see a justified use for a publicly writable namespace). '**Named**', of a hashmap, merely means there is some path from the privileged root namespace which is the value of `oblist` which leads to that hashmap. A **path** is in principle just a sequence of keys, such that the value of each successive key is bound to a namespace in the namespace bound by its predecessor. The evaluable implementation of paths will be discussed later. + +I think also that there must be a privileged **session** namespace, containing information about the current session, which the user can read but not write. + +## Security considerations + +What's important is that a user cannot rebind privileged names in their own environment. Thus to ensure privileged names, such names must be paths either from the `oblist`or from the current session. So we need magic, privileged notations for these things built into the reader, which cannot be overridden. + +This kind of takes away from my general feeling that users should be able to override *anything*. but hey, that's engineering for you. + +Users should be able to override reader macros generally; a programmable reader is in the medium term something which should be implemented. But the privileged syntax for paths should not be overridable. + +## Current state of the reader + +At present, you can rebind the value of the symbol `oblist` in the runtime environment. In principle, you should be able to rebind any symbol. Paths and symbols are not the same. + +At present, the colon character is a separator character. So if you type + +> (list :foo:bar:ban) + +the reader will return + +> (list :foo :bar :ban) + +That's significant, and helpful. + +## Constructing path notation + +The Clojure threading macro, `->`, is a useful example of how we can implement this. Essentially it takes a expression as its first argument, passes the value of that expression to the function which is its second argument, the value of that as argument to the function which is its next, and so on. Given that, in Clojure, an expression which has a keyword in the function position and a hashmap in the argument position will return the value of that keyword in that hashmap, this means that, given the hashmap + +> (def x {:foo {:bar {:ban "Howzat!!"}}}) + +the expression + +> (-> x :foo :bar :ban) + +will return + +> "Howzat!!" + +So, in general, if we implement the 'keyword in the function position' `eval` hack and the threading macro, then something like + +> (-> oblist :users :simon :functions 'foo) + +should return the value of the symbol `foo` in the `:functions` of the user called `:simon`. + +That's stage one of our goal. + +Stage two of our goal is that a stream of non-separator characters separated by colons should be interpreted as a list of keywords. Thus typing + +> :foo:bar:ban + +should result in not just `:foo`being read, but the list `(:foo :bar :ban)`(? not sure about this) + +Stage 3 is to allow a symbol to be appended to a sequence of keywords written by using `/`as a separator, so + +> :foo:bar/ban + +would be read as `(:foo :bar 'ban)` + +Finally, we need privileged notation for root (oblist) and for session. There are very few non-alpha-numeric characters which are available on a standard keyboard and which are not already used as significant lexical characters in Lisp readers. PSSE is not limited, of course, to the characters which are part of the ASCII character set, but it is helpful to use symbols which are reasonably convenient to type, possibly with special keyboard bindings. + +So I'm going to propose that the reader should interpret + +> /:users:simon:functions/assoc + +as + +> (-> oblist :users :simon :functions 'assoc) + +where `oblist` is the actual privileged global object list, not just the current binding of `oblist` in the environment. Thus, this expression would return my personal version of the function `assoc`, whatever the symbol `assoc` was bound to in the runtime environment. + +The use of the leading slash here follows UNIX convention. + +I'm going to suggest that the session is referenced by the character §, otherwise known as the 'silcrow'. This is not available on most keyboard mappings, so a custom mapping might be needed, or we might have to fall back on `$`. + +Thus the reader should interpret + +> §:user + +as + +> (-> session :user) + +where `session`is again a system privileged value, not the binding of `session` in the current environment. \ No newline at end of file diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index 2e68cda..efc0e88 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -110,10 +110,10 @@ struct cons_pointer lisp_get_hash( struct stack_frame *frame, struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn, struct cons_pointer write_acl ) { - struct cons_pointer result = - make_vso( HASHTV, - ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + - ( sizeof( uint32_t ) * 2 ) ); + struct cons_pointer result = make_vso( HASHTV, + ( sizeof( struct cons_pointer ) * + ( n_buckets + 1 ) ) + + ( sizeof( uint32_t ) * 2 ) ); struct hashmap_payload *payload = ( struct hashmap_payload * ) &pointer_to_vso( result )->payload; @@ -175,9 +175,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer val = c_cdr( pair ); uint32_t bucket_no = - get_hash( key ) % - ( ( struct hashmap_payload * ) &( map->payload ) )-> - n_buckets; + get_hash( key ) % ( ( struct hashmap_payload * ) + &( map->payload ) )->n_buckets; map->payload.hashmap.buckets[bucket_no] = inc_ref( make_cons( make_cons( key, val ), diff --git a/src/ops/equal.c b/src/ops/equal.c index 36f73ed..39d80af 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -82,13 +82,15 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * structures can be of indefinite extent. It *must* be done by * iteration (and even that is problematic) */ result = - cell_a->payload.string.hash == cell_b->payload.string.hash && - cell_a->payload.string.character == - cell_b->payload.string.character && - ( equal( cell_a->payload.string.cdr, - cell_b->payload.string.cdr ) || - ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload.string.cdr ) ) ); + cell_a->payload.string.hash == cell_b->payload.string.hash + && cell_a->payload.string.character == + cell_b->payload.string.character + && + ( equal + ( cell_a->payload.string.cdr, + cell_b->payload.string.cdr ) + || ( end_of_string( cell_a->payload.string.cdr ) + && end_of_string( cell_b->payload.string.cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/ops/intern.c b/src/ops/intern.c index e541bdf..d7a6c0d 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -90,67 +90,68 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { */ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - debug_print( L"c_assoc; key is `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"`\n", DEBUG_BIND ); + debug_print( L"c_assoc; key is `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); - if ( consp( store ) ) { - for ( struct cons_pointer next = store; - nilp( result ) && ( consp( next ) || hashmapp( next ) ); - next = pointer2cell( next ).payload.cons.cdr ) { - if ( consp( next ) ) { - struct cons_pointer entry_ptr = c_car( next ); - struct cons_space_object entry = pointer2cell( entry_ptr ); + if ( consp( store ) ) { + for ( struct cons_pointer next = store; + nilp( result ) && ( consp( next ) || hashmapp( next ) ); + next = pointer2cell( next ).payload.cons.cdr ) { + if ( consp( next ) ) { + struct cons_pointer entry_ptr = c_car( next ); + struct cons_space_object entry = pointer2cell( entry_ptr ); - switch ( entry.tag.value ) { - case CONSTV: - if ( equal( key, entry.payload.cons.car ) ) { - result = entry.payload.cons.cdr; + switch ( entry.tag.value ) { + case CONSTV: + if ( equal( key, entry.payload.cons.car ) ) { + result = entry.payload.cons.cdr; + } + break; + case VECTORPOINTTV: + result = hashmap_get( entry_ptr, key ); + break; + default: + throw_exception( c_string_to_lisp_string + ( L"Store entry is of unknown type" ), + NIL ); + } } - break; - case VECTORPOINTTV: - result = hashmap_get( entry_ptr, key ); - break; - default: - throw_exception( - c_string_to_lisp_string( L"Store entry is of unknown type" ), - NIL ); } - } + } else if ( hashmapp( store ) ) { + result = hashmap_get( store, key ); + } else if ( !nilp( store ) ) { + result = + throw_exception( c_string_to_lisp_string + ( L"Store is of unknown type" ), NIL ); } - } else if ( hashmapp( store ) ) { - result = hashmap_get( store, key ); - } else if (!nilp(store)) { - result = throw_exception( - c_string_to_lisp_string( L"Store is of unknown type" ), NIL ); - } - debug_print( L"c_assoc returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"c_assoc returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND ); - return result; + return result; } /** * Return a new key/value store containing all the key/value pairs in this * store with this key/value pair added to the front. */ - struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { - struct cons_pointer result = NIL; +struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { + struct cons_pointer result = NIL; - debug_print( L"set: binding `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"` to `", DEBUG_BIND ); - debug_print_object( value, DEBUG_BIND ); - debug_print( L"` in store ", DEBUG_BIND ); - debug_dump_object( store, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"set: binding `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` to `", DEBUG_BIND ); + debug_print_object( value, DEBUG_BIND ); + debug_print( L"` in store ", DEBUG_BIND ); + debug_dump_object( store, DEBUG_BIND ); + debug_println( DEBUG_BIND ); - if ( nilp( store ) || consp( store ) ) { + if ( nilp( store ) || consp( store ) ) { result = make_cons( make_cons( key, value ), store ); } else if ( hashmapp( store ) ) { result = hashmap_put( store, key, value ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 454fb9a..b173090 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -380,9 +380,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = c_assoc( eval_form( frame, frame_pointer, c_car( c_cdr - ( frame-> - arg[0] ) ), - env ), fn_pointer ); + ( frame->arg + [0] ) ), env ), + fn_pointer ); break; } break; From c63c262b740024dccfec261185fa520876d5354f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 18 Aug 2021 18:48:05 +0100 Subject: [PATCH 089/101] Compact path notation now expands correctly --- src/init.c | 5 ++ src/io/read.c | 97 ++++++++++++++++++++++++++++++++++++- src/memory/hashmap.c | 2 +- src/ops/intern.c | 9 ++-- src/repl.c | 8 ++- unit-tests/map.sh | 1 + unit-tests/path-notation.sh | 31 ++++++++++++ 7 files changed, 145 insertions(+), 8 deletions(-) create mode 100755 unit-tests/path-notation.sh diff --git a/src/init.c b/src/init.c index ca48b9d..dbd7acf 100644 --- a/src/init.c +++ b/src/init.c @@ -163,6 +163,9 @@ int main( int argc, char *argv[] ) { debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP ); +// TODO: oblist-as-hashmap (which is what we ultimately need) is failing hooribly +// oblist = inc_ref( make_hashmap( 32, NIL, TRUE ) ); + /* * privileged variables (keywords) */ @@ -271,7 +274,9 @@ int main( int argc, char *argv[] ) { bind_special( L"set!", &lisp_set_shriek ); debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); + repl( show_prompt ); + debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); dec_ref( oblist ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); diff --git a/src/io/read.c b/src/io/read.c index 9c87932..4425b77 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -60,6 +60,77 @@ struct cons_pointer c_quote( struct cons_pointer arg ) { make_cons( arg, NIL ) ); } +/** + * Read a path macro from the stream. A path macro is expected to be + * 1. optionally a leading character such as '/' or '$', followed by + * 2. one or more keywords with leading colons (':') but no intervening spaces; or + * 3. one or more symbols separated by slashes; or + * 4. keywords (with leading colons) interspersed with symbols (prefixed by slashes). + */ +struct cons_pointer read_path( URL_FILE * input, wint_t initial, + struct cons_pointer q ) { + bool done = false; + struct cons_pointer prefix = NIL; + + switch ( initial ) { + case '/': + prefix = c_string_to_lisp_symbol( L"oblist" ); + break; + case '$': + case L'§': + prefix = c_string_to_lisp_symbol( L"session" ); + break; + } + + while ( !done ) { + wint_t c = url_fgetwc( input ); + if ( iswblank( c ) || iswcntrl( c ) ) { + done = true; + } else if ( url_feof( input ) ) { + done = true; + } else { + switch ( c ) { + case ':': + q = make_cons( read_symbol_or_key + ( input, KEYTV, url_fgetwc( input ) ), q ); + break; + case '/': + q = make_cons( make_cons + ( c_string_to_lisp_symbol( L"quote" ), + make_cons( read_symbol_or_key + ( input, SYMBOLTV, + url_fgetwc( input ) ), + NIL ) ), q ); + break; + default: + if ( iswalpha( c ) ) { + q = make_cons( read_symbol_or_key + ( input, SYMBOLTV, c ), q ); + } else { + // TODO: it's really an error. Exception? + url_ungetwc( c, input ); + done = true; + } + } + } + } + + // right, we now have the path we want (reversed) in q. + struct cons_pointer r = NIL; + + for ( struct cons_pointer p = q; !nilp( p ); p = c_cdr( p ) ) { + r = make_cons( c_car( p ), r ); + } + + dec_ref( q ); + + if ( !nilp( prefix ) ) { + r = make_cons( prefix, r ); + } + + return make_cons( c_string_to_lisp_symbol( L"->" ), r ); +} + /** * Read the next object on this input stream and return a cons_pointer to it, * treating this initial character as the first character of the object @@ -149,6 +220,27 @@ struct cons_pointer read_continuation( struct stack_frame *frame, result = read_symbol_or_key( input, KEYTV, url_fgetwc( input ) ); break; + case '/': + { + /* slash followed by whitespace is legit provided it's not + * preceded by anything - it's the division operator. Otherwise, + * it's terminal, probably part of a path, and needs pushed back. + */ + wint_t cn = url_fgetwc( input ); + if ( nilp( result ) + && ( iswblank( cn ) || iswcntrl( cn ) ) ) { + url_ungetwc( cn, input ); + result = make_symbol_or_key( c, NIL, SYMBOLTV ); + } else { + url_ungetwc( cn, input ); + result = read_path( input, c, NIL ); + } + } + break; + case '$': + case L'§': + result = read_path( input, c, NIL ); + break; default: if ( iswdigit( c ) ) { result = @@ -398,9 +490,10 @@ struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, /* unwise to allow embedded quotation marks in symbols */ case ')': case ':': + case '/': /* - * symbols and keywords may not include right-parenthesis - * or colons. + * symbols and keywords may not include right-parenthesis, + * slashes or colons. */ result = NIL; /* diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index efc0e88..cee9267 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -112,7 +112,7 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer write_acl ) { struct cons_pointer result = make_vso( HASHTV, ( sizeof( struct cons_pointer ) * - ( n_buckets + 1 ) ) + + ( n_buckets + 2 ) ) + ( sizeof( uint32_t ) * 2 ) ); struct hashmap_payload *payload = diff --git a/src/ops/intern.c b/src/ops/intern.c index d7a6c0d..05d5822 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -25,7 +25,7 @@ #include "equal.h" #include "hashmap.h" #include "lispops.h" -#include "print.h" +// #include "print.h" /** * The global object list/or, to put it differently, the root namespace. @@ -181,8 +181,11 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { debug_println( DEBUG_BIND ); oblist = set( key, value, oblist ); - inc_ref( oblist ); - dec_ref( old ); + + if ( consp( oblist ) ) { + inc_ref( oblist ); + dec_ref( old ); + } debug_print( L"deep_bind returning ", DEBUG_BIND ); debug_print_object( oblist, DEBUG_BIND ); diff --git a/src/repl.c b/src/repl.c index 0ea104d..39bbde6 100644 --- a/src/repl.c +++ b/src/repl.c @@ -24,12 +24,16 @@ void repl( ) { debug_print( L"Entered repl\n", DEBUG_REPL ); - struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, oblist ); + struct cons_pointer env = + consp( oblist ) ? oblist : make_cons( oblist, NIL ); + + /* bottom of stack */ + struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, env ); if ( !nilp( frame_pointer ) ) { inc_ref( frame_pointer ); - lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, oblist ); + lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env ); dec_ref( frame_pointer ); } diff --git a/unit-tests/map.sh b/unit-tests/map.sh index c5fb834..65dc182 100755 --- a/unit-tests/map.sh +++ b/unit-tests/map.sh @@ -5,6 +5,7 @@ expected='{}' actual=`echo "$expected" | target/psse | tail -1` +echo -n "Empty map using compact map notation: " if [ "${expected}" = "${actual}" ] then echo "OK" diff --git a/unit-tests/path-notation.sh b/unit-tests/path-notation.sh new file mode 100755 index 0000000..a6cb669 --- /dev/null +++ b/unit-tests/path-notation.sh @@ -0,0 +1,31 @@ +#!/bin/bash + +##################################################################### +# Create a path from root using compact path notation +expected='(-> oblist :users :simon :functions (quote assoc))' +actual=`echo "'/:users:simon:functions/assoc" | target/psse | tail -1` + +echo -n "Path from root (oblist) using compact notation: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Create a path from the current session using compact path notation +expected='(-> session :input-stream)' +actual=`echo "'$:input-stream" | target/psse | tail -1` + +echo -n "Path from current session using compact notation: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + From 6771d6494c5b95d1adc7029aa8920e763d0a71b6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 23 Aug 2021 12:35:05 +0100 Subject: [PATCH 090/101] Append works; mapcar doesn't; loop isn't even written. --- src/init.c | 2 + src/io/io.c | 4 +- src/memory/consspaceobject.h | 13 ++-- src/memory/dump.c | 8 +-- src/memory/hashmap.c | 4 +- src/ops/lispops.c | 121 +++++++++++++++++++++++++++++------ src/ops/lispops.h | 9 +++ src/ops/loop.c | 50 +++++++++++++++ src/ops/loop.h | 10 +++ unit-tests/append.sh | 24 +++++++ 10 files changed, 213 insertions(+), 32 deletions(-) create mode 100644 src/ops/loop.c create mode 100644 src/ops/loop.h create mode 100755 unit-tests/append.sh diff --git a/src/init.c b/src/init.c index dbd7acf..5e8a55d 100644 --- a/src/init.c +++ b/src/init.c @@ -220,6 +220,7 @@ int main( int argc, char *argv[] ) { */ bind_function( L"absolute", &lisp_absolute ); bind_function( L"add", &lisp_add ); + bind_function( L"append", &lisp_append ); bind_function( L"apply", &lisp_apply ); bind_function( L"assoc", &lisp_assoc ); bind_function( L"car", &lisp_car ); @@ -235,6 +236,7 @@ int main( int argc, char *argv[] ) { bind_function( L"hashmap", lisp_make_hashmap ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"keys", &lisp_keys ); + bind_function( L"mapcar", &lisp_mapcar ); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); bind_function( L"multiply", &lisp_multiply ); diff --git a/src/io/io.c b/src/io/io.c index f621539..72830a4 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -503,8 +503,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload.stream. - stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload. + stream.stream ), NIL ); } return result; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 2817e69..7c3a390 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -114,12 +114,12 @@ * A loop exit is a special kind of exception which has exactly the same * payload as an exception. */ -#define LOOPXTAG "LOOX" +#define LOOPTAG "LOOP" /** * The string `LOOX`, considered as an `unsigned int`. */ -#define LOOPXTV 1481592652 +#define LOOPTV 1347374924 /** * The special cons cell at address {0,0} whose car and cdr both point to @@ -304,9 +304,9 @@ #define lambdap(conspoint) (check_tag(conspoint,LAMBDATV)) /** - * true if `conspoint` points to a loop exit exception, else false. + * true if `conspoint` points to a loop recursion, else false. */ -#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTV)) +#define loopp(conspoint) (check_tag(conspoint,LOOPTV)) /** * true if `conspoint` points to a special form cell, else false @@ -615,7 +615,7 @@ struct cons_space_object { */ struct cons_payload cons; /** - * if tag == EXCEPTIONTAG || tag == LOOPXTAG + * if tag == EXCEPTIONTAG || tag == LOOPTAG */ struct exception_payload exception; /** @@ -713,6 +713,9 @@ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer, struct cons_pointer ) ); +struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail, + uint32_t tag ); + struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, diff --git a/src/memory/dump.c b/src/memory/dump.c index 086f8c8..81182a8 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -114,10 +114,10 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { case RATIOTV: url_fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload. - integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload. - integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ). + payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ). + payload.integer.value, cell.count ); break; case READTV: url_fputws( L"\t\tInput stream; metadata: ", output ); diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index cee9267..d6909ba 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -180,8 +180,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, map->payload.hashmap.buckets[bucket_no] = inc_ref( make_cons( make_cons( key, val ), - map->payload.hashmap. - buckets[bucket_no] ) ); + map->payload. + hashmap.buckets[bucket_no] ) ); } } } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index b173090..2356abe 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -413,10 +413,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload. - special.executable ) ( get_stack_frame - ( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -904,26 +903,30 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * reverse a sequence. + * reverse a sequence (if it is a sequence); else return it unchanged. */ struct cons_pointer c_reverse( struct cons_pointer arg ) { struct cons_pointer result = NIL; - for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { - struct cons_space_object o = pointer2cell( p ); - switch ( o.tag.value ) { - case CONSTV: - result = make_cons( o.payload.cons.car, result ); - break; - case STRINGTV: - result = make_string( o.payload.string.character, result ); - break; - case SYMBOLTV: - result = - make_symbol_or_key( o.payload.string.character, result, - SYMBOLTV ); - break; + if ( sequencep( arg ) ) { + for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { + struct cons_space_object o = pointer2cell( p ); + switch ( o.tag.value ) { + case CONSTV: + result = make_cons( o.payload.cons.car, result ); + break; + case STRINGTV: + result = make_string( o.payload.string.character, result ); + break; + case SYMBOLTV: + result = + make_symbol_or_key( o.payload.string.character, result, + SYMBOLTV ); + break; + } } + } else { + result = arg; } return result; @@ -1350,6 +1353,86 @@ struct cons_pointer lisp_source( struct stack_frame *frame, return result; } +/** + * A version of append which can conveniently be called from C. + */ +struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { + switch ( pointer2cell( l1 ).tag.value ) { + case CONSTV: + if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { + if ( nilp( c_cdr( l1 ) ) ) { + return make_cons( c_car( l1 ), l2 ); + } else { + return make_cons( c_car( l1 ), + c_append( c_cdr( l1 ), l2 ) ); + } + } else { + throw_exception( c_string_to_lisp_string + ( L"Can't append: not same type" ), NIL ); + } + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { + if ( nilp( c_cdr( l1 ) ) ) { + return + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), l2, + pointer2cell( l1 ).tag.value ); + } else { + return + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), + c_append( c_cdr( l1 ), l2 ), + pointer2cell( l1 ).tag.value ); + } + } else { + throw_exception( c_string_to_lisp_string + ( L"Can't append: not same type" ), NIL ); + } + break; + default: + throw_exception( c_string_to_lisp_string + ( L"Can't append: not a sequence" ), NIL ); + break; + } +} + +/** + * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp + */ +struct cons_pointer lisp_append( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_append( frame->arg[0], frame->arg[1] ); +} + + +struct cons_pointer lisp_mapcar( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { + struct cons_pointer expr = make_cons(frame->arg[0], make_cons(c_car(c), NIL)); + inc_ref(expr); + + struct cons_pointer r = eval_form(frame, frame_pointer, expr, env); + + if ( exceptionp( r ) ) { + result = r; + inc_ref( expr ); // to protect exception from the later dec_ref + break; + } else { + result = make_cons( c, result ); + } + + dec_ref( expr ); + } + + return c_reverse( result ); +} // /** // * Function; print the internal representation of the object indicated by `frame->arg[0]` to the diff --git a/src/ops/lispops.h b/src/ops/lispops.h index c1cc337..582cd98 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -202,4 +202,13 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ); + +struct cons_pointer lisp_append( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_mapcar( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif diff --git a/src/ops/loop.c b/src/ops/loop.c new file mode 100644 index 0000000..6ccada6 --- /dev/null +++ b/src/ops/loop.c @@ -0,0 +1,50 @@ +/* + * loop.c + * + * Iteration functions. This has *a lot* of similarity to try/catch -- + * essentially what `recur` does is throw a special purpose exception which is + * caught by `loop`. + * + * Essentially the syntax I want is + * + * (defun expt (n e) + * (loop ((n1 . n) (r . n) (e1 . e)) + * (cond ((= e 0) r) + * (t (recur n1 (* n1 r) (- e 1))))) + * + * It might in future be good to allow the body of the loop to comprise many + * expressions, like a `progn`, but for now if you want that you can just + * shove a `progn` in. Note that, given that what `recur` is essentially + * doing is throwing a special purpose exception, the `recur` expression + * doesn't actually have to be in the same function as the `loop` expression. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "consspaceobject.h" +#include "lispops.h" +#include "loop.h" + +/** + * Special form, not dissimilar to `let`. Essentially, + * + * 1. the first arg (`args`) is an assoc list; + * 2. the second arg (`body`) is an expression. + * + * Each of the vals in the assoc list is evaluated, and bound to its + * respective key in a new environment. The body is then evaled in that + * environment. If the result is an object of type LOOP, it should carry + * a list of values of the same arity as args. Each of the keys in args + * is then rebound in a new environment to the respective value from the + * LOOP object, and body is then re-evaled in that environment. + * + * If the result is not a LOOP object, it is simply returned. + */ +struct cons_pointer +lisp_loop( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer keys = c_keys( frame->arg[0] ); + struct cons_pointer body = frame->arg[1]; + +} diff --git a/src/ops/loop.h b/src/ops/loop.h new file mode 100644 index 0000000..27714a8 --- /dev/null +++ b/src/ops/loop.h @@ -0,0 +1,10 @@ +/* + * loop.h + * + * Iteration functions. This has *a lot* of similarity to try/catch -- + * essentially what `recur` does is throw a special purpose exception which is + * caught by `loop`. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ diff --git a/unit-tests/append.sh b/unit-tests/append.sh new file mode 100755 index 0000000..0f6fb30 --- /dev/null +++ b/unit-tests/append.sh @@ -0,0 +1,24 @@ +#!/bin/bash + +expected='(a b c d e f)' +actual=`echo "(append '(a b c) '(d e f))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='"hellodere"' +actual=`echo '(append "hello" "dere")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + From 4047b88cae2d5fe2a482d6a3722355fc966a3342 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 23 Aug 2021 13:29:11 +0100 Subject: [PATCH 091/101] Documentation, only --- README.md | 135 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 133 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 9c08aab..afcc524 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,5 @@ # Post Scarcity Software System, version 0 -Very Nearly a Big Lisp Environment - tl,dr: look at the [wiki](wiki). ## State of play @@ -22,6 +20,139 @@ What I'm trying to do now is write a detailed low level specification of the und Although I describe it as a 'Lisp environment', for reasons explained in Post Scarcity Software that doesn't mean you will program it in Lisp. It means that the underlying representation of things in the system is Lispy, not Unixy. +## Bindings currently available + +The following symbols are bound in the bootstrap layer. It is anticipated that + +1. Most of the functions will be overridden by versions of the same function written in Lisp; but +2. these implementations will remain available in the package `/:bootstrap`. + +### Values + +Note that symbols delimited by asterisks, as in `*in*`, invite rebinding; it is expected, for example, that users will want to rebind input and output streams in their current environment. Rebinding some other symbols, for example `nil`, is unwise. + +#### nil + +The canonical empty list. + +#### t + +The canonical true value. + +#### \*in\* + +The input stream. + +#### \*out\* + +The output stream. + +#### \*log\* + +The logging stream (equivalent to `stderr`). + +#### \*sink\* + +The sink stream (equivalent to `/dev/null`). + +#### \*prompt\* + +The REPL prompt. + +#### (absolute *n*) + +Return the absolute value of a number. + +#### (add *n1* *n2* ...), (+ *n1* *n2* ...) + +Return the result of adding together all the (assumed numeric) arguments supplied. + +#### (append *s1* *s2*) + +Return a new sequence comprising all the elements of *s1* followed by all the elements of *s2*. *s1* and *s2* must be sequences of the same type. At a later stage this function will accept arbitrary numbers of arguments, but by that time it will be written in Lisp. + +#### (apply *f* *s*) + +Apply the function *f* to the arguments that form the sequence *s*, and return the result. + +#### (assoc *key* *store*) + +Return the value associated with *key* in *store*. *key* may be an object of any type, but keywords, symbols and strings are handled most efficiently. *store* may be an [*association list*](#Association_list), or may be a hashmap. + +#### (car *s*) + +Return the first element of the sequence *s*. + +#### (cdr *s*) + +Return a sequence of all the elements of the sequence *s* except the first. + +#### (close *stream*) + +Closes the indicates stream. Returns `nil`. + +#### (cons *a* *b*) + +Returns a new pair comprising *a* and *b*. If *b* is a list, this has the effect of creating a new list with the element *a* prepended to all the elements of *b*. If *b* is `nil`, this has the effect creating a new list with *a* as the sole element. Otherwise, it just creates a pair. + +#### (divide *n1* *n2*), (/ *n1* *n2*) + +Divides the number *n1* by the number *n2*. If *n1* and *n2* are both integers, it's likely that the result will be a rational number. + +#### (eq *o1* *o2*) + +Returns true (`t`) if *o1* and *o2* are identically the same object, else `nil`. + +#### (equal *o1* *o2*) + +Returns true (`t`) if *o1* and *o2* are structurally identical to one another, else `nil`. + +#### (exception *message*) + +Throws (returns) an exception, with the specified *message*. Note that it is extremely likely this signature will change. + +#### (get-hash *key* *hashmap*) + +Like 'assoc', but the store must be a hashmap. Deprecated. + +#### (hashmap *n* *f* *store*) + +Create a hashmap with *n* buckets, using *f* as its hashing function, and initialised with the key/value pairs from *store*. All arguments are optional; if none are passed, will create an empty hashmap with 32 keys and the default hashing function. + +#### (inspect *o*) + +Prints detailed structure of the object *o*. Primarily for debugging. + +#### (keys *store*) + +Returns a list of the keys in *store*, which may be either an [*association list*](#Association_list), or a hashmap. + +#### (mapcar *f* *s*) + +Applies the function *f* to each element of the sequence *s*, and returns a new sequence of the results. + +#### (meta *o*), (metadata *o*) + +Returns metadata on *o*. + +#### (multiply *n1* *n2* ...), (\* *n1* *n2* ...) + +Returns the product of multiplying together all of its numeric arguments. + +#### (negative? n1) + +Returns `t` if its argument is a negative number, else `nil`. + +#### (oblist) + +Returns a sequence of all the names bound in the root of the naming system. + +#### (open *url* *read?*) + +Opens a stream to the specified *url*. If a second argument is present and is non-`nil`, the stream is opened for reading; otherwise, it's opened for writing. + + + ## License Copyright © 2017 [Simon Brooke](mailto:simon@journeyman.cc) From 06e87f09faedc8c370cd473f73b2f1dc2a2d47c4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 8 Sep 2021 13:12:40 +0100 Subject: [PATCH 092/101] Mapcar working; really only `let` left to do for version 0.1 --- src/ops/lispops.c | 31 +++++++++++++++++++++++++------ 1 file changed, 25 insertions(+), 6 deletions(-) diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 2356abe..0f058ed 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -42,8 +42,6 @@ * also to create in this section: * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, * struct stack_frame* frame); - * struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env, - * struct stack_frame* frame); * * and others I haven't thought of yet. */ @@ -62,7 +60,8 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer form, struct cons_pointer env ) { debug_print( L"eval_form: ", DEBUG_EVAL ); - debug_dump_object( form, DEBUG_EVAL ); + debug_print_object( form, DEBUG_EVAL ); + debug_println(DEBUG_EVAL); struct cons_pointer result = NIL; struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); @@ -81,6 +80,10 @@ struct cons_pointer eval_form( struct stack_frame *parent, dec_ref( next_pointer ); } + debug_print( L"eval_form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println(DEBUG_EVAL); + return result; } @@ -1413,25 +1416,41 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + debug_print( L"Mapcar: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + int i = 0; for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { struct cons_pointer expr = make_cons(frame->arg[0], make_cons(c_car(c), NIL)); inc_ref(expr); - struct cons_pointer r = eval_form(frame, frame_pointer, expr, env); + debug_printf(DEBUG_EVAL, L"Mapcar %d, evaluating ", i); + debug_print_object( expr, DEBUG_EVAL); + debug_println(DEBUG_EVAL); + + struct cons_pointer r = eval_form(frame, frame_pointer, expr, env); if ( exceptionp( r ) ) { result = r; inc_ref( expr ); // to protect exception from the later dec_ref break; } else { - result = make_cons( c, result ); + result = make_cons( r, result ); } + debug_printf(DEBUG_EVAL, L"Mapcar %d, result is ", i++); + debug_print_object( result, DEBUG_EVAL); + debug_println(DEBUG_EVAL); dec_ref( expr ); } - return c_reverse( result ); + result = consp(result) ? c_reverse( result ) : result; + + debug_print( L"Mapcar returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println(DEBUG_EVAL); + + return result; } // /** From 3abebe937cd55436e8d1bb8c9d1db741317a39b6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 8 Sep 2021 13:47:36 +0100 Subject: [PATCH 093/101] Added `list` and unit test for it. --- src/init.c | 1 + src/ops/lispops.c | 13 +++++++++++ src/ops/lispops.h | 4 ++++ unit-tests/integer-allocation.sh | 4 ++-- unit-tests/list-test,sh | 38 ++++++++++++++++++++++++++++++++ 5 files changed, 58 insertions(+), 2 deletions(-) create mode 100644 unit-tests/list-test,sh diff --git a/src/init.c b/src/init.c index 5e8a55d..4fc922a 100644 --- a/src/init.c +++ b/src/init.c @@ -236,6 +236,7 @@ int main( int argc, char *argv[] ) { bind_function( L"hashmap", lisp_make_hashmap ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"keys", &lisp_keys ); + bind_function( L"list", &lisp_list); bind_function( L"mapcar", &lisp_mapcar ); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 0f058ed..d35c5a6 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1453,6 +1453,19 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, return result; } +struct cons_pointer lisp_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = frame->more; + + for ( int a = nilp(result) ? frame->args - 1: args_in_frame - 1; + a >= 0; a-- ) { + result = make_cons(fetch_arg(frame, a), result); + } + + return result; +} + // /** // * Function; print the internal representation of the object indicated by `frame->arg[0]` to the // * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 582cd98..2724f89 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -211,4 +211,8 @@ struct cons_pointer lisp_append( struct stack_frame *frame, struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + + struct cons_pointer lisp_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh index ced92f2..b25bef3 100755 --- a/unit-tests/integer-allocation.sh +++ b/unit-tests/integer-allocation.sh @@ -1,8 +1,8 @@ #!/bin/bash value=354 -expected="Integer cell: value ${value}," -echo ${value} | target/psse -v5 2>&1 | grep "${expected}" > /dev/null +expected="(${value} \"INTR\")" +echo "(set! x $value)(list x (type x))" | target/psse 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then diff --git a/unit-tests/list-test,sh b/unit-tests/list-test,sh new file mode 100644 index 0000000..32f4797 --- /dev/null +++ b/unit-tests/list-test,sh @@ -0,0 +1,38 @@ +#!/bin/bash + +expected="(0 1 2 3 4 5 6 7 8 9 a b c d e f)" + +actual=`echo "(list 0 1 2 3 4 5 6 7 8 9 'a 'b 'c 'd 'e 'f)" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi + +expected="(0 1 2 3 4)" + +actual=`echo "(list 0 1 2 3 4)" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi + +expected="(0 1 2 3 4 5 6 7)" + +actual=`echo "(list 0 1 2 3 4 5 6 7)" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi From 78d2395d60b291737a70fc83ee165b63f1462bff Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 8 Sep 2021 15:01:48 +0100 Subject: [PATCH 094/101] Let working, unit tested. --- src/init.c | 1 + src/ops/lispops.c | 54 ++++++++++++++++++++++++++++++++++++++++++----- src/ops/lispops.h | 4 ++++ unit-tests/let.sh | 24 +++++++++++++++++++++ 4 files changed, 78 insertions(+), 5 deletions(-) create mode 100755 unit-tests/let.sh diff --git a/src/init.c b/src/init.c index 4fc922a..031d0ba 100644 --- a/src/init.c +++ b/src/init.c @@ -270,6 +270,7 @@ int main( int argc, char *argv[] ) { bind_special( L"cond", &lisp_cond ); bind_special( L"lambda", &lisp_lambda ); bind_special( L"\u03bb", &lisp_lambda ); // λ + bind_special(L"let", &lisp_let); bind_special( L"nlambda", &lisp_nlambda ); bind_special( L"n\u03bb", &lisp_nlambda ); bind_special( L"progn", &lisp_progn ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d35c5a6..fa3c68d 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -593,7 +593,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, result = frame->arg[1]; } else { result = - make_exception( make_cons + throw_exception( make_cons ( c_string_to_lisp_string ( L"The first argument to `set` is not a symbol: " ), make_cons( frame->arg[0], NIL ) ), @@ -632,7 +632,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, result = val; } else { result = - make_exception( make_cons + throw_exception( make_cons ( c_string_to_lisp_string ( L"The first argument to `set!` is not a symbol: " ), make_cons( frame->arg[0], NIL ) ), @@ -1212,7 +1212,7 @@ struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer message = frame->arg[0]; - return exceptionp( message ) ? message : make_exception( message, + return exceptionp( message ) ? message : throw_exception( message, frame->previous ); } @@ -1408,9 +1408,14 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { struct cons_pointer lisp_append( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return c_append( frame->arg[0], frame->arg[1] ); -} + struct cons_pointer result = fetch_arg(frame, (frame->args - 1)); + for (int a = frame->args - 2; a >= 0; a--) { + result = c_append(fetch_arg(frame, a), result); + } + + return result; +} struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -1466,6 +1471,45 @@ struct cons_pointer lisp_list( struct stack_frame *frame, return result; } +/** + * Special form: evaluate a series of forms in an environment in which + * these bindings are bound. + * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. + */ +struct cons_pointer lisp_let( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env) { + struct cons_pointer bindings = env; + struct cons_pointer result = NIL; + + for (struct cons_pointer cursor = frame->arg[0]; + truep(cursor); + cursor = c_cdr(cursor)) { + struct cons_pointer pair = c_car(cursor); + struct cons_pointer symbol = c_car(pair); + + if (symbolp(symbol)) { + bindings = make_cons( + make_cons(symbol, eval_form(frame, frame_pointer, c_cdr(pair), bindings)), + bindings); + + } else { + result = throw_exception( + c_string_to_lisp_string(L"Let: cannot bind, not a symbol"), + frame_pointer); + break; + } + } + + /* i.e., no exception yet */ + for (int form = 1; !exceptionp(result) && form < frame->args; form++) { + result = eval_form(frame, frame_pointer, fetch_arg(frame, form), bindings); + } + + return result; + + } + // /** // * Function; print the internal representation of the object indicated by `frame->arg[0]` to the // * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 2724f89..3d1c4f7 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -215,4 +215,8 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer lisp_list( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_let( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env); #endif diff --git a/unit-tests/let.sh b/unit-tests/let.sh new file mode 100755 index 0000000..6454b1e --- /dev/null +++ b/unit-tests/let.sh @@ -0,0 +1,24 @@ +#!/bin/bash + +expected='11' +actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi + +expected='1' +actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi From be5cc4e528d024c00386960cde2139648bb9dd4a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 8 Sep 2021 18:32:31 +0100 Subject: [PATCH 095/101] Documentation in README.md --- README.md | 136 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 132 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index afcc524..408818c 100644 --- a/README.md +++ b/README.md @@ -4,6 +4,28 @@ tl,dr: look at the [wiki](wiki). ## State of play +### Version 0.0.5 + +Has working Lisp interpreter, more or less complete, with functions and symbols as defined under [[#Bindings currently available]] below. Features include hash maps. + +#### Known bugs + +At the time of writing, big number arithmetic is completely failing. It has worked in the past, but it doesn't now. + +#### Unknown bugs + +It's pretty likely that there are memory leaks. + +#### Not yet implemented + +1. There is as yet no **compiler**, and indeed it isn't yet certain what a compiler would even mean. Do all nodes in a machine necessarily share the same processor architecture? +2. There's the beginnings of a narrative about how **namespaces** are going to work, but as yet they aren't really implemented. +3. There is as yet no implementation of the concept of **users**. Access Control Lists exist but are not used. Related, there's no concept of a **session**. +4. There is as yet no **multiprocessor architecture**, not even a simulated one. As it is intended that threading will be implemented by handing off parts of a computation to peer processors, this means there no **threads** either. +5. There's no **user interface** beyond a REPL. There isn't even an **editor**, or **history**. +6. **Printing to strings** does not work. +7. The **exception system**, while it does exist, needs to be radically rethought. + ### Version 0.0.4 Has working rational number arithmetic, as well as integer and real number arithmetic. The stack is now in vector space, but vector space is not yet properly garbage collected. `defun` does not yet work, so although Lisp functions can be defined the syntax is pretty clunky. So you *can* start to do things with this, but you should probably wait for at least a 0.1.0 release! @@ -25,7 +47,7 @@ Although I describe it as a 'Lisp environment', for reasons explained in Post Sc The following symbols are bound in the bootstrap layer. It is anticipated that 1. Most of the functions will be overridden by versions of the same function written in Lisp; but -2. these implementations will remain available in the package `/:bootstrap`. +2. these implementations will remain available in the namespace `/:bootstrap`. ### Values @@ -59,6 +81,8 @@ The sink stream (equivalent to `/dev/null`). The REPL prompt. +### Functions + #### (absolute *n*) Return the absolute value of a number. @@ -67,9 +91,9 @@ Return the absolute value of a number. Return the result of adding together all the (assumed numeric) arguments supplied. -#### (append *s1* *s2*) +#### (append *s1* *s2* ...) -Return a new sequence comprising all the elements of *s1* followed by all the elements of *s2*. *s1* and *s2* must be sequences of the same type. At a later stage this function will accept arbitrary numbers of arguments, but by that time it will be written in Lisp. +Return a new sequence comprising all the elements of *s1* followed by all the elements of *s2* and so on for an indefinite number of arguments. All arguments must be sequences of the same type. #### (apply *f* *s*) @@ -109,7 +133,7 @@ Returns true (`t`) if *o1* and *o2* are structurally identical to one another, e #### (exception *message*) -Throws (returns) an exception, with the specified *message*. Note that it is extremely likely this signature will change. +Throws (returns) an exception, with the specified *message*. Note that this doesn't really work at all well, and that it is extremely likely this signature will change. #### (get-hash *key* *hashmap*) @@ -127,6 +151,14 @@ Prints detailed structure of the object *o*. Primarily for debugging. Returns a list of the keys in *store*, which may be either an [*association list*](#Association_list), or a hashmap. +#### (let *bindings* *form*...) + +Evaluates each of the *forms* in an environment to which ally of these *bindings* have been added. *bindings* must be an [*association list*](#Association_list), and, additionally, all keys in *bindings* must be symbols. Values in the association list will be evaluated before being bound, and this is done sequentially, as in the behaviour of Common Lisp `let*` rather than of Common Lisp `let`. + +#### (list *o*...) + +Returns a list of the values of all of its arguments in sequence. + #### (mapcar *f* *s*) Applies the function *f* to each element of the sequence *s*, and returns a new sequence of the results. @@ -151,6 +183,102 @@ Returns a sequence of all the names bound in the root of the naming system. Opens a stream to the specified *url*. If a second argument is present and is non-`nil`, the stream is opened for reading; otherwise, it's opened for writing. +### Types + +The following types are known. Further types can be defined, and ultimately it should be possible to define further types in Lisp, but these are what you have to be going on with. Note that where this documentation differs from `memory/consspaceobject.h`, this documentation is *wrong*. + +#### CONS + +An ordinary cons cell: that is to say, a pair. + +#### EXEP + +An exception + +#### FREE + +An unallocated memory cell. User programs should never see this. + +#### FUNC + +A primitive or compiled Lisp function \-- one whose arguments are pre-evaluated. + +#### HASH + +A hash map (in vector space) + +#### INTR + +An arbitrarily large integer number. + +#### KEYW + +A keyword - an interned, self-evaluating string. + +#### LMBA + +A lambda cell. Lambdas are the interpretable (source) versions of functions. + +#### LOOP + +Internal to the workings of the ••loop** function. User functions should never see this. + +#### NIL + +The special cons cell at address {0,0} whose **car** and **cdr** both point to itself. The canonical empty set. Generally, treated as being indicative of falsity. + +#### NLMD + +An nlambda cell. NLambdas are the interpretable (source) versions of special forms. + +#### RTIO + +A rational number, stored as pointers two integers representing dividend and divisor respectively. + +#### READ + +An open read stream. + +#### REAL + +A real number, represented internally as an IEEE 754-2008 `binary64`. + +#### SPFM + +A compiled or primitive special form - one whose arguments are not pre-evaluated but passed as provided. + +#### STAK + +A stack frame. In vector space. + +#### STRG + +A string of [UTF-32](https://en.wikipedia.org/wiki/UTF-32) characters, stored as a linked list. Self evaluating. + +#### SYMB + +A symbol is just like a string except not self-evaluating. Later, there may be some restrictions on what characters are legal in a symbol, but at present there are not. + +#### TIME + +A time stamp. Not really properly implemented yet; the epoch is not defined, and, given the size of numbers we can store, could be pushed far into the past. + +#### TRUE + +The special cell at address {0,1} which is canonically different from NIL. + +#### VECP + +A pointer to an object in vector space. User functions shouldn't see this, they should see the type of the vector-space object indicated. + +#### VECT + +A vector of objects. In vector space. + +#### WRIT + +An open write stream. + ## License From 2c96e7c30d8d152b4bc5fb88770c0a8e37348975 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 13:41:27 +0100 Subject: [PATCH 096/101] Sanitising debug-printf formats, mostly. --- .gitignore | 4 ++++ Makefile | 2 +- src/arith/integer.c | 2 +- src/init.c | 1 + src/io/io.c | 1 + src/memory/conspage.c | 15 ++++++++++++++- src/memory/conspage.h | 2 ++ src/memory/consspaceobject.c | 2 +- src/memory/vectorspace.c | 2 +- 9 files changed, 26 insertions(+), 5 deletions(-) diff --git a/.gitignore b/.gitignore index a85ac01..b07b2a6 100644 --- a/.gitignore +++ b/.gitignore @@ -42,3 +42,7 @@ hi\.* .vscode/ core + +.kdev4/ + +post-scarcity.kdev4 diff --git a/Makefile b/Makefile index d8e6e81..7e5efb4 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ SRC_DIRS ?= ./src SRCS := $(shell find $(SRC_DIRS) -name *.cpp -or -name *.c -or -name *.s) HDRS := $(shell find $(SRC_DIRS) -name *.h) -OBJS := $(addsuffix .o,$(basename $(SRCS))) +OBJS := $(addsuffix .o,$(basename $(SRCS))) DEPS := $(OBJS:.o=.d) TESTS := $(shell find unit-tests -name *.sh) diff --git a/src/arith/integer.c b/src/arith/integer.c index db486d2..06ef8a3 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -76,7 +76,7 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { __int128_t result = ( __int128_t ) integerp( c ) ? ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; debug_printf( DEBUG_ARITH, - L"cell_value: raw value is %ld, is_first_cell = %s; %4.4s; returning ", + L"cell_value: raw value is %ld, is_first_cell = %s; '%4.4s'; returning ", val, is_first_cell ? "true" : "false", pointer2cell( c ).tag.bytes ); debug_print_128bit( result, DEBUG_ARITH ); diff --git a/src/init.c b/src/init.c index 031d0ba..a47f008 100644 --- a/src/init.c +++ b/src/init.c @@ -288,6 +288,7 @@ int main( int argc, char *argv[] ) { dump_pages( file_to_url_file( stdout ) ); } + summarise_allocation(); curl_global_cleanup( ); return ( 0 ); } diff --git a/src/io/io.c b/src/io/io.c index 72830a4..fe08a77 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -166,6 +166,7 @@ wint_t url_fgetwc( URL_FILE * input ) { debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); int c = ( int ) cbuff[0]; + // TODO: risk of reading off cbuff? debug_printf( DEBUG_IO, L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", cbuff, c, c & 0xf7 ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index d8d54f9..f967c74 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -28,6 +28,12 @@ */ bool conspageinitihasbeencalled = false; +/** + * keep track of total cells allocated and freed to check for leakage. + */ +uint64_t total_cells_allocated = 0; +uint64_t total_cells_freed = 0; + /** * the number of cons pages which have thus far been initialised. */ @@ -187,6 +193,7 @@ void free_cell( struct cons_pointer pointer ) { cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; + total_cells_freed ++; } else { debug_printf( DEBUG_ALLOC, L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", @@ -228,8 +235,10 @@ struct cons_pointer allocate_cell( uint32_t tag ) { cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; + total_cells_allocated ++; + debug_printf( DEBUG_ALLOC, - L"Allocated cell of type '%s' at %d, %d \n", tag, + L"Allocated cell of type '%4.4s' at %d, %d \n", tag, result.page, result.offset ); } else { debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); @@ -255,3 +264,7 @@ void initialise_cons_pages( ) { L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); } } + +void summarise_allocation() { + fwprintf(stderr, L"Allocation summary: allocated %lld; deallocated %lld.\n", total_cells_allocated, total_cells_freed ); +} \ No newline at end of file diff --git a/src/memory/conspage.h b/src/memory/conspage.h index 260794e..18eda3b 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -61,4 +61,6 @@ void initialise_cons_pages( ); void dump_pages( URL_FILE * output ); +void summarise_allocation(); + #endif diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 5b04699..0eef3d5 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -324,7 +324,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { } else { // \todo should throw an exception! debug_printf( DEBUG_ALLOC, - L"Warning: only NIL and %s can be prepended to %s\n", + L"Warning: only NIL and %4.4s can be prepended to %4.4s\n", tag, tag ); } diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 4709482..0c1b159 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -85,7 +85,7 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) { if ( vso != NULL ) { memset( vso, 0, padded ); debug_printf( DEBUG_ALLOC, - L"make_vso: about to write tag '%s' into vso at %p\n", + L"make_vso: about to write tag '%4.4s' into vso at %p\n", tag, vso ); vso->header.tag.value = tag; result = make_vec_pointer( vso, tag ); From 2b8f31d2ce46a9bd475dd7063366a1c0b956eb10 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 15:02:27 +0100 Subject: [PATCH 097/101] Paths of #include files --- src/arith/integer.c | 10 +++++----- src/arith/peano.c | 24 ++++++++++++------------ src/arith/ratio.c | 16 ++++++++-------- src/arith/real.c | 6 +++--- src/debug.c | 8 ++++---- src/init.c | 22 ++++++++++++---------- src/io/fopen.c | 6 +++--- src/io/io.c | 14 ++++++-------- src/io/print.c | 18 +++++++++--------- src/io/read.c | 36 ++++++++++++++++++++---------------- src/memory/conspage.c | 12 ++++++------ src/memory/consspaceobject.c | 12 ++++++------ src/memory/dump.c | 16 ++++++++-------- src/memory/hashmap.c | 2 +- src/memory/stack.c | 14 +++++++------- src/memory/vectorspace.c | 10 +++++----- src/ops/intern.c | 10 +++++----- src/ops/lispops.c | 24 ++++++++++++------------ src/ops/meta.c | 2 +- src/repl.c | 8 ++++---- src/time/psse_time.c | 9 ++++----- 21 files changed, 141 insertions(+), 138 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 06ef8a3..eef171b 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -18,12 +18,12 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "equal.h" -#include "lispops.h" -#include "peano.h" +#include "ops/equal.h" +#include "ops/lispops.h" +#include "arith/peano.h" /** * hexadecimal digits for printing numbers. diff --git a/src/arith/peano.c b/src/arith/peano.c index 5589f1f..ae23a00 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -14,19 +14,19 @@ #include #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "equal.h" -#include "integer.h" -#include "intern.h" -#include "lispops.h" -#include "peano.h" -#include "print.h" -#include "ratio.h" -#include "read.h" -#include "real.h" -#include "stack.h" +#include "ops/equal.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "ops/lispops.h" +#include "arith/peano.h" +#include "io/print.h" +#include "arith/ratio.h" +#include "io/read.h" +#include "arith/real.h" +#include "memory/stack.h" long double to_long_double( struct cons_pointer arg ); int64_t to_long_int( struct cons_pointer arg ); diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 8100ec2..5135d6b 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -11,15 +11,15 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "equal.h" -#include "integer.h" -#include "lispops.h" -#include "peano.h" -#include "print.h" -#include "ratio.h" +#include "ops/equal.h" +#include "arith/integer.h" +#include "ops/lispops.h" +#include "arith/peano.h" +#include "io/print.h" +#include "arith/ratio.h" /** diff --git a/src/arith/real.c b/src/arith/real.c index a59a125..34d29d0 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -7,10 +7,10 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "read.h" +#include "io/read.h" /** * Allocate a real number cell representing this value and return a cons diff --git a/src/debug.c b/src/debug.c index c8b9771..233e154 100644 --- a/src/debug.c +++ b/src/debug.c @@ -18,11 +18,11 @@ #include #include -#include "consspaceobject.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "dump.h" -#include "io.h" -#include "print.h" +#include "memory/dump.h" +#include "io/io.h" +#include "io/print.h" /** * the controlling flags for `debug_print`; set in `init.c`, q.v. diff --git a/src/init.c b/src/init.c index a47f008..12187fd 100644 --- a/src/init.c +++ b/src/init.c @@ -20,18 +20,20 @@ #include #include "version.h" -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/stack.h" #include "debug.h" -#include "hashmap.h" -#include "intern.h" -#include "io.h" -#include "lispops.h" -#include "meta.h" -#include "peano.h" -#include "print.h" +#include "memory/hashmap.h" +#include "ops/intern.h" +#include "io/io.h" +#include "ops/lispops.h" +#include "ops/meta.h" +#include "arith/peano.h" +#include "io/print.h" #include "repl.h" -#include "psse_time.h" +#include "io/fopen.h" +#include "time/psse_time.h" // extern char *optarg; /* defined in unistd.h */ diff --git a/src/io/fopen.c b/src/io/fopen.c index 3a66806..e4fafdd 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -47,12 +47,12 @@ #include -#include "fopen.h" +#include "io/fopen.h" #ifdef FOPEN_STANDALONE CURLSH *io_share; #else -#include "consspaceobject.h" -#include "io.h" +#include "memory/consspaceobject.h" +#include "io/io.h" #include "utils.h" #endif diff --git a/src/io/io.c b/src/io/io.c index fe08a77..0125488 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -28,13 +28,13 @@ #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "fopen.h" -#include "integer.h" -#include "intern.h" -#include "lispops.h" +#include "io/fopen.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "ops/lispops.h" #include "utils.h" /** @@ -56,8 +56,6 @@ wint_t ungotten = 0; * @return 0 on success; any other value means failure. */ int io_init( ) { - CURL *curl; - CURLcode res; int result = curl_global_init( CURL_GLOBAL_SSL ); io_share = curl_share_init( ); diff --git a/src/io/print.c b/src/io/print.c index 64d7b37..8f4b88e 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -17,15 +17,15 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" -#include "hashmap.h" -#include "integer.h" -#include "intern.h" -#include "stack.h" -#include "print.h" -#include "psse_time.h" -#include "vectorspace.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/hashmap.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "memory/stack.h" +#include "io/print.h" +#include "time/psse_time.h" +#include "memory/vectorspace.h" /** * print all the characters in the symbol or string indicated by `pointer` diff --git a/src/io/read.c b/src/io/read.c index 4425b77..45d1045 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -17,25 +17,29 @@ #include #include -#include "consspaceobject.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "dump.h" -#include "hashmap.h" -#include "integer.h" -#include "intern.h" -#include "io.h" -#include "lispops.h" -#include "peano.h" -#include "print.h" -#include "ratio.h" -#include "read.h" -#include "real.h" -#include "vectorspace.h" +#include "memory/dump.h" +#include "memory/hashmap.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "io/io.h" +#include "ops/lispops.h" +#include "arith/peano.h" +#include "io/print.h" +#include "arith/ratio.h" +#include "io/read.h" +#include "arith/real.h" +#include "memory/vectorspace.h" /* - * for the time being things which may be read are: strings numbers - either - * integer or real, but not yet including ratios or bignums lists Can't read - * atoms because I don't yet know what an atom is or how it's stored. + * for the time being things which may be read are: + * * strings + * * numbers - either integer, ratio or real + * * lists + * * maps + * * keywords + * * atoms */ struct cons_pointer read_number( struct stack_frame *frame, diff --git a/src/memory/conspage.c b/src/memory/conspage.c index f967c74..6cc4814 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -16,12 +16,12 @@ #include #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "dump.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/dump.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** * Flag indicating whether conspage initialisation has been done. @@ -267,4 +267,4 @@ void initialise_cons_pages( ) { void summarise_allocation() { fwprintf(stderr, L"Allocation summary: allocated %lld; deallocated %lld.\n", total_cells_allocated, total_cells_freed ); -} \ No newline at end of file +} diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 0eef3d5..579e84b 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -19,13 +19,13 @@ #include #include "authorise.h" -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "intern.h" -#include "print.h" -#include "stack.h" -#include "vectorspace.h" +#include "ops/intern.h" +#include "io/print.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** * True if the value of the tag on the cell at this `pointer` is this `value`, diff --git a/src/memory/dump.c b/src/memory/dump.c index 81182a8..3148ac1 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -18,15 +18,15 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "hashmap.h" -#include "intern.h" -#include "io.h" -#include "print.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/hashmap.h" +#include "ops/intern.h" +#include "io/io.h" +#include "io/print.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" void dump_string_cell( URL_FILE * output, wchar_t *prefix, diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index d6909ba..a9bc336 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -11,7 +11,7 @@ #include "arith/peano.h" #include "authorise.h" #include "debug.h" -#include "intern.h" +#include "ops/intern.h" #include "io/print.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" diff --git a/src/memory/stack.c b/src/memory/stack.c index 8b0e610..4b70ed1 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -17,14 +17,14 @@ #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "dump.h" -#include "lispops.h" -#include "print.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/dump.h" +#include "ops/lispops.h" +#include "io/print.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** * set a register in a stack frame. Alwaye use this to do so, diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 0c1b159..4bbeb51 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -19,12 +19,12 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "hashmap.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/hashmap.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** diff --git a/src/ops/intern.c b/src/ops/intern.c index 05d5822..cd80612 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -19,12 +19,12 @@ #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "equal.h" -#include "hashmap.h" -#include "lispops.h" +#include "ops/equal.h" +#include "memory/hashmap.h" +#include "ops/lispops.h" // #include "print.h" /** diff --git a/src/ops/lispops.c b/src/ops/lispops.c index fa3c68d..4ff14a1 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -24,19 +24,19 @@ #include #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "dump.h" -#include "equal.h" -#include "integer.h" -#include "intern.h" -#include "io.h" -#include "lispops.h" -#include "print.h" -#include "read.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/dump.h" +#include "ops/equal.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "io/io.h" +#include "ops/lispops.h" +#include "io/print.h" +#include "io/read.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /* * also to create in this section: diff --git a/src/ops/meta.c b/src/ops/meta.c index a27d2af..f00824f 100644 --- a/src/ops/meta.c +++ b/src/ops/meta.c @@ -7,7 +7,7 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "conspage.h" +#include "memory/conspage.h" #include "debug.h" /** diff --git a/src/repl.c b/src/repl.c index 39bbde6..bef08b1 100644 --- a/src/repl.c +++ b/src/repl.c @@ -11,11 +11,11 @@ #include #include -#include "consspaceobject.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "intern.h" -#include "lispops.h" -#include "stack.h" +#include "ops/intern.h" +#include "ops/lispops.h" +#include "memory/stack.h" /** diff --git a/src/time/psse_time.c b/src/time/psse_time.c index 1f24b0e..06c1b58 100644 --- a/src/time/psse_time.c +++ b/src/time/psse_time.c @@ -16,10 +16,10 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" -#include "integer.h" -#include "psse_time.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "arith/integer.h" +#include "time/psse_time.h" #define _GNU_SOURCE #define seconds_per_year 31557600L @@ -63,7 +63,6 @@ struct cons_pointer make_time( struct cons_pointer integer_or_nil ) { if ( integerp( integer_or_nil ) ) { cell->payload.time.value = pointer2cell( integer_or_nil ).payload.integer.value; - // \todo: if integer is a bignum, deal with it. } else { cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); } From 40e35022475915608e630deb15402772499b4819 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 15:06:05 +0100 Subject: [PATCH 098/101] Standardised format (with `make format`) --- src/init.c | 6 +- src/io/io.c | 4 +- src/memory/conspage.c | 10 +-- src/memory/conspage.h | 2 +- src/memory/dump.c | 8 +-- src/memory/hashmap.c | 4 +- src/ops/lispops.c | 144 ++++++++++++++++++++++-------------------- src/ops/lispops.h | 6 +- 8 files changed, 97 insertions(+), 87 deletions(-) diff --git a/src/init.c b/src/init.c index 12187fd..ff8c190 100644 --- a/src/init.c +++ b/src/init.c @@ -238,7 +238,7 @@ int main( int argc, char *argv[] ) { bind_function( L"hashmap", lisp_make_hashmap ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"keys", &lisp_keys ); - bind_function( L"list", &lisp_list); + bind_function( L"list", &lisp_list ); bind_function( L"mapcar", &lisp_mapcar ); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); @@ -272,7 +272,7 @@ int main( int argc, char *argv[] ) { bind_special( L"cond", &lisp_cond ); bind_special( L"lambda", &lisp_lambda ); bind_special( L"\u03bb", &lisp_lambda ); // λ - bind_special(L"let", &lisp_let); + bind_special( L"let", &lisp_let ); bind_special( L"nlambda", &lisp_nlambda ); bind_special( L"n\u03bb", &lisp_nlambda ); bind_special( L"progn", &lisp_progn ); @@ -290,7 +290,7 @@ int main( int argc, char *argv[] ) { dump_pages( file_to_url_file( stdout ) ); } - summarise_allocation(); + summarise_allocation( ); curl_global_cleanup( ); return ( 0 ); } diff --git a/src/io/io.c b/src/io/io.c index 0125488..d01f788 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -502,8 +502,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload. - stream.stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); } return result; diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 6cc4814..f8802cc 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -193,7 +193,7 @@ void free_cell( struct cons_pointer pointer ) { cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; - total_cells_freed ++; + total_cells_freed++; } else { debug_printf( DEBUG_ALLOC, L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", @@ -235,7 +235,7 @@ struct cons_pointer allocate_cell( uint32_t tag ) { cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; - total_cells_allocated ++; + total_cells_allocated++; debug_printf( DEBUG_ALLOC, L"Allocated cell of type '%4.4s' at %d, %d \n", tag, @@ -265,6 +265,8 @@ void initialise_cons_pages( ) { } } -void summarise_allocation() { - fwprintf(stderr, L"Allocation summary: allocated %lld; deallocated %lld.\n", total_cells_allocated, total_cells_freed ); +void summarise_allocation( ) { + fwprintf( stderr, + L"Allocation summary: allocated %lld; deallocated %lld.\n", + total_cells_allocated, total_cells_freed ); } diff --git a/src/memory/conspage.h b/src/memory/conspage.h index 18eda3b..589f6bf 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -61,6 +61,6 @@ void initialise_cons_pages( ); void dump_pages( URL_FILE * output ); -void summarise_allocation(); +void summarise_allocation( ); #endif diff --git a/src/memory/dump.c b/src/memory/dump.c index 3148ac1..2bc5bb0 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -114,10 +114,10 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { case RATIOTV: url_fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); break; case READTV: url_fputws( L"\t\tInput stream; metadata: ", output ); diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index a9bc336..5e1db0a 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -180,8 +180,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, map->payload.hashmap.buckets[bucket_no] = inc_ref( make_cons( make_cons( key, val ), - map->payload. - hashmap.buckets[bucket_no] ) ); + map->payload.hashmap. + buckets[bucket_no] ) ); } } } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 4ff14a1..c4ca4f3 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -61,7 +61,7 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer env ) { debug_print( L"eval_form: ", DEBUG_EVAL ); debug_print_object( form, DEBUG_EVAL ); - debug_println(DEBUG_EVAL); + debug_println( DEBUG_EVAL ); struct cons_pointer result = NIL; struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); @@ -82,7 +82,7 @@ struct cons_pointer eval_form( struct stack_frame *parent, debug_print( L"eval_form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); - debug_println(DEBUG_EVAL); + debug_println( DEBUG_EVAL ); return result; } @@ -416,9 +416,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -594,10 +595,10 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, } else { result = throw_exception( make_cons - ( c_string_to_lisp_string - ( L"The first argument to `set` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), - frame_pointer ); + ( c_string_to_lisp_string + ( L"The first argument to `set` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -633,10 +634,10 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, } else { result = throw_exception( make_cons - ( c_string_to_lisp_string - ( L"The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), - frame_pointer ); + ( c_string_to_lisp_string + ( L"The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -1213,7 +1214,8 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer message = frame->arg[0]; return exceptionp( message ) ? message : throw_exception( message, - frame->previous ); + frame-> + previous ); } /** @@ -1380,13 +1382,14 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { if ( nilp( c_cdr( l1 ) ) ) { return - make_string_like_thing( ( pointer2cell( l1 ).payload. - string.character ), l2, + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), + l2, pointer2cell( l1 ).tag.value ); } else { return - make_string_like_thing( ( pointer2cell( l1 ).payload. - string.character ), + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), c_append( c_cdr( l1 ), l2 ), pointer2cell( l1 ).tag.value ); } @@ -1408,13 +1411,13 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { struct cons_pointer lisp_append( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = fetch_arg(frame, (frame->args - 1)); + struct cons_pointer result = fetch_arg( frame, ( frame->args - 1 ) ); - for (int a = frame->args - 2; a >= 0; a--) { - result = c_append(fetch_arg(frame, a), result); - } + for ( int a = frame->args - 2; a >= 0; a-- ) { + result = c_append( fetch_arg( frame, a ), result ); + } - return result; + return result; } struct cons_pointer lisp_mapcar( struct stack_frame *frame, @@ -1426,34 +1429,35 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, int i = 0; for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { - struct cons_pointer expr = make_cons(frame->arg[0], make_cons(c_car(c), NIL)); - inc_ref(expr); + struct cons_pointer expr = + make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) ); + inc_ref( expr ); - debug_printf(DEBUG_EVAL, L"Mapcar %d, evaluating ", i); - debug_print_object( expr, DEBUG_EVAL); - debug_println(DEBUG_EVAL); + debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); + debug_print_object( expr, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); - struct cons_pointer r = eval_form(frame, frame_pointer, expr, env); + struct cons_pointer r = eval_form( frame, frame_pointer, expr, env ); if ( exceptionp( r ) ) { result = r; - inc_ref( expr ); // to protect exception from the later dec_ref + inc_ref( expr ); // to protect exception from the later dec_ref break; } else { result = make_cons( r, result ); } - debug_printf(DEBUG_EVAL, L"Mapcar %d, result is ", i++); - debug_print_object( result, DEBUG_EVAL); - debug_println(DEBUG_EVAL); + debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); dec_ref( expr ); } - result = consp(result) ? c_reverse( result ) : result; + result = consp( result ) ? c_reverse( result ) : result; debug_print( L"Mapcar returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); - debug_println(DEBUG_EVAL); + debug_println( DEBUG_EVAL ); return result; } @@ -1461,14 +1465,14 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer lisp_list( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = frame->more; + struct cons_pointer result = frame->more; - for ( int a = nilp(result) ? frame->args - 1: args_in_frame - 1; - a >= 0; a-- ) { - result = make_cons(fetch_arg(frame, a), result); - } + for ( int a = nilp( result ) ? frame->args - 1 : args_in_frame - 1; + a >= 0; a-- ) { + result = make_cons( fetch_arg( frame, a ), result ); + } - return result; + return result; } /** @@ -1477,38 +1481,42 @@ struct cons_pointer lisp_list( struct stack_frame *frame, * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. */ struct cons_pointer lisp_let( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env) { - struct cons_pointer bindings = env; - struct cons_pointer result = NIL; + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer bindings = env; + struct cons_pointer result = NIL; - for (struct cons_pointer cursor = frame->arg[0]; - truep(cursor); - cursor = c_cdr(cursor)) { - struct cons_pointer pair = c_car(cursor); - struct cons_pointer symbol = c_car(pair); + for ( struct cons_pointer cursor = frame->arg[0]; + truep( cursor ); cursor = c_cdr( cursor ) ) { + struct cons_pointer pair = c_car( cursor ); + struct cons_pointer symbol = c_car( pair ); - if (symbolp(symbol)) { - bindings = make_cons( - make_cons(symbol, eval_form(frame, frame_pointer, c_cdr(pair), bindings)), - bindings); - - } else { - result = throw_exception( - c_string_to_lisp_string(L"Let: cannot bind, not a symbol"), - frame_pointer); - break; - } - } + if ( symbolp( symbol ) ) { + bindings = + make_cons( make_cons + ( symbol, + eval_form( frame, frame_pointer, c_cdr( pair ), + bindings ) ), bindings ); - /* i.e., no exception yet */ - for (int form = 1; !exceptionp(result) && form < frame->args; form++) { - result = eval_form(frame, frame_pointer, fetch_arg(frame, form), bindings); - } + } else { + result = + throw_exception( c_string_to_lisp_string + ( L"Let: cannot bind, not a symbol" ), + frame_pointer ); + break; + } + } - return result; + /* i.e., no exception yet */ + for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) { + result = + eval_form( frame, frame_pointer, fetch_arg( frame, form ), + bindings ); + } - } + return result; + +} // /** // * Function; print the internal representation of the object indicated by `frame->arg[0]` to the diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 3d1c4f7..ba1e999 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -212,11 +212,11 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); - struct cons_pointer lisp_list( struct stack_frame *frame, +struct cons_pointer lisp_list( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_let( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env); + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif From 462c0c69b4e0513c34c27d75fa4a291a04ae50d9 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 15:28:27 +0100 Subject: [PATCH 099/101] Fixed bug that reading map literal didn't evaluate values. --- src/io/read.c | 33 ++++++++++++++-------- src/io/read.h | 4 ++- src/ops/lispops.c | 70 +++++++++++++++++++++++++++++++---------------- 3 files changed, 71 insertions(+), 36 deletions(-) diff --git a/src/io/read.c b/src/io/read.c index 45d1045..df0735b 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -48,9 +48,11 @@ struct cons_pointer read_number( struct stack_frame *frame, bool seen_period ); struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ); struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, @@ -142,6 +144,7 @@ struct cons_pointer read_path( URL_FILE * input, wint_t initial, */ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ) { debug_print( L"entering read_continuation\n", DEBUG_IO ); struct cons_pointer result = NIL; @@ -171,16 +174,16 @@ struct cons_pointer read_continuation( struct stack_frame *frame, case '\'': result = c_quote( read_continuation - ( frame, frame_pointer, input, + ( frame, frame_pointer, env, input, url_fgetwc( input ) ) ); break; case '(': result = - read_list( frame, frame_pointer, input, + read_list( frame, frame_pointer, env, input, url_fgetwc( input ) ); break; case '{': - result = read_map( frame, frame_pointer, input, + result = read_map( frame, frame_pointer, env, input, url_fgetwc( input ) ); break; case '"': @@ -210,8 +213,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, /* dotted pair. \todo this isn't right, we * really need to backtrack up a level. */ result = - read_continuation( frame, frame_pointer, input, - url_fgetwc( input ) ); + read_continuation( frame, frame_pointer, env, + input, url_fgetwc( input ) ); debug_print ( L"read_continuation: dotted pair; read cdr ", DEBUG_IO ); @@ -383,6 +386,7 @@ struct cons_pointer read_number( struct stack_frame *frame, */ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ) { struct cons_pointer result = NIL; wint_t c; @@ -391,7 +395,7 @@ struct cons_pointer read_list( struct stack_frame *frame, debug_printf( DEBUG_IO, L"read_list starting '%C' (%d)\n", initial, initial ); struct cons_pointer car = - read_continuation( frame, frame_pointer, input, + read_continuation( frame, frame_pointer, env, input, initial ); /* skip whitespace */ @@ -406,10 +410,12 @@ struct cons_pointer read_list( struct stack_frame *frame, make_cons( car, c_car( read_list( frame, frame_pointer, + env, input, url_fgetwc( input ) ) ) ); } else { result = - make_cons( car, read_list( frame, frame_pointer, input, c ) ); + make_cons( car, + read_list( frame, frame_pointer, env, input, c ) ); } } else { debug_print( L"End of list detected\n", DEBUG_IO ); @@ -420,6 +426,7 @@ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ) { // set write ACL to true whilst creating to prevent GC churn struct cons_pointer result = @@ -428,21 +435,23 @@ struct cons_pointer read_map( struct stack_frame *frame, while ( c != L'}' ) { struct cons_pointer key = - read_continuation( frame, frame_pointer, input, c ); + read_continuation( frame, frame_pointer, env, input, c ); /* skip whitespace */ for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) ); struct cons_pointer value = - read_continuation( frame, frame_pointer, input, c ); + read_continuation( frame, frame_pointer, env, input, c ); /* skip commaa and whitespace at this point. */ for ( c = url_fgetwc( input ); c == L',' || iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) ); - result = hashmap_put( result, key, value ); + result = + hashmap_put( result, key, + eval_form( frame, frame_pointer, value, env ) ); } // default write ACL for maps should be NIL. @@ -536,7 +545,7 @@ struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, - URL_FILE * input ) { - return read_continuation( frame, frame_pointer, input, + struct cons_pointer env, URL_FILE * input ) { + return read_continuation( frame, frame_pointer, env, input, url_fgetwc( input ) ); } diff --git a/src/io/read.h b/src/io/read.h index 64f36b0..031bb4f 100644 --- a/src/io/read.h +++ b/src/io/read.h @@ -11,11 +11,13 @@ #ifndef __read_h #define __read_h +#include "memory/consspaceobject.h" + /** * read the next object on this input stream and return a cons_pointer to it. */ struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, - URL_FILE * input ); + struct cons_pointer env, URL_FILE * input ); #endif diff --git a/src/ops/lispops.c b/src/ops/lispops.c index c4ca4f3..436f4df 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -63,21 +63,45 @@ struct cons_pointer eval_form( struct stack_frame *parent, debug_print_object( form, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); - struct cons_pointer result = NIL; - struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); - inc_ref( next_pointer ); + struct cons_pointer result = form; + switch ( pointer2cell( form ).tag.value ) { + /* things which evaluate to themselves */ + case EXCEPTIONTV: + case FREETV: // shouldn't happen, but anyway... + // FUNCTIONTV, LAMBDATV, NLAMBDATV, SPECIALTV ? + case INTEGERTV: + case KEYTV: + case LOOPTV: // don't think this should happen... + case NILTV: + case RATIOTV: + case REALTV: + case READTV: + case STRINGTV: + case TIMETV: + case TRUETV: + // case VECTORPOINTTV: ? + case WRITETV: + break; + default: + { + struct cons_pointer next_pointer = + make_empty_frame( parent_pointer ); + inc_ref( next_pointer ); - struct stack_frame *next = get_stack_frame( next_pointer ); - set_reg( next, 0, form ); - next->args = 1; + struct stack_frame *next = get_stack_frame( next_pointer ); + set_reg( next, 0, form ); + next->args = 1; - result = lisp_eval( next, next_pointer, env ); + result = lisp_eval( next, next_pointer, env ); - if ( !exceptionp( result ) ) { - /* if we're returning an exception, we should NOT free the - * stack frame. Corollary is, when we free an exception, we - * should free all the frames it's holding on to. */ - dec_ref( next_pointer ); + if ( !exceptionp( result ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + dec_ref( next_pointer ); + } + } + break; } debug_print( L"eval_form returning: ", DEBUG_EVAL ); @@ -113,16 +137,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame, } /** - * OK, the idea here (and I know this is less than perfect) is that the basic `try` - * function in PSSE takes two arguments, the first, `body`, being a list of forms, - * and the second, `catch`, being a catch handler (which is also a list of forms). - * Forms from `body` are evaluated in turn until one returns an exception object, + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * function in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, * or until the list is exhausted. If the list was exhausted, then the value of - * evaluating the last form in `body` is returned. If an exception was encountered, - * then each of the forms in `catch` is evaluated and the value of the last of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of * those is returned. - * - * This is experimental. It almost certainly WILL change. + * + * This is experimental. It almost certainly WILL change. */ struct cons_pointer lisp_try( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -891,7 +915,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, input = file_to_url_file( stdin ); } - struct cons_pointer result = read( frame, frame_pointer, input ); + struct cons_pointer result = read( frame, frame_pointer, env, input ); debug_print( L"lisp_read returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); @@ -1406,7 +1430,7 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { } /** - * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp + * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp */ struct cons_pointer lisp_append( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -1476,7 +1500,7 @@ struct cons_pointer lisp_list( struct stack_frame *frame, } /** - * Special form: evaluate a series of forms in an environment in which + * Special form: evaluate a series of forms in an environment in which * these bindings are bound. * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. */ From a8315d649f40d8249f10992924fd755593d700e7 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 16:20:13 +0100 Subject: [PATCH 100/101] Made try/catch actually work --- src/init.c | 1 + src/ops/lispops.c | 23 ++++++++++------------- src/ops/lispops.h | 4 ++++ unit-tests/try.sh | 45 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 60 insertions(+), 13 deletions(-) create mode 100755 unit-tests/try.sh diff --git a/src/init.c b/src/init.c index ff8c190..dee2b7c 100644 --- a/src/init.c +++ b/src/init.c @@ -278,6 +278,7 @@ int main( int argc, char *argv[] ) { bind_special( L"progn", &lisp_progn ); bind_special( L"quote", &lisp_quote ); bind_special( L"set!", &lisp_set_shriek ); + bind_special( L"try", &lisp_try ); debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 436f4df..917f7b5 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -138,7 +138,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame, /** * OK, the idea here (and I know this is less than perfect) is that the basic `try` - * function in PSSE takes two arguments, the first, `body`, being a list of forms, + * special form in PSSE takes two arguments, the first, `body`, being a list of forms, * and the second, `catch`, being a catch handler (which is also a list of forms). * Forms from `body` are evaluated in turn until one returns an exception object, * or until the list is exhausted. If the list was exhausted, then the value of @@ -158,7 +158,7 @@ struct cons_pointer lisp_try( struct stack_frame *frame, // TODO: need to put the exception into the environment! result = c_progn( frame, frame_pointer, frame->arg[1], make_cons( make_cons - ( c_string_to_lisp_keyword + ( c_string_to_lisp_symbol ( L"*exception*" ), result ), env ) ); } @@ -440,10 +440,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload. - special.executable ) ( get_stack_frame - ( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -1238,8 +1237,7 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer message = frame->arg[0]; return exceptionp( message ) ? message : throw_exception( message, - frame-> - previous ); + frame->previous ); } /** @@ -1406,14 +1404,13 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { if ( nilp( c_cdr( l1 ) ) ) { return - make_string_like_thing( ( pointer2cell( l1 ). - payload.string.character ), - l2, + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), l2, pointer2cell( l1 ).tag.value ); } else { return - make_string_like_thing( ( pointer2cell( l1 ). - payload.string.character ), + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), c_append( c_cdr( l1 ), l2 ), pointer2cell( l1 ).tag.value ); } diff --git a/src/ops/lispops.h b/src/ops/lispops.h index ba1e999..da1f27e 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -219,4 +219,8 @@ struct cons_pointer lisp_list( struct stack_frame *frame, struct cons_pointer lisp_let( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_try( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif diff --git a/unit-tests/try.sh b/unit-tests/try.sh new file mode 100755 index 0000000..a6d529c --- /dev/null +++ b/unit-tests/try.sh @@ -0,0 +1,45 @@ +#!/bin/bash + +expected=':foo' +actual=`echo "(try ((+ 2 (/ 1 'a))) (:foo))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='4' +actual=`echo "(try ((+ 2 (/ 1 'a))) ((+ 2 2)))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='8' +actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch (* 2 2 2)))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='' +actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From 86961577a6d8f86ee395cf5d21f4825c1d1bbb9d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 18:43:07 +0100 Subject: [PATCH 101/101] Mostly more documentation --- README.md | 114 ++++++++++++++++++++++++++++++++++++++++++++-- src/init.c | 5 +- src/ops/lispops.c | 27 +++++++++-- 3 files changed, 134 insertions(+), 12 deletions(-) diff --git a/README.md b/README.md index 408818c..145b870 100644 --- a/README.md +++ b/README.md @@ -12,9 +12,11 @@ Has working Lisp interpreter, more or less complete, with functions and symbols At the time of writing, big number arithmetic is completely failing. It has worked in the past, but it doesn't now. +There are ludicrous memory leaks. Essentially the garbage collection strategy isn't yet really working. However, if we are to implement the hypercube architecture in future, a mark and sweep garbage collector will not work, so it's important to get the reference counter working properly. + #### Unknown bugs -It's pretty likely that there are memory leaks. +There are certainly MANY unknown bugs. Please report those you find. #### Not yet implemented @@ -127,7 +129,7 @@ Divides the number *n1* by the number *n2*. If *n1* and *n2* are both integers, Returns true (`t`) if *o1* and *o2* are identically the same object, else `nil`. -#### (equal *o1* *o2*) +#### (equal *o1* *o2*), (= *o1* *o2*) Returns true (`t`) if *o1* and *o2* are structurally identical to one another, else `nil`. @@ -183,7 +185,111 @@ Returns a sequence of all the names bound in the root of the naming system. Opens a stream to the specified *url*. If a second argument is present and is non-`nil`, the stream is opened for reading; otherwise, it's opened for writing. -### Types +#### (print *o* [*stream*]) + +Prints the print-name of object *o* to the output stream which is the value of *stream*, or to the value of \*out\* in the current environment if no *stream* is provided. + +#### (put! *map* *key* *value*) + +Puts *value* as the value of *key* in hashmap *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map. + +#### (put-all! *map* *assoc*) + +Puts each (+key* . *value*) pair from the association list *assoc* into this *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map. + +#### (read [*stream*]) + +Reads a single Lisp form from the input stream which is the value of *stream*, or from the value of \*in\* in the current environment if no *stream* is provided. + +#### (read-char [*stream*]) + +Return the next character from the stream indicated by *stream*, or from the value of \*in\* in the current environment if no *stream* is provided; further arguments are ignored. + +#### (repl [*prompt* *input* *output*)) + +Initiate a new Read/Eval/Print loop with this *prompt*, reading from this *input* stream and writing to this *output* stream. All arguments are optional and default sensibly if omitted. TODO: doesn't actually work yet. + +#### (reverse *seq*) + +Return a new sequence of the same type as *seq*, containing the same elements but in the reverse order. + +#### (slurp *in*) + +Reads all available characters on input stream *in* into a string, and returns the string. + +#### (source *fn*) + +Should return the source code of the function or special form *fn*, but as we don't yet +have a compiler, doesn't. + +#### (subtract *n1* *n2*), (- *n1* *n2*) + +Subtracts the numeric value *n2* from the numeric value *n1*, and returns the difference. + +#### (throw *message*) + +Throws an exception, with the payload *message*. While *message* is at present most usefully a string, it doesn't have to be. Returns the exception, but as exceptions are handled specially by `eval`, it is returned to the catch block of the nearest `try` expression on the stack. + +#### (time [*milliseconds-since-epoch*]) + +Returns a time object whose value is the specified number of *milliseconds-since-epoch*, where the Post Scarcity Software Environment epoch is 14 billion years prior to the UN*X epoch. If *milliseconds-since-epoch* is not specified, returns a time object representing the UTC time when the function was executed. + +#### (type *o*) + +Returns a string representing the type -- actually the tag value -- of the object *o*. + +### Special forms + +#### (cond (test value) ...) + +Evaluates a series of *(test value)* clauses in turn until a test returns non-nil, when the corresponding value is returned and further tests are not evaluated. This is the same syntax as Common Lisp's `cond` implementation, and different from Clojure's. + +It's conventional in Lisp to have a final clause in a `cond` block with the test `t`; however, since we have keywords which are always truthy, it would be equally valid to use `:else` or `:default` as final fallback tests. + +#### (lambda (arg ...) form ...), (λ (arg ...) form ...) + +Returns an anonymous fuction which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form. + +#### (let ((*var* . *val*) ...) form ...) + +Evaluates each of these *form*s sequentially in an environment in which each *var* is bound to the respective *val* in the bindings specified, and returns the value of the last form. + +#### (nlambda (arg ...) form ...), (nλ (arg ...) form ...) + +Returns an anonymous special form which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form. + +#### (progn *f* ...) + +Evaluates each of the forms which are its arguments in turn and returns the value of the last. + +#### (quote *o*), '*o* + +Returns *o*, unevaluated. + +#### (set! *name* *value* [*namespace*]) + +Sets (destructively modifies) the value of *name* this *value* in the root namespace. The *namespace* argument is currently ignored but in future is anticipated to be a path specification of a namespace to be modified. + +#### (try (*form* ...) (*handler* ...)) + +Attempt to evaluate, sequentially, each of the *form*s in the first sequence, and return the value of the last of them; however, if any of them cause an exception to be thrown, then evaluate sequentially each of the *handler*s in the second sequence. + +It is recommended that you structure this as follows: + +`lisp + (try + (:body + (print "hello") + (/ 1 'a) + (print "goodbye")) + (:catch + (print "Well, that failed.") + 5)) +` + +Here, `:body` and `:catch` are syntactic sugar which will not affect the final value. + +### Type values The following types are known. Further types can be defined, and ultimately it should be possible to define further types in Lisp, but these are what you have to be going on with. Note that where this documentation differs from `memory/consspaceobject.h`, this documentation is *wrong*. @@ -261,7 +367,7 @@ A symbol is just like a string except not self-evaluating. Later, there may be s #### TIME -A time stamp. Not really properly implemented yet; the epoch is not defined, and, given the size of numbers we can store, could be pushed far into the past. +A time stamp. The epoch for the Post Scarcity Software Environment is 14 billion years before the UN*X epoch, and is chosen as being a reasonable estimate for the birth of the universe, and thus of the start of time. #### TRUE diff --git a/src/init.c b/src/init.c index dee2b7c..676964f 100644 --- a/src/init.c +++ b/src/init.c @@ -247,9 +247,8 @@ int main( int argc, char *argv[] ) { bind_function( L"oblist", &lisp_oblist ); bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); - bind_function( L"progn", &lisp_progn ); - bind_function( L"put", lisp_hashmap_put ); - bind_function( L"put-all", &lisp_hashmap_put_all ); + bind_function( L"put!", lisp_hashmap_put ); + bind_function( L"put-all!", &lisp_hashmap_put_all ); bind_function( L"read", &lisp_read ); bind_function( L"read-char", &lisp_read_char ); bind_function( L"repl", &lisp_repl ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 917f7b5..f9fb95a 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1256,23 +1256,36 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer expr = NIL; - - /* \todo bind *prompt*, *input*, *output* in the environment to the values - * of arguments 0, 1, and 2 respectively, but in each case only if the - * argument is not nil */ + + debug_printf(DEBUG_REPL, L"Entering new inner REPL\n"); struct cons_pointer input = get_default_stream( true, env ); struct cons_pointer output = get_default_stream( false, env ); - URL_FILE *os = pointer2cell( output ).payload.stream.stream; struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; + inc_ref( env ); + if (truep(frame->arg[0])) { + new_env = set( prompt_name, frame->arg[0], new_env); + } + if (readp(frame->arg[1])) { + new_env = set( c_string_to_lisp_symbol(L"*in*"), frame->arg[1], new_env); + input = frame->arg[1]; + } + if (readp(frame->arg[2])) { + new_env = set( c_string_to_lisp_symbol(L"*out*"), frame->arg[2], new_env); + output = frame->arg[2]; + } + inc_ref( input ); inc_ref( output ); inc_ref( prompt_name ); + URL_FILE *os = pointer2cell( output ).payload.stream.stream; + + /* \todo this is subtly wrong. If we were evaluating * (print (eval (read))) * then the stack frame for read would have the stack frame for @@ -1287,6 +1300,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * are not visible. So copy changes made in the oblist into the enviroment. * \todo the whole process of resolving symbol values needs to be revisited * when we get onto namespaces. */ + /* OK, there's something even more subtle here if the root namespace is a map. + * H'mmmm... */ if ( !eq( oblist, old_oblist ) ) { struct cons_pointer cursor = oblist; @@ -1335,6 +1350,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, dec_ref( prompt_name ); dec_ref( env ); + debug_printf(DEBUG_REPL, L"Leaving inner repl\n"); + return expr; }