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

Fixed the horrendous 'unbound symbol nil' bug. Also work on documentation and

Browse source 
unit tests.
This commit is contained in:
Simon Brooke 2026-02-14 11:40:52 +00:00
parent 3659103dd7
commit 5e6363e6ae
17 changed files with 328 additions and 143 deletions
Download patch file Download diff file Expand all files Collapse all files

11
src/arith/integer.c
View file

@ -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,6 +251,10 @@ struct cons_pointer add_integers( struct cons_pointer a,
debug_print_128bit( rv, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
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;
@ -264,6 +268,7 @@ struct cons_pointer add_integers( struct cons_pointer a,
is_first_cell = false;
}
}
}
debug_print( L"add_integers returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );

19
src/arith/ratio.c
View file

@ -45,6 +45,8 @@ 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;
if ( ratiop( pointer ) ) {
struct cons_space_object cell = pointer2cell( pointer );
struct cons_space_object dividend =
pointer2cell( cell.payload.ratio.dividend );
@ -54,7 +56,6 @@ struct cons_pointer simplify_ratio( struct cons_pointer 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 );
@ -63,6 +64,8 @@ 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 ) );
@ -70,6 +73,7 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
}
}
}
// 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;

39
src/debug.c
View file

@ -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

55
src/debug.h
View file

@ -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;

115
src/init.c
View file

@ -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 ) );
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 );

8
src/io/io.c
View file

@ -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.

6
src/memory/consspaceobject.c
View file

@ -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 {

6
src/memory/hashmap.c
View file

@ -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.

13
src/ops/intern.c
View file

@ -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 );

2
src/ops/intern.h
View file

@ -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 );

5
src/ops/lispops.c
View file

@ -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");

45
unit-tests/add.sh
View file

@ -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}

28
unit-tests/append.sh
View file

@ -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}

23
unit-tests/apply.sh
View file

@ -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}

32
unit-tests/bignum-add.sh
View file

@ -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}

8
unit-tests/cond.sh
View file

@ -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

16
unit-tests/try.sh
View file

@ -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}