From 5e6363e6aeb8840cb64b555c98005ac330755e77 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 14 Feb 2026 11:40:52 +0000 Subject: [PATCH] Fixed the horrendous 'unbound symbol nil' bug. Also work on documentation and unit tests. --- src/arith/integer.c | 31 ++++++---- src/arith/ratio.c | 37 +++++++---- src/debug.c | 39 ++++++++---- src/debug.h | 55 +++++++++++++++- src/init.c | 117 ++++++++++++++++++++++++----------- src/io/io.c | 8 +-- src/memory/consspaceobject.c | 6 +- src/memory/hashmap.c | 6 -- src/ops/intern.c | 13 +++- src/ops/intern.h | 2 + src/ops/lispops.c | 5 +- unit-tests/add.sh | 45 +++++++++----- unit-tests/append.sh | 28 +++++++-- unit-tests/apply.sh | 23 ++++++- unit-tests/bignum-add.sh | 32 +++++----- unit-tests/cond.sh | 8 ++- unit-tests/try.sh | 16 +++-- 17 files changed, 328 insertions(+), 143 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 821b476..0247d0f 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -55,7 +55,7 @@ struct cons_pointer small_int_cache[SMALL_INT_LIMIT]; * 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 + * @param op a character representing the operation: expected to 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. @@ -128,8 +128,8 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ) { struct cons_pointer result; - if ( !nilp( more) || value >= SMALL_INT_LIMIT) { - debug_print( L"acquire_integer passing to make_integer (too large)\n", DEBUG_ALLOC ); + if ( !nilp( more) || value < 0 || value >= SMALL_INT_LIMIT) { + debug_print( L"acquire_integer passing to make_integer (outside small int range)\n", DEBUG_ALLOC ); result = make_integer( value, more); } else { if ( !small_int_cache_initialised) { @@ -239,7 +239,7 @@ struct cons_pointer add_integers( struct cons_pointer a, 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 rv = av + bv + carry; + __int128_t rv = (av + bv) + carry; debug_print( L"add_integers: av = ", DEBUG_ARITH ); debug_print_128bit( av, DEBUG_ARITH ); @@ -251,17 +251,22 @@ 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 ); - cursor = new; + if ( carry == 0 && ( rv >= 0 || rv < SMALL_INT_LIMIT)) { + result = acquire_integer( (int64_t)(rv & 0xffffffff), NIL); + break; + } else { + struct cons_pointer new = make_integer( 0, NIL ); + carry = int128_to_integer( rv, cursor, new ); + cursor = new; - if ( nilp( result ) ) { - result = cursor; + if ( nilp( result ) ) { + result = cursor; + } + + a = pointer2cell( a ).payload.integer.more; + b = pointer2cell( b ).payload.integer.more; + is_first_cell = false; } - - a = pointer2cell( a ).payload.integer.more; - b = pointer2cell( b ).payload.integer.more; - is_first_cell = false; } } diff --git a/src/arith/ratio.c b/src/arith/ratio.c index f0095b1..aa8e69f 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -45,16 +45,17 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { 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 ( divisor.payload.integer.value == 1 ) { - result = pointer2cell( pointer ).payload.ratio.dividend; - } else { - if ( ratiop( pointer ) ) { + if ( ratiop( 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 ( divisor.payload.integer.value == 1 ) { + result = pointer2cell( pointer ).payload.ratio.dividend; + } else { int64_t ddrv = dividend.payload.integer.value, drrv = divisor.payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); @@ -63,13 +64,16 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) { if ( drrv / gcd == 1 ) { result = acquire_integer( ddrv / gcd, NIL ); } else { + debug_printf( DEBUG_ARITH, + L"simplify_ratio: %ld/%ld => %ld/%ld\n", ddrv, drrv, ddrv/gcd, drrv/gcd); result = make_ratio( acquire_integer( ddrv / gcd, NIL ), acquire_integer( drrv / gcd, NIL ) ); } } } - } + } + // TODO: else throw exception? return result; @@ -311,23 +315,30 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, if ( integerp( dividend ) && integerp( divisor ) ) { inc_ref( dividend ); inc_ref( divisor ); - result = allocate_cell( RATIOTV ); - struct cons_space_object *cell = &pointer2cell( result ); + struct cons_pointer unsimplified = allocate_cell( RATIOTV ); + struct cons_space_object *cell = &pointer2cell( unsimplified ); cell->payload.ratio.dividend = dividend; cell->payload.ratio.divisor = divisor; + + result = simplify_ratio( unsimplified); + if ( !eq( result, unsimplified)) { dec_ref( unsimplified); } } else { result = throw_exception( c_string_to_lisp_string ( L"Dividend and divisor of a ratio must be integers" ), NIL ); } + // debug_print( L"make_ratio returning:\n", DEBUG_ARITH); debug_dump_object( result, DEBUG_ARITH ); return result; } /** - * True if a and be are identical ratios, else false. + * True if a and be are identical rationals, else false. + * + * TODO: we need ways of checking whether rationals are equal + * to floats and to integers. */ bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) { bool result = false; diff --git a/src/debug.c b/src/debug.c index 233e154..d139f8c 100644 --- a/src/debug.c +++ b/src/debug.c @@ -1,4 +1,4 @@ -/** +/* * debug.c * * Better debug log messages. @@ -25,13 +25,17 @@ #include "io/print.h" /** - * the controlling flags for `debug_print`; set in `init.c`, q.v. + * @brief the controlling flags for `debug_print`; set in `init.c`, q.v. + * + * Interpreted as a set o binary flags. The values are controlled by macros + * with names 'DEBUG_[A_Z]*' in `debug.h`, q.v. */ int verbosity = 0; /** - * print this debug `message` to stderr, if `verbosity` matches `level`. - * `verbosity is a set of flags, see debug_print.h; so you can + * @brief print this debug `message` to stderr, if `verbosity` matches `level`. + * + * `verbosity` is a set of flags, see debug_print.h; so you can * turn debugging on for only one part of the system. */ void debug_print( wchar_t *message, int level ) { @@ -44,6 +48,11 @@ void debug_print( wchar_t *message, int level ) { } /** + * @brief print a 128 bit integer value to stderr, if `verbosity` matches `level`. + * + * `verbosity` is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. + * * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc */ void debug_print_128bit( __int128_t n, int level ) { @@ -68,8 +77,9 @@ void debug_print_128bit( __int128_t n, int level ) { } /** - * print a line feed to stderr, if `verbosity` matches `level`. - * `verbosity is a set of flags, see debug_print.h; so you can + * @brief print a line feed to stderr, if `verbosity` matches `level`. + * + * `verbosity` is a set of flags, see debug_print.h; so you can * turn debugging on for only one part of the system. */ void debug_println( int level ) { @@ -83,8 +93,10 @@ 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`. + * @brief `wprintf` adapted for the debug logging system. + * + * Print to stderr only if `verbosity` matches `level`. All other arguments + * as for `wprintf`. */ void debug_printf( int level, wchar_t *format, ... ) { #ifdef DEBUG @@ -98,8 +110,10 @@ void debug_printf( int level, wchar_t *format, ... ) { } /** - * print the object indicated by this `pointer` to stderr, if `verbosity` - * matches `level`.`verbosity is a set of flags, see debug_print.h; so you can + * @brief print the object indicated by this `pointer` to stderr, if `verbosity` + * matches `level`. + * + * `verbosity` is a set of flags, see debug_print.h; so you can * turn debugging on for only one part of the system. */ void debug_print_object( struct cons_pointer pointer, int level ) { @@ -114,7 +128,10 @@ void debug_print_object( struct cons_pointer pointer, int level ) { } /** - * Like `dump_object`, q.v., but protected by the verbosity mechanism. + * @brief Like `dump_object`, q.v., but protected by the verbosity mechanism. + * + * `verbosity` is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. */ void debug_dump_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG diff --git a/src/debug.h b/src/debug.h index babbaea..41c1618 100644 --- a/src/debug.h +++ b/src/debug.h @@ -1,4 +1,4 @@ -/** +/* * debug.h * * Better debug log messages. @@ -13,14 +13,67 @@ #ifndef __debug_print_h #define __debug_print_h +/** + * @brief Print messages debugging memory allocation. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ #define DEBUG_ALLOC 1 + +/** + * @brief Print messages debugging arithmetic operations. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ #define DEBUG_ARITH 2 + +/** + * @brief Print messages debugging symbol binding. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ #define DEBUG_BIND 4 + +/** + * @brief Print messages debugging bootstrapping and teardown. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ #define DEBUG_BOOTSTRAP 8 + +/** + * @brief Print messages debugging evaluation. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ #define DEBUG_EVAL 16 + +/** + * @brief Print messages debugging input/output operations. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ #define DEBUG_IO 32 + +/** + * @brief Print messages debugging lambda functions (interpretation). + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ #define DEBUG_LAMBDA 64 + +/** + * @brief Print messages debugging the read eval print loop. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ #define DEBUG_REPL 128 + +/** + * @brief Print messages debugging stack operations. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ #define DEBUG_STACK 256 extern int verbosity; diff --git a/src/init.c b/src/init.c index 17f8d36..7c4bdc3 100644 --- a/src/init.c +++ b/src/init.c @@ -65,6 +65,25 @@ struct cons_pointer check_exception( struct cons_pointer pointer, char * locatio return result; } +struct cons_pointer init_name_symbol = NIL; +struct cons_pointer init_primitive_symbol = NIL; + +void maybe_bind_init_symbols() { + if ( nilp( init_name_symbol)) { + init_name_symbol = c_string_to_lisp_keyword( L"name" ); + } + if ( nilp( init_primitive_symbol)) { + init_primitive_symbol = c_string_to_lisp_keyword( L"primitive" ); + } + if ( nilp( privileged_symbol_nil)) { + privileged_symbol_nil = c_string_to_lisp_symbol( L"nil"); + } +} + +void free_init_symbols() { + dec_ref( init_name_symbol); + dec_ref( init_primitive_symbol); +} /** * Bind this compiled `executable` function, as a Lisp function, to @@ -73,45 +92,75 @@ struct cons_pointer check_exception( struct cons_pointer pointer, char * locatio * 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 cons_pointer 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 ), + make_cons( make_cons( init_primitive_symbol, TRUE ), + make_cons( make_cons( init_name_symbol, n ), NIL ) ); - check_exception( deep_bind( n, make_function( meta, executable ) ), + struct cons_pointer r = check_exception( + deep_bind( n, make_function( meta, executable ) ), "bind_function"); + + dec_ref( n); + + return r; } /** * 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 cons_pointer 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 ) ); - check_exception(deep_bind( n, make_special( meta, executable ) ), + struct cons_pointer meta = + make_cons( make_cons( init_primitive_symbol, TRUE ), + make_cons( make_cons( init_name_symbol, n), NIL ) ); + + struct cons_pointer r = + check_exception(deep_bind( n, make_special( meta, executable ) ), "bind_special"); + + dec_ref( n); + + return r; +} + +/** + * Bind this `value` to this `symbol` in the `oblist`. + */ +struct cons_pointer +bind_symbol_value( struct cons_pointer symbol, struct cons_pointer value, bool lock) { + struct cons_pointer r = check_exception( + deep_bind( symbol, value ), + "bind_symbol_value"); + + if ( lock && !exceptionp( r)){ + struct cons_space_object * cell = & pointer2cell( r); + + cell->count = UINT32_MAX; + } + + return r; } /** * Bind this `value` to this `name` in the `oblist`. */ -struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value ) { - return check_exception( - deep_bind( c_string_to_lisp_symbol( name ), value ), - "bind_value"); +struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value, bool lock ) { + struct cons_pointer p = c_string_to_lisp_symbol( name ); + + struct cons_pointer r = bind_symbol_value( p, value, lock); + + dec_ref( p); + + return r; } void print_banner( ) { @@ -187,21 +236,15 @@ int main( int argc, char *argv[] ) { } } + initialise_cons_pages(); + + maybe_bind_init_symbols(); + + if ( show_prompt ) { print_banner( ); } - initialise_cons_pages( ); - -// TODO: oblist-as-hashmap (which is what we ultimately need) is failing hooribly. -// What actually goes wrong is: -// 1. the hashmap is created; -// 2. everything bound in init seems to get initialised properly; -// 3. the REPL starts up; -// 4. Anything typed into the REPL (except ctrl-D) results in immediate segfault. -// 5. If ctrl-D is the first thing typed into the REPL, shutdown proceeds normally. -// Hypothesis: binding stuff into a hashmap oblist either isn't happening or -// is wrking ok, but retrieving from a hashmap oblist is failing. debug_print( L"About to initialise oblist\n", DEBUG_BOOTSTRAP ); oblist = make_hashmap( 32, NIL, TRUE ); @@ -211,8 +254,8 @@ int main( int argc, char *argv[] ) { /* * privileged variables (keywords) */ - bind_value( L"nil", NIL ); - bind_value( L"t", TRUE ); + bind_symbol_value( privileged_symbol_nil, NIL, true); + bind_value( L"t", TRUE, true ); /* * standard input, output, error and sink streams @@ -233,7 +276,7 @@ int main( int argc, char *argv[] ) { ( L"url" ), c_string_to_lisp_string ( L"system:standard input" ) ), - NIL ) ) ); + NIL ) ), false ); lisp_io_out = bind_value( C_IO_OUT, make_write_stream( file_to_url_file( stdout ), make_cons( make_cons @@ -241,26 +284,26 @@ int main( int argc, char *argv[] ) { ( L"url" ), c_string_to_lisp_string ( L"system:standard output]" ) ), - NIL ) ) ); + NIL ) ), false); 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 ) ) ); + NIL ) ), false ); 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 ) ) ); + NIL ) ), false ); /* * the default prompt */ prompt_name = bind_value( L"*prompt*", - show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL ); + show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL, false ); /* * primitive function operations */ @@ -327,13 +370,15 @@ int main( int argc, char *argv[] ) { 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 ) ); } + debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); + dec_ref( oblist ); + free_init_symbols(); + summarise_allocation( ); curl_global_cleanup( ); return ( 0 ); diff --git a/src/io/io.c b/src/io/io.c index 2db9492..66c51c2 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -413,12 +413,8 @@ struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { struct cons_pointer stream_name = inputp ? lisp_io_in : lisp_io_out; - inc_ref( stream_name ); - result = c_assoc( stream_name, env ); - dec_ref( stream_name ); - return result; } @@ -430,7 +426,7 @@ struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { * to append, or error if the URL is faulty or indicates an unavailable * resource. * - * * (read-char stream) + * * (open url) * * @param frame my stack_frame. * @param frame_pointer a pointer to my stack_frame. @@ -524,6 +520,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, * Function: return a string representing all characters from the stream * indicated by arg 0; further arguments are ignored. * + * TODO: it should be possible to optionally pass a string URL to this function, + * * * (slurp stream) * * @param frame my stack_frame. diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 8a8ed2a..5a234da 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -80,7 +80,7 @@ struct cons_pointer inc_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 ) { + if ( cell->count > 0 && cell->count != UINT32_MAX) { cell->count--; if ( cell->count == 0 ) { @@ -307,10 +307,6 @@ struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail, cell->payload.string.character = c; cell->payload.string.cdr = tail; - /* \todo There's a problem here. Sometimes the offsets on - * strings are quite massively off. Fix is probably - * cell->payload.string.cdr = tail */ - //cell->payload.string.cdr.offset = tail.offset; cell->payload.string.hash = calculate_hash( c, tail ); } else { diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index 15b5550..d268bd9 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -94,9 +94,6 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, } } - // TODO: I am not sure this is right! We do not inc_ref a string when - // we make it. - inc_ref(result); return result; } @@ -118,9 +115,6 @@ struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, struct cons_pointer result = hashmap_put( mapp, key, val ); struct cons_space_object *cell = &pointer2cell( result); - // if (cell->count <= 1) { - // inc_ref( result); // TODO: I DO NOT BELIEVE this is the right place! - // } return result; // TODO: else clone and return clone. diff --git a/src/ops/intern.c b/src/ops/intern.c index 3fb38d3..d2be616 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -36,7 +36,7 @@ // #include "print.h" /** - * The global object list/or, to put it differently, the root namespace. + * @brief 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 @@ -47,6 +47,12 @@ */ struct cons_pointer oblist = NIL; +/** + * @brief the symbol `NIL`, which is special! + * + */ +struct cons_pointer privileged_symbol_nil = NIL; + /** * 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 @@ -163,7 +169,6 @@ struct cons_pointer hashmap_keys( struct cons_pointer mapp ) { !nilp( c ); c = c_cdr( c ) ) { result = make_cons( c_car( c_car( c ) ), result ); } - } } @@ -260,6 +265,8 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { return result; } +// (keys set let quote read equal *out* *log* oblist cons source cond close meta mapcar negative? open subtract eval nλ *in* *sink* cdr set! reverse slurp try assoc eq add list time car t *prompt* absolute append apply divide exception get-hash hashmap inspect metadata multiply print put! put-all! read-char repl throw type + * - / = lambda λ nlambda progn) + /** * Implementation of interned? in C. The final implementation if interned? will * deal with stores which can be association lists or hashtables or hybrids of @@ -294,6 +301,8 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { // } if (!nilp( c_assoc( key, store))) { result = key; + } else if ( equal( key, privileged_symbol_nil)) { + result = privileged_symbol_nil; } } else { debug_print( L"`", DEBUG_BIND ); diff --git a/src/ops/intern.h b/src/ops/intern.h index 6be9cbc..abc6f91 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -20,6 +20,8 @@ #ifndef __intern_h #define __intern_h +extern struct cons_pointer privileged_symbol_nil; + extern struct cons_pointer oblist; uint32_t get_hash( struct cons_pointer ptr ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 2f549e4..c0765cd 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1273,8 +1273,6 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, 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); } @@ -1338,7 +1336,6 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, new_env ); - inc_ref( expr ); if ( exceptionp( expr ) && url_feof( pointer2cell( input ).payload.stream.stream ) ) { @@ -1356,7 +1353,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, dec_ref( input ); dec_ref( output ); dec_ref( prompt_name ); - dec_ref( env ); + dec_ref( new_env); debug_printf(DEBUG_REPL, L"Leaving inner repl\n"); diff --git a/unit-tests/add.sh b/unit-tests/add.sh index 2802c3a..ca6f2a8 100755 --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -1,79 +1,92 @@ #!/bin/bash +result=0; + +echo -n "$0: Add two small integers... " + expected='5' -actual=`echo "(add 2 3)" | target/psse | tail -1` +actual=`echo "(add 2 3)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + result=`echo "${result} + 1" | bc` fi +echo -n "$0: Add float to integer... " + expected='5.5' -actual=`echo "(add 2.5 3)" | target/psse | tail -1` +actual=`echo "(add 2.5 3)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" - exit 0 else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + result=`echo "${result} + 1" | bc` fi +echo -n "$0: Add two rationals... " + expected='1/4' -actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1` +actual=`echo "(+ 3/14 1/28)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + result=`echo "${result} + 1" | bc` fi +echo -n "$0: Add an integer to a rational... " + # (+ integer ratio) should be ratio expected='25/4' -actual=`echo "(+ 6 1/4)" | target/psse | tail -1` +actual=`echo "(+ 6 1/4)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + result=`echo "${result} + 1" | bc` fi +echo -n "$0: Add a rational to an integer... " + # (+ ratio integer) should be ratio expected='25/4' -actual=`echo "(+ 1/4 6)" | target/psse | tail -1` +actual=`echo "(+ 1/4 6)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + result=`echo "${result} + 1" | bc` fi +echo -n "$0: Add a real to a rational... " + # (+ real ratio) should be real # for this test, trailing zeros can be ignored expected='6.25' actual=`echo "(+ 6.000000001 1/4)" |\ target/psse 2> /dev/null |\ - sed 's/0*$//' |\ - head -2 |\ - tail -1` + sed -r '/^\s*$/d' |\ + sed 's/0*$//' outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc` -if [ "${outcome}" = "1" ] +if [ "${outcome}" -eq "1" ] then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + result=`echo "${result} + 1" | bc ` fi +exit ${result} diff --git a/unit-tests/append.sh b/unit-tests/append.sh index 0f6fb30..972aa04 100755 --- a/unit-tests/append.sh +++ b/unit-tests/append.sh @@ -1,24 +1,44 @@ #!/bin/bash +return=0; + +echo -n "$0: Append two lists... " + expected='(a b c d e f)' -actual=`echo "(append '(a b c) '(d e f))" | target/psse | tail -1` +actual=`echo "(append '(a b c) '(d e f))" | target/psse 2>/dev/null | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + return=`echo "${return} + 1" | bc` fi +echo -n "$0: Append two strings... " + expected='"hellodere"' -actual=`echo '(append "hello" "dere")' | target/psse | tail -1` +actual=`echo '(append "hello" "dere")' | target/psse 2>/dev/null | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + return=`echo "${return} + 1" | bc` fi +echo -n "$0: Append keyword to string should error... " + +expected='Exception:' +actual=`echo '(append "hello" :dere)' | target/psse 2>/dev/null | sed -r '/^\s*$/d' | awk '{print $1}'` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + return=`echo "${return} + 1" | bc` +fi + +exit ${return} \ No newline at end of file diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh index 811fdae..63b76a3 100755 --- a/unit-tests/apply.sh +++ b/unit-tests/apply.sh @@ -1,13 +1,30 @@ #!/bin/bash +result=1 + +echo -n "$0: Apply function to one argument... " expected='1' -actual=`echo "(apply 'add '(1))"| target/psse | tail -1` +actual=`echo "(apply 'add '(1))"| target/psse 2>/dev/null | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" - exit 0 else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + result=`echo "${result} + 1" | bc` fi + +echo -n "$0: Apply function to multiple arguments... " +expected='3' +actual=`echo "(apply 'add '(1 2))"| target/psse 2>/dev/null | tail -1` + + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + result=`echo "${result} + 1" | bc` +fi + +exit ${result} diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh index 293e1e5..c82dee6 100755 --- a/unit-tests/bignum-add.sh +++ b/unit-tests/bignum-add.sh @@ -20,7 +20,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - return=1 + return=`echo "${return} + 1" | bc` fi echo -n "checking no bignum was created: " @@ -30,7 +30,7 @@ then echo "OK" else echo "Fail" - return=1 + return=`echo "${return} + 1" | bc` fi ##################################################################### @@ -52,7 +52,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - return=1 + return=`echo "${return} + 1" | bc` fi echo -n "$0 => checking a bignum was created: " @@ -62,7 +62,7 @@ then echo "OK" else echo "Fail" - return=1 + return=`echo "${return} + 1" | bc` fi @@ -85,7 +85,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - return=1 + return=`echo "${return} + 1" | bc` fi echo -n "$0 => checking a bignum was created: " @@ -95,7 +95,7 @@ then echo "OK" else echo "Fail" - return=1 + return=`echo "${return} + 1" | bc` fi ##################################################################### @@ -118,7 +118,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - return=1 + return=`echo "${return} + 1" | bc` fi echo -n "checking a bignum was created: " @@ -128,7 +128,7 @@ then echo "OK" else echo "Fail" - return=1 + return=`echo "${return} + 1" | bc` fi @@ -150,7 +150,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - return=1 + return=`echo "${return} + 1" | bc` fi ##################################################################### @@ -171,7 +171,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - return=1 + return=`echo "${return} + 1" | bc` fi @@ -195,7 +195,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - return=1 + return=`echo "${return} + 1" | bc` fi echo -n "$0 => checking a bignum was created: " @@ -205,7 +205,7 @@ then echo "OK" else echo "Fail" - return=1 + return=`echo "${return} + 1" | bc` fi @@ -228,7 +228,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - return=1 + return=`echo "${return} + 1" | bc` fi echo -n "$0 => checking a bignum was created: " @@ -238,7 +238,7 @@ then echo "OK" else echo "Fail" - return=1 + return=`echo "${return} + 1" | bc` fi @@ -262,7 +262,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - return=1 + return=`echo "${return} + 1" | bc` fi echo -n "$0 => checking a bignum was created: " @@ -272,7 +272,7 @@ then echo "OK" else echo "Fail" - return=1 + return=`echo "${return} + 1" | bc` fi exit ${return} \ No newline at end of file diff --git a/unit-tests/cond.sh b/unit-tests/cond.sh index 69952c9..4c4a66c 100755 --- a/unit-tests/cond.sh +++ b/unit-tests/cond.sh @@ -2,8 +2,10 @@ result=0 +echo -n "$0: cond with one clause... " + expected='5' -actual=`echo "(cond ((equal 2 2) 5))" | target/psse | tail -1` +actual=`echo "(cond ((equal 2 2) 5))" | target/psse 2>/dev/null | tail -1` if [ "${expected}" = "${actual}" ] then @@ -13,8 +15,10 @@ else result=1 fi +echo -n "$0: cond with two clauses... " + expected='"should"' -actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse | tail -1` +actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2>/dev/null | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/try.sh b/unit-tests/try.sh index a6d529c..c70c4d8 100755 --- a/unit-tests/try.sh +++ b/unit-tests/try.sh @@ -1,5 +1,7 @@ #!/bin/bash +result=0 + expected=':foo' actual=`echo "(try ((+ 2 (/ 1 'a))) (:foo))" | target/psse | tail -1` @@ -8,7 +10,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + return=`echo "${return} + 1" | bc` fi expected='4' @@ -19,7 +21,7 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + return=`echo "${return} + 1" | bc` fi expected='8' @@ -30,16 +32,18 @@ then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + return=`echo "${return} + 1" | bc` fi -expected='' -actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse | tail -1` +expected='Exception: "Cannot divide: not a number"' +actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse | grep Exception` if [ "${expected}" = "${actual}" ] then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" - exit 1 + return=`echo "${return} + 1" | bc` fi + +exit ${result}