From 98120d045b2cee70c3fb8f0427abe719801974f2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 23 Dec 2018 14:16:51 +0000 Subject: [PATCH 01/22] All unit tests now pass --- unit-tests/nlambda.sh | 13 +++++++++++++ unit-tests/string-allocation.sh | 10 ++++------ 2 files changed, 17 insertions(+), 6 deletions(-) create mode 100644 unit-tests/nlambda.sh diff --git a/unit-tests/nlambda.sh b/unit-tests/nlambda.sh new file mode 100644 index 0000000..f267527 --- /dev/null +++ b/unit-tests/nlambda.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +expected='a' +actual=`echo "((nlambda (x) x) a)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh index 7fe78c4..6f55143 100644 --- a/unit-tests/string-allocation.sh +++ b/unit-tests/string-allocation.sh @@ -1,17 +1,15 @@ #!/bin/bash -log=log.$$ value='"Fred"' -expected="String cell: character 'F' (70)" -echo ${value} | target/psse -d > ${log} 2>/dev/null -grep "${expected}" ${log} > /dev/null +expected="String cell: character 'F'" +# set! protects "Fred" from the garbage collector. +actual=`echo "(set! x ${value})" | target/psse -d 2>&1 | grep "$expected" | sed 's/ *\(.*\) next.*$/\1/'` if [ $? -eq 0 ] then echo "OK" - rm ${log} exit 0 else - echo "Expected '${expected}', not found in ${log}" + echo "Fail: expected '${expected}', got '${actual}'" exit 1 fi From 2c001a5f98c9588b549d4331815a231f714cb2e7 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 23 Dec 2018 15:16:53 +0000 Subject: [PATCH 02/22] Sorting out what looked like a premature freeing bug. It wasn't, but in investigating I tightened up allocation and deallocation in frames. --- src/consspaceobject.c | 2 +- src/equal.c | 4 ++-- src/lispops.c | 20 +++++++++++--------- src/print.c | 12 +++++++----- src/print.h | 2 +- src/repl.c | 28 +++++++++++++--------------- src/stack.c | 11 ++++------- src/stack.h | 7 +++++++ 8 files changed, 46 insertions(+), 40 deletions(-) diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 0fe28e3..ef96c1f 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -54,7 +54,7 @@ void inc_ref( struct cons_pointer pointer ) { void dec_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); - if ( cell->count <= MAXREFERENCE ) { + if ( cell->count > 0 ) { cell->count--; if ( cell->count == 0 ) { diff --git a/src/equal.c b/src/equal.c index ebb085e..0f0597c 100644 --- a/src/equal.c +++ b/src/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/lispops.c b/src/lispops.c index 62338b1..f29c658 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -88,8 +88,7 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer result = NIL; struct stack_frame *next = make_empty_frame( parent, env ); - next->arg[0] = form; - inc_ref( next->arg[0] ); + set_reg( next, 0, form ); result = lisp_eval( next, env ); if ( !exceptionp( result ) ) { @@ -242,8 +241,7 @@ struct cons_pointer c_apply( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; struct stack_frame *fn_frame = make_empty_frame( frame, env ); - fn_frame->arg[0] = c_car( frame->arg[0] ); - inc_ref( fn_frame->arg[0] ); + set_reg( fn_frame, 0, c_car( frame->arg[0] ) ); struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); if ( !exceptionp( result ) ) { @@ -438,9 +436,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { fputws( L"Apply: ", stderr ); dump_frame( stderr, frame ); - frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] ); - inc_ref( frame->arg[0] ); - frame->arg[1] = NIL; + set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); + set_reg( frame, 1, NIL ); struct cons_pointer result = c_apply( frame, env ); @@ -653,15 +650,20 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) { */ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer env ) { + struct cons_pointer result = NIL; FILE *output = stdout; if ( writep( frame->arg[1] ) ) { output = pointer2cell( frame->arg[1] ).payload.stream.stream; } - print( output, frame->arg[0] ); + result = print( output, frame->arg[0] ); - return NIL; + fputws( L"Print returning ", stderr); + print(stderr, result); + fputws( L"\n", stderr); + + return result; } diff --git a/src/print.c b/src/print.c index 42bf8b4..0ab42b2 100644 --- a/src/print.c +++ b/src/print.c @@ -103,7 +103,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) { * Print the cons-space object indicated by `pointer` to the stream indicated * by `output`. */ -void print( FILE * output, struct cons_pointer pointer ) { +struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); char *buffer; @@ -132,8 +132,8 @@ void print( FILE * output, struct cons_pointer pointer ) { case LAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body ) ) ); + cell.payload.lambda. + body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); @@ -141,8 +141,8 @@ void print( FILE * output, struct cons_pointer pointer ) { case NLAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ), make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body ) ) ); + cell.payload.lambda. + body ) ) ); break; case READTV: fwprintf( output, L"(Input stream)" ); @@ -196,4 +196,6 @@ void print( FILE * output, struct cons_pointer pointer ) { if ( print_use_colours ) { fputws( L"\x1B[39m", output ); } + + return pointer; } diff --git a/src/print.h b/src/print.h index 7ee9c80..1399db4 100644 --- a/src/print.h +++ b/src/print.h @@ -14,7 +14,7 @@ #ifndef __print_h #define __print_h -void print( FILE * output, struct cons_pointer pointer ); +struct cons_pointer print( FILE * output, struct cons_pointer pointer ); extern int print_use_colours; #endif diff --git a/src/repl.c b/src/repl.c index 40f6300..2ebf79d 100644 --- a/src/repl.c +++ b/src/repl.c @@ -33,7 +33,7 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { struct stack_frame *frame = make_empty_frame( NULL, oblist ); - frame->arg[0] = stream_pointer; + set_reg( frame, 0, stream_pointer ); struct cons_pointer result = lisp_read( frame, oblist ); free_stack_frame( frame ); @@ -46,7 +46,7 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { struct cons_pointer repl_eval( struct cons_pointer input ) { struct stack_frame *frame = make_empty_frame( NULL, oblist ); - frame->arg[0] = input; + set_reg( frame, 0, input ); struct cons_pointer result = lisp_eval( frame, oblist ); if ( !exceptionp( result ) ) { @@ -63,8 +63,8 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer value ) { struct stack_frame *frame = make_empty_frame( NULL, oblist ); - frame->arg[0] = value; - frame->arg[1] = NIL /* stream_pointer */ ; + set_reg( frame, 0, value ); + set_reg( frame, 1, stream_pointer ); struct cons_pointer result = lisp_print( frame, oblist ); free_stack_frame( frame ); @@ -82,7 +82,10 @@ void repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, bool show_prompt ) { struct cons_pointer input_stream = make_read_stream( in_stream ); + pointer2cell( input_stream ).count = MAXREFERENCE; + struct cons_pointer output_stream = make_write_stream( out_stream ); + pointer2cell( output_stream ).count = MAXREFERENCE; while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { if ( show_prompt ) { @@ -90,21 +93,16 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, } struct cons_pointer input = repl_read( input_stream ); + inc_ref( input ); if ( exceptionp( input ) ) { + if ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { + repl_print( output_stream, input ); + } break; } else { - - struct cons_pointer val = repl_eval( input ); - - if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) { - /* suppress the 'end of stream' exception */ - if ( !exceptionp( val ) ) { - repl_print( output_stream, val ); - } - } else { - repl_print( output_stream, val ); - } + repl_print( output_stream, repl_eval( input ) ); } + dec_ref( input ); } } diff --git a/src/stack.c b/src/stack.c index 3554f22..1bb8b1b 100644 --- a/src/stack.c +++ b/src/stack.c @@ -49,7 +49,7 @@ struct stack_frame *make_empty_frame( struct stack_frame *previous, result->function = NIL; for ( int i = 0; i < args_in_frame; i++ ) { - result->arg[i] = NIL; + set_reg( result, i, NIL ); } return result; @@ -83,17 +83,15 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, * https://github.com/simon-brooke/post-scarcity/wiki/parallelism */ struct stack_frame *arg_frame = make_empty_frame( result, env ); - arg_frame->arg[0] = cell.payload.cons.car; - inc_ref( arg_frame->arg[0] ); + set_reg( arg_frame, 0, cell.payload.cons.car ); struct cons_pointer val = lisp_eval( arg_frame, env ); if ( exceptionp( val ) ) { exception = &val; break; } else { - result->arg[i] = val; + set_reg( result, i, val ); } - inc_ref( val ); free_stack_frame( arg_frame ); @@ -129,8 +127,7 @@ struct stack_frame *make_special_frame( struct stack_frame *previous, * stash them on more */ struct cons_space_object cell = pointer2cell( args ); - result->arg[i] = cell.payload.cons.car; - inc_ref( result->arg[i] ); + set_reg( result, i, cell.payload.cons.car ); args = cell.payload.cons.cdr; } diff --git a/src/stack.h b/src/stack.h index ebb1aa1..d708b39 100644 --- a/src/stack.h +++ b/src/stack.h @@ -24,6 +24,13 @@ #ifndef __stack_h #define __stack_h +/** + * 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) + + /** * Make an empty stack frame, and return it. * @param previous the current top-of-stack; From ea1d4ce7ed0812fb6692f1e4a97be6377063a7c8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 23 Dec 2018 19:23:00 +0000 Subject: [PATCH 03/22] Doesn't compile, but I have a mess. --- src/peano.c | 301 +++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 217 insertions(+), 84 deletions(-) diff --git a/src/peano.c b/src/peano.c index 691c95f..9d272df 100644 --- a/src/peano.c +++ b/src/peano.c @@ -25,35 +25,163 @@ #include "real.h" #include "stack.h" -/** - * Internal guts of add. Dark and mysterious. - */ -struct cons_pointer add_accumulate( struct cons_pointer arg, - struct stack_frame *frame, - long int *i_accumulator, - long double *d_accumulator, int *is_int ) { - struct cons_pointer result = NIL; +long double to_long_double( struct cons_pointer arg ); +long int to_long_int( struct stack_frame *frame, struct cons_pointer arg ); + + +bool zerop( struct cons_pointer arg ) { + bool result = false; struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: - ( *i_accumulator ) += cell.payload.integer.value; - ( *d_accumulator ) += numeric_value( arg ); + result = cell.payload.integer.value == 0; + break; + case RATIOTV: + result = zerop( cell.payload.ratio.dividend ); break; case REALTV: - ( *d_accumulator ) += cell.payload.real.value; - ( *is_int ) &= false; + result = ( cell.payload.real.value == 0 ); break; - case EXCEPTIONTV: - result = arg; + } + + return result; +} + +/** + * 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 ) { + long double result = NAN; /* not a number, as a long double */ + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case INTEGERTV: + result = cell.payload.integer.value * 1.0; + case RATIOTV: + { + struct cons_space_object dividend = + pointer2cell( cell.payload.ratio.dividend ); + struct cons_space_object divisor = + pointer2cell( cell.payload.ratio.divisor ); + + result = + dividend.payload.integer.value / + divisor.payload.integer.value; + } + break; + case REALTV: + result = cell.payload.real.value; + break; + } + + return result; +} + + +/** + * 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. + */ +long int to_long_int( struct stack_frame *frame, struct cons_pointer arg ) { + long int result = 0; + struct cons_space_object cell = pointer2cell( arg ); + switch ( cell.tag.value ) { + case INTEGERTV: + result = cell.payload.integer.value; + break; + case RATIOTV: + result = lroundl( to_long_double( arg ) ); + break; + case REALTV: + result = lroundl( cell.payload.real.value ); break; - default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), frame ); } return result; } +long int greatest_common_divisor( long int m, long int n ) { + int o; + while ( m ) { + o = m; + m = n % m; + n = o; + } + + return o; +} + +long int least_common_multiplier( long int m, long int n ) { + return m / greatest_common_divisor( m, n ) * n; +} + +/** +* 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 arg1, + struct cons_pointer arg2 ) { + struct cons_pointer result; + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + + if ( zerop( arg1 ) ) { + result = arg2; + } else if ( zerop( arg2 ) ) { + result = arg1; + } else { + + switch ( cell1.tag.value ) { + case EXCEPTIONTV: + result = cell1; + break; + case INTEGERTV: + switch ( cell2.tag.value ) { + case EXCEPTIONTV: + result = cell2; + break; + case INTEGERTV: + make_integer( cell1.payload.integer.value + + cell2.payload.integer.value ); + break; + case RATIOTV: + result = add_integer_ratio( arg1, arg2 ); + break; + case REALTV: + result = + make_real( cell1.payload.integer.value + + cell2.payload.real.value ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot add: not a number" ), + frame ); + } + break; + case RATIOTV: + switch ( cell2.tag.value ) { + case EXCEPTIONTV: + result = cell2; + break; + case INTEGERTV: + result = add_integer_ratio( arg1, arg2 ); + break; + case RATIOTV: + break; + case REALTV: + result = + make_real( cell2.payload.real.value + + ratio_to_long_double( arg1 ) ); + break; + } + } + } + + return result; +} /** * Add an indefinite number of numbers together @@ -61,48 +189,38 @@ struct cons_pointer add_accumulate( struct cons_pointer arg, * @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 env ) { +struct cons_pointer lisp_add( struct stack_frame + *frame, struct + cons_pointer env ) { struct cons_pointer result = NIL; - long int i_accumulator = 0; - long double d_accumulator = 0; - int is_int = true; - + struct cons_pointer result = make_integer( 0 ); for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { - result = - add_accumulate( frame->arg[i], frame, &i_accumulator, - &d_accumulator, &is_int ); + result = add_q( frame, result, frame->arg[i] ); } struct cons_pointer more = frame->more; - while ( consp( more ) ) { - result = - add_accumulate( c_car( more ), frame, &i_accumulator, - &d_accumulator, &is_int ); + result = add_2( frame, result, c _car( more ) ); more = c_cdr( more ); } - if ( is_int ) { - result = make_integer( i_accumulator ); - } else { - result = make_real( d_accumulator ); - } - return result; } /** * Internal guts of multiply. Dark and mysterious. */ -struct cons_pointer multiply_accumulate( struct cons_pointer arg, - struct stack_frame *frame, - long int *i_accumulator, - long double *d_accumulator, - int *is_int ) { +struct cons_pointer multiply_accumulate( struct + cons_pointer arg, struct + stack_frame + *frame, long + int + *i_accumulator, long + double + *d_accumulator, int + *is_int ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); - switch ( cell.tag.value ) { case INTEGERTV: ( *i_accumulator ) *= cell.payload.integer.value; @@ -116,8 +234,10 @@ struct cons_pointer multiply_accumulate( struct cons_pointer arg, result = arg; break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), frame ); + result = + lisp_throw + ( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), frame ); } return result; } @@ -128,27 +248,30 @@ struct cons_pointer multiply_accumulate( struct cons_pointer arg, * @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 env ) { +struct cons_pointer lisp_multiply( struct + stack_frame + *frame, struct + cons_pointer env ) { struct cons_pointer result = NIL; long int i_accumulator = 1; long double d_accumulator = 1; int is_int = true; - - for ( int i = 0; - i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); - i++ ) { + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) + && !exceptionp( result ); i++ ) { result = - multiply_accumulate( frame->arg[i], frame, &i_accumulator, - &d_accumulator, &is_int ); + multiply_accumulate( frame->arg[i], + frame, + &i_accumulator, &d_accumulator, &is_int ); } struct cons_pointer more = frame->more; - - while ( consp( more ) && !exceptionp( result ) ) { + while ( consp( more ) + && !exceptionp( result ) ) { result = - multiply_accumulate( c_car( more ), frame, &i_accumulator, - &d_accumulator, &is_int ); + multiply_accumulate( c_car + ( more ), + frame, + &i_accumulator, &d_accumulator, &is_int ); more = c_cdr( more ); } @@ -169,32 +292,37 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) { * @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 env ) { +struct cons_pointer lisp_subtract( struct + stack_frame + *frame, struct + cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); - - if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) { + if ( integerp( frame->arg[0] ) + && integerp( frame->arg[1] ) ) { result = - make_integer( arg0.payload.integer.value - - arg1.payload.integer.value ); - } else if ( realp( frame->arg[0] ) && realp( frame->arg[1] ) ) { + make_integer( arg0.payload.integer.value + - arg1.payload.integer.value ); + } else if ( realp( frame->arg[0] ) + && realp( frame->arg[1] ) ) { result = make_real( arg0.payload.real.value - arg1.payload.real.value ); - } else if ( integerp( frame->arg[0] ) && realp( frame->arg[1] ) ) { + } else if ( integerp( frame->arg[0] ) + && realp( frame->arg[1] ) ) { result = - make_real( numeric_value( frame->arg[0] ) - - arg1.payload.real.value ); - } else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) { + make_real( numeric_value + ( frame->arg[0] ) - arg1.payload.real.value ); + } else if ( realp( frame->arg[0] ) + && integerp( frame->arg[1] ) ) { result = make_real( arg0.payload.real.value - numeric_value( frame->arg[1] ) ); } else { /* TODO: throw an exception */ - lisp_throw( c_string_to_lisp_string - ( "Cannot subtract: not a number" ), frame ); + lisp_throw + ( c_string_to_lisp_string + ( "Cannot subtract: not a number" ), frame ); } // and if not nilp[frame->arg[2]) we also have an error. @@ -208,29 +336,34 @@ lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) { * @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 env ) { +struct cons_pointer lisp_divide( struct + stack_frame + *frame, struct + cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); - - if ( numberp( frame->arg[1] ) && numeric_value( frame->arg[1] ) == 0 ) { - lisp_throw( c_string_to_lisp_string - ( "Cannot divide: divisor is zero" ), frame ); - } else if ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) { - long int i = ( long int ) numeric_value( frame->arg[0] ) / - numeric_value( frame->arg[1] ); - long double r = ( long double ) numeric_value( frame->arg[0] ) / - numeric_value( frame->arg[1] ); + if ( numberp( frame->arg[1] ) + && numeric_value( frame->arg[1] ) == 0 ) { + lisp_throw + ( c_string_to_lisp_string + ( "Cannot divide: divisor is zero" ), frame ); + } else if ( numberp( frame->arg[0] ) + && numberp( frame->arg[1] ) ) { + long int i = ( long int ) + numeric_value( frame->arg[0] ) / numeric_value( frame->arg[1] ); + long double r = ( long double ) + numeric_value( frame->arg[0] ) + / numeric_value( frame->arg[1] ); if ( fabsl( ( long double ) i - r ) < 0.0000000001 ) { result = make_integer( i ); } else { result = make_real( r ); } } else { - lisp_throw( c_string_to_lisp_string - ( "Cannot divide: not a number" ), frame ); + lisp_throw + ( c_string_to_lisp_string + ( "Cannot divide: not a number" ), frame ); } return result; From 4c9fdfc3dbaa0936fccc3386524f838fb1b8f694 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 23 Dec 2018 20:02:00 +0000 Subject: [PATCH 04/22] Added ratio numbers (but some arithmetic is now broken) --- src/conspage.c | 4 ++ src/consspaceobject.c | 25 +++++++++++ src/consspaceobject.h | 36 ++++++++++++++- src/equal.c | 4 +- src/lispops.c | 6 +-- src/peano.c | 72 +++++++++++++++++++++++++----- src/print.c | 15 ++++--- src/read.c | 35 ++++++++++++--- src/repl.c | 1 + utils_src/tagvalcalc/tagvalcalc.c | 9 ++++ utils_src/tagvalcalc/tvc | Bin 0 -> 8432 bytes 11 files changed, 176 insertions(+), 31 deletions(-) create mode 100644 utils_src/tagvalcalc/tagvalcalc.c create mode 100755 utils_src/tagvalcalc/tvc diff --git a/src/conspage.c b/src/conspage.c index ad83680..0e6532f 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -145,6 +145,10 @@ void free_cell( struct cons_pointer pointer ) { 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; diff --git a/src/consspaceobject.c b/src/consspaceobject.c index ef96c1f..38a2934 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -239,6 +239,31 @@ struct cons_pointer make_nlambda( struct cons_pointer args, return pointer; } +/** + * Construct a ratio frame from these two pointers, expected to be integers + * or (later) bignums, in the context of this stack_frame. + */ +struct cons_pointer make_ratio( struct stack_frame *frame, + struct cons_pointer dividend, + struct cons_pointer divisor ) { + struct cons_pointer result; + if ( integerp( dividend ) && integerp( divisor ) ) { + inc_ref( dividend ); + inc_ref( divisor ); + result = allocate_cell( RATIOTAG ); + struct cons_space_object *cell = &pointer2cell( result ); + cell->payload.ratio.dividend = dividend; + cell->payload.ratio.divisor = divisor; + } else { + result = + make_exception( c_string_to_lisp_string + ( "Dividend and divisor of a ratio must be integers" ), + frame ); + } + + 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 diff --git a/src/consspaceobject.h b/src/consspaceobject.h index ed5cbd1..de4d635 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -91,6 +91,12 @@ #define REALTAG "REAL" #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 @@ -197,6 +203,11 @@ */ #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) +/** + * true if conspointer 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 */ @@ -317,10 +328,19 @@ struct lambda_payload { struct cons_pointer body; }; +/** + * payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells. + */ +struct ratio_payload { + struct cons_pointer dividend; + struct cons_pointer divisor; +}; + /** * payload for a real number cell. Internals of this liable to change to give 128 bits * precision, but I'm not sure of the detail. - */ struct real_payload { + */ +struct real_payload { long double value; }; @@ -418,6 +438,10 @@ struct cons_space_object { * 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 */ @@ -496,7 +520,15 @@ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ); - /** +/** + * Construct a ratio frame from these two pointers, expected to be integers + * or (later) bignums, in the context of this stack_frame. + */ +struct cons_pointer make_ratio( struct stack_frame *frame, + struct cons_pointer dividend, + struct cons_pointer divisor ); + +/** * Construct a cell which points to an executable Lisp special form. */ struct cons_pointer make_special( struct cons_pointer src, diff --git a/src/equal.c b/src/equal.c index 0f0597c..ebb085e 100644 --- a/src/equal.c +++ b/src/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/lispops.c b/src/lispops.c index f29c658..371779c 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -659,9 +659,9 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) { result = print( output, frame->arg[0] ); - fputws( L"Print returning ", stderr); - print(stderr, result); - fputws( L"\n", stderr); + fputws( L"Print returning ", stderr ); + print( stderr, result ); + fputws( L"\n", stderr ); return result; } diff --git a/src/peano.c b/src/peano.c index 9d272df..7fffcb0 100644 --- a/src/peano.c +++ b/src/peano.c @@ -27,6 +27,8 @@ long double to_long_double( struct cons_pointer arg ); long int to_long_int( struct stack_frame *frame, struct cons_pointer arg ); +struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, + struct cons_pointer arg2 ); bool zerop( struct cons_pointer arg ) { @@ -118,6 +120,52 @@ long int least_common_multiplier( long int m, long int n ) { return m / greatest_common_divisor( m, n ) * n; } +/** + * 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. +*/ +struct cons_pointer add_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer result; + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + long int dd1v = pointer2cell(cell1.payload.ratio.dividend).payload.integer.value, + dd2v = pointer2cell(cell2.payload.ratio.dividend).payload.integer.value, + dr1v = pointer2cell(cell1.payload.ratio.divisor).payload.integer.value, + dr2v = pointer2cell(cell2.payload.ratio.divisor).payload.integer.value, + lcm = least_common_multiplier(dr1v, dr2v), + m1 = lcm/dr2v, + m2 = lcm/dr1v; + + if (dr1v == dr2v) { + result = make_ratio( frame, add_2(frame, cell1.payload.ratio.dividend, cell2.payload.ratio.dividend), + cell1.payload.ratio.divisor); + } else { + result = make_ratio( frame, + make_integer((dd1v * m1) + (dd2v * m2)), + make_integer((dr1v * m1) + (dr2v * m2))); + } + + return result; +} + + +/** + * 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. +*/ +struct cons_pointer add_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) { + return add_ratio_ratio( frame, + make_ratio( frame, intarg, make_integer( 1)), + ratarg); +} + + /** * return a cons_pointer indicating a number which is the sum of * the numbers indicated by `arg1` and `arg2`. @@ -136,23 +184,23 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, switch ( cell1.tag.value ) { case EXCEPTIONTV: - result = cell1; + result = arg1; break; case INTEGERTV: switch ( cell2.tag.value ) { case EXCEPTIONTV: - result = cell2; + result = arg2; break; case INTEGERTV: make_integer( cell1.payload.integer.value + cell2.payload.integer.value ); break; case RATIOTV: - result = add_integer_ratio( arg1, arg2 ); + result = add_integer_ratio( frame, arg1, arg2 ); break; case REALTV: result = - make_real( cell1.payload.integer.value + + make_real( to_long_double(arg1) + cell2.payload.real.value ); break; default: @@ -164,17 +212,18 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, case RATIOTV: switch ( cell2.tag.value ) { case EXCEPTIONTV: - result = cell2; + result = arg2; break; case INTEGERTV: - result = add_integer_ratio( arg1, arg2 ); + result = add_integer_ratio( frame, arg2, arg1 ); break; case RATIOTV: + result = add_ratio_ratio( frame, arg1, arg2); break; case REALTV: result = make_real( cell2.payload.real.value + - ratio_to_long_double( arg1 ) ); + to_long_double( arg1 ) ); break; } } @@ -192,15 +241,14 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer lisp_add( struct stack_frame *frame, struct cons_pointer env ) { - struct cons_pointer result = NIL; struct cons_pointer result = make_integer( 0 ); - for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { - result = add_q( frame, result, frame->arg[i] ); + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i]) && !exceptionp(result); i++ ) { + result = add_2( frame, result, frame->arg[i] ); } struct cons_pointer more = frame->more; - while ( consp( more ) ) { - result = add_2( frame, result, c _car( more ) ); + while ( consp( more ) && !exceptionp(result) ) { + result = add_2( frame, result, c_car( more ) ); more = c_cdr( more ); } diff --git a/src/print.c b/src/print.c index 0ab42b2..6101c37 100644 --- a/src/print.c +++ b/src/print.c @@ -132,8 +132,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case LAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); + cell.payload. + lambda.body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); @@ -141,8 +141,13 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case NLAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ), make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); + cell.payload. + lambda.body ) ) ); + break; + case RATIOTV: + print( output, cell.payload.ratio.dividend ); + fputws( L"/", output ); + print( output, cell.payload.ratio.divisor ); break; case READTV: fwprintf( output, L"(Input stream)" ); @@ -197,5 +202,5 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { fputws( L"\x1B[39m", output ); } - return pointer; + return pointer; } diff --git a/src/read.c b/src/read.c index 3bee19f..458c3f8 100644 --- a/src/read.c +++ b/src/read.c @@ -31,7 +31,8 @@ * atoms because I don't yet know what an atom is or how it's stored. */ -struct cons_pointer read_number( FILE * input, wint_t initial ); +struct cons_pointer read_number( struct stack_frame *frame, FILE * input, + wint_t initial, bool seen_period ); struct cons_pointer read_list( struct stack_frame *frame, FILE * input, wint_t initial ); struct cons_pointer read_string( FILE * input, wint_t initial ); @@ -89,7 +90,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, wint_t next = fgetwc( input ); if ( iswdigit( next ) ) { ungetwc( next, input ); - result = read_number( input, c ); + result = read_number( frame, input, c, true ); } else if ( iswblank( next ) ) { /* dotted pair. TODO: this isn't right, we * really need to backtrack up a level. */ @@ -102,7 +103,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, break; default: if ( iswdigit( c ) ) { - result = read_number( input, c ); + result = read_number( frame, input, c, false ); } else if ( iswprint( c ) ) { result = read_symbol( input, c ); } else { @@ -120,17 +121,33 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, /** * read a number from this input stream, given this initial character. */ -struct cons_pointer read_number( FILE * input, wint_t initial ) { +struct cons_pointer read_number( struct stack_frame *frame, FILE * input, + wint_t initial, bool seen_period ) { struct cons_pointer result = NIL; long int accumulator = 0; + long int dividend = 0; int places_of_decimals = 0; - bool seen_period = false; wint_t c; fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); for ( c = initial; iswdigit( c ) - || c == btowc( '.' ); c = fgetwc( input ) ) { + || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { - seen_period = true; + if ( seen_period || dividend > 0 ) { + return make_exception( c_string_to_lisp_string + ( "Malformed number: too many periods" ), + frame ); + } else { + seen_period = true; + } + } else if ( c == btowc( '/' ) ) { + if ( seen_period || dividend > 0 ) { + return make_exception( c_string_to_lisp_string + ( "Malformed number: dividend must be integer" ), + frame ); + } else { + dividend = accumulator; + accumulator = 0; + } } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); fwprintf( stderr, @@ -151,6 +168,10 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { ( accumulator / pow( 10, places_of_decimals ) ); fwprintf( stderr, L"read_numer returning %Lf\n", rv ); result = make_real( rv ); + } else if ( dividend > 0 ) { + result = + make_ratio( frame, make_integer( dividend ), + make_integer( accumulator ) ); } else { result = make_integer( accumulator ); } diff --git a/src/repl.c b/src/repl.c index 2ebf79d..f9ca5d5 100644 --- a/src/repl.c +++ b/src/repl.c @@ -96,6 +96,7 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_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 ); } diff --git a/utils_src/tagvalcalc/tagvalcalc.c b/utils_src/tagvalcalc/tagvalcalc.c new file mode 100644 index 0000000..1159187 --- /dev/null +++ b/utils_src/tagvalcalc/tagvalcalc.c @@ -0,0 +1,9 @@ +#include +#include + +int main( int argc, char *argv[] ) { + + for (int i = 1; i < argc; i++) { + printf( "%4.4s:\t%u\n", argv[i], (uint32_t)*argv[i]); + } +} diff --git a/utils_src/tagvalcalc/tvc b/utils_src/tagvalcalc/tvc new file mode 100755 index 0000000000000000000000000000000000000000..8fb6cb3375ac08fe1a467f984717cdc492714ca7 GIT binary patch literal 8432 zcmeHMO-NKx7`@|9S&8%9ME|_3k#eCH24MsmJ{rkN(;$MnIXdRR%qa6iN(qv+7zV>d zn>MXm1hp$%h)|%rwn5tpg$Z0rNz*y+-8b{*+0Qz-AAElI-0!<*?mhQCxW4=0`?sGv zg$Ps&F0q);cpRnKB7>{A?wCaWr;oB zsO%F8V{W2WIV+^hM5i)rIp*gxumJMKRh}5jDO-)0Ed%nUGucSG)aB=Up!jyE3KzQr z>J*=wclhLZG(H(kp~%noNbwy|1jN+6WZUL9lFp=J$-An+&-YyM?NNDRuT^j(A!Rms zFP0pYvESruBP@W6sGdP{jL=&wS zS~0I!1VylBIQj3Gj-DqKre4~#0$KsBfL1^&pcT*xXa%$a|5D(3IQJzyS1?zsEtckH zHp98>#)?(op*C+7&RLtm`A)RM^XG3fB(}SSz3v&Q+)*23HdyMqDeCXnA3_S)F_Zb8iN h8HlA%566Ajp+%<KX*Y0tr(@3s|T+%L!g*Gm8Z literal 0 HcmV?d00001 From 813b24406de2e7ec0c178fc9cd50e780396e771a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 23 Dec 2018 20:54:57 +0000 Subject: [PATCH 05/22] Ratio addition now works --- src/equal.c | 4 +- src/peano.c | 81 ++++++++++++++++++++++++------------ src/print.c | 8 ++-- unit-tests/ratio-addition.sh | 12 ++++++ 4 files changed, 72 insertions(+), 33 deletions(-) create mode 100644 unit-tests/ratio-addition.sh diff --git a/src/equal.c b/src/equal.c index ebb085e..0f0597c 100644 --- a/src/equal.c +++ b/src/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/peano.c b/src/peano.c index 7fffcb0..96ca18b 100644 --- a/src/peano.c +++ b/src/peano.c @@ -116,7 +116,7 @@ long int greatest_common_divisor( long int m, long int n ) { return o; } -long int least_common_multiplier( long int m, long int n ) { +long int least_common_multiple( long int m, long int n ) { return m / greatest_common_divisor( m, n ) * n; } @@ -126,27 +126,52 @@ long int least_common_multiplier( long int m, long int n ) { * this is going to break horribly. */ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, - struct cons_pointer arg1, - struct cons_pointer arg2 ) { + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + fputws( L"add_ratio_ratio: srg1 = ", stderr ); + print( stderr, arg1 ); + fputws( L"; srg2 = ", stderr ); + print( stderr, arg2 ); + struct cons_pointer result; struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); - long int dd1v = pointer2cell(cell1.payload.ratio.dividend).payload.integer.value, - dd2v = pointer2cell(cell2.payload.ratio.dividend).payload.integer.value, - dr1v = pointer2cell(cell1.payload.ratio.divisor).payload.integer.value, - dr2v = pointer2cell(cell2.payload.ratio.divisor).payload.integer.value, - lcm = least_common_multiplier(dr1v, dr2v), - m1 = lcm/dr2v, - m2 = lcm/dr1v; + long int dd1v = + pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, + dd2v = + pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, + dr1v = + pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, + dr2v = + pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, + lcm = least_common_multiple( dr1v, dr2v ), + m1 = lcm / dr1v, + m2 = lcm / dr2v; - if (dr1v == dr2v) { - result = make_ratio( frame, add_2(frame, cell1.payload.ratio.dividend, cell2.payload.ratio.dividend), - cell1.payload.ratio.divisor); - } else { - result = make_ratio( frame, - make_integer((dd1v * m1) + (dd2v * m2)), - make_integer((dr1v * m1) + (dr2v * m2))); - } + fwprintf(stderr , L"; lcm = %ld; m1 = %ld; m2 = %ld\n", lcm, m1, m2); + + if ( dr1v == dr2v ) { + result = + make_ratio( frame, + make_integer( dd1v + dd2v ), + cell1.payload.ratio.divisor ); + + long int ddrv = pointer2cell(pointer2cell(result).payload.ratio.dividend).payload.integer.value, + drrv = pointer2cell(pointer2cell(result).payload.ratio.divisor).payload.integer.value, + gcd = greatest_common_divisor(ddrv, drrv); + + if (gcd > 1) { + result = make_ratio( frame, make_integer(ddrv/gcd),make_integer(drrv/gcd)); + } + } else { + result = add_ratio_ratio( frame, + make_ratio( frame, + make_integer( dd1v * m1 ), + make_integer( dr1v * m1 )), + make_ratio( frame, + make_integer( dd2v * m2 ), + make_integer( dr2v * m2 ) )); + } return result; } @@ -158,11 +183,11 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, * this is going to break horribly. */ struct cons_pointer add_integer_ratio( struct stack_frame *frame, - struct cons_pointer intarg, - struct cons_pointer ratarg ) { - return add_ratio_ratio( frame, - make_ratio( frame, intarg, make_integer( 1)), - ratarg); + struct cons_pointer intarg, + struct cons_pointer ratarg ) { + return add_ratio_ratio( frame, + make_ratio( frame, intarg, make_integer( 1 ) ), + ratarg ); } @@ -200,7 +225,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, break; case REALTV: result = - make_real( to_long_double(arg1) + + make_real( to_long_double( arg1 ) + cell2.payload.real.value ); break; default: @@ -218,7 +243,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, result = add_integer_ratio( frame, arg2, arg1 ); break; case RATIOTV: - result = add_ratio_ratio( frame, arg1, arg2); + result = add_ratio_ratio( frame, arg1, arg2 ); break; case REALTV: result = @@ -242,12 +267,14 @@ struct cons_pointer lisp_add( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = make_integer( 0 ); - for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i]) && !exceptionp(result); i++ ) { + for ( int i = 0; + i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); + i++ ) { result = add_2( frame, result, frame->arg[i] ); } struct cons_pointer more = frame->more; - while ( consp( more ) && !exceptionp(result) ) { + while ( consp( more ) && !exceptionp( result ) ) { result = add_2( frame, result, c_car( more ) ); more = c_cdr( more ); } diff --git a/src/print.c b/src/print.c index 6101c37..50e6f41 100644 --- a/src/print.c +++ b/src/print.c @@ -132,8 +132,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case LAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body ) ) ); + cell.payload.lambda. + body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); @@ -141,8 +141,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case NLAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "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/unit-tests/ratio-addition.sh b/unit-tests/ratio-addition.sh new file mode 100644 index 0000000..f57d0b0 --- /dev/null +++ b/unit-tests/ratio-addition.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +expected='1/4' +actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From d725097f89919ad37231dee9921f1c27f84b6dc6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 23 Dec 2018 21:45:24 +0000 Subject: [PATCH 06/22] Ratio addition working perfectly; all tests pass. --- src/peano.c | 95 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 67 insertions(+), 28 deletions(-) diff --git a/src/peano.c b/src/peano.c index 96ca18b..e9ef08f 100644 --- a/src/peano.c +++ b/src/peano.c @@ -56,12 +56,13 @@ bool zerop( struct cons_pointer arg ) { * not a number is passed in. */ long double to_long_double( struct cons_pointer arg ) { - long double result = NAN; /* not a number, as a long double */ + long double result = 0; /* not a number, as a long double */ struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: - result = cell.payload.integer.value * 1.0; + result = ( double ) cell.payload.integer.value; + break; case RATIOTV: { struct cons_space_object dividend = @@ -70,15 +71,22 @@ long double to_long_double( struct cons_pointer arg ) { pointer2cell( cell.payload.ratio.divisor ); result = - dividend.payload.integer.value / + ( long double ) dividend.payload.integer.value / divisor.payload.integer.value; } break; case REALTV: result = cell.payload.real.value; break; + default: + result = NAN; + break; } + fputws( L"to_long_double( ", stderr ); + print( stderr, arg ); + fwprintf( stderr, L") => %lf\n", result ); + return result; } @@ -128,9 +136,9 @@ long int least_common_multiple( long int m, long int n ) { struct cons_pointer add_ratio_ratio( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer arg2 ) { - fputws( L"add_ratio_ratio: srg1 = ", stderr ); + fputws( L"add_ratio_ratio( arg1 = ", stderr ); print( stderr, arg1 ); - fputws( L"; srg2 = ", stderr ); + fputws( L"; arg2 = ", stderr ); print( stderr, arg2 ); struct cons_pointer result; @@ -145,10 +153,9 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, dr2v = pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, lcm = least_common_multiple( dr1v, dr2v ), - m1 = lcm / dr1v, - m2 = lcm / dr2v; + m1 = lcm / dr1v, m2 = lcm / dr2v; - fwprintf(stderr , L"; lcm = %ld; m1 = %ld; m2 = %ld\n", lcm, m1, m2); + fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); if ( dr1v == dr2v ) { result = @@ -156,22 +163,35 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, make_integer( dd1v + dd2v ), cell1.payload.ratio.divisor ); - long int ddrv = pointer2cell(pointer2cell(result).payload.ratio.dividend).payload.integer.value, - drrv = pointer2cell(pointer2cell(result).payload.ratio.divisor).payload.integer.value, - gcd = greatest_common_divisor(ddrv, drrv); + long int ddrv = + pointer2cell( pointer2cell( result ).payload.ratio. + dividend ).payload.integer.value, drrv = + pointer2cell( pointer2cell( result ).payload.ratio. + divisor ).payload.integer.value, gcd = + greatest_common_divisor( ddrv, drrv ); - if (gcd > 1) { - result = make_ratio( frame, make_integer(ddrv/gcd),make_integer(drrv/gcd)); - } + if ( gcd > 1 ) { + if ( drrv / gcd == 1 ) { + result = make_integer( ddrv / gcd ); + } else { + result = + make_ratio( frame, make_integer( ddrv / gcd ), + make_integer( drrv / gcd ) ); + } + } } else { result = add_ratio_ratio( frame, - make_ratio( frame, - make_integer( dd1v * m1 ), - make_integer( dr1v * m1 )), - make_ratio( frame, - make_integer( dd2v * m2 ), - make_integer( dr2v * m2 ) )); - } + make_ratio( frame, + make_integer( dd1v * m1 ), + make_integer( dr1v * m1 ) ), + make_ratio( frame, + make_integer( dd2v * m2 ), + make_integer( dr2v * m2 ) ) ); + } + + fputws( L" => ", stderr ); + print( stderr, result ); + fputws( L"\n", stderr ); return result; } @@ -201,6 +221,11 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); + fputws( L"add_2( arg1 = ", stderr ); + print( stderr, arg1 ); + fputws( L"; arg2 = ", stderr ); + print( stderr, arg2 ); + if ( zerop( arg1 ) ) { result = arg2; } else if ( zerop( arg2 ) ) { @@ -217,8 +242,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, result = arg2; break; case INTEGERTV: - make_integer( cell1.payload.integer.value + - cell2.payload.integer.value ); + result = make_integer( cell1.payload.integer.value + + cell2.payload.integer.value ); break; case RATIOTV: result = add_integer_ratio( frame, arg1, arg2 ); @@ -226,7 +251,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, case REALTV: result = make_real( to_long_double( arg1 ) + - cell2.payload.real.value ); + to_long_double( arg2 ) ); break; default: result = lisp_throw( c_string_to_lisp_string @@ -247,13 +272,27 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, break; case REALTV: result = - make_real( cell2.payload.real.value + - to_long_double( arg1 ) ); + make_real( to_long_double( arg1 ) + + to_long_double( arg2 ) ); break; } + break; + case REALTV: + result = + make_real( to_long_double( arg1 ) + + to_long_double( arg2 ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot add: not a number" ), frame ); } } + fputws( L"}; => ", stderr ); + print( stderr, arg2 ); + fputws( L"\n", stderr ); + + return result; } @@ -268,8 +307,8 @@ struct cons_pointer lisp_add( struct stack_frame cons_pointer env ) { struct cons_pointer result = make_integer( 0 ); for ( int i = 0; - i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); - i++ ) { + i < args_in_frame && + !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { result = add_2( frame, result, frame->arg[i] ); } From 7e98207f7ef126cc9c97efe399728e2d57cd26fe Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 24 Dec 2018 10:28:10 +0000 Subject: [PATCH 07/22] Ratio multiplication and subtraction --- src/conspage.c | 9 +- src/consspaceobject.c | 8 + src/peano.c | 437 +++++++++++++++++++++++++++++++----------- 3 files changed, 342 insertions(+), 112 deletions(-) diff --git a/src/conspage.c b/src/conspage.c index 0e6532f..33e9828 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -127,6 +127,9 @@ void dump_pages( FILE * output ) { void free_cell( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); + fwprintf( stderr, L"Freeing cell " ); + dump_object( stderr, pointer ); + switch ( cell->tag.value ) { /* for all the types of cons-space object which point to other * cons-space objects, cascade the decrement. */ @@ -160,20 +163,18 @@ void free_cell( struct cons_pointer pointer ) { if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { - fwprintf( stderr, L"Freeing cell " ); - dump_object( stderr, pointer ); strncpy( &cell->tag.bytes[0], FREETAG, 4 ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; } else { fwprintf( stderr, - L"Attempt to free cell with %d dangling references at page %d, offset %d\n", + L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", cell->count, pointer.page, pointer.offset ); } } else { fwprintf( stderr, - L"Attempt to free cell which is already FREE at page %d, offset %d\n", + L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", pointer.page, pointer.offset ); } } diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 38a2934..d927470 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -133,6 +133,14 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); 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 ); + break; case READTV: fwprintf( output, L"\t\tInput stream\n" ); case REALTV: diff --git a/src/peano.c b/src/peano.c index e9ef08f..3b6df53 100644 --- a/src/peano.c +++ b/src/peano.c @@ -26,7 +26,7 @@ #include "stack.h" long double to_long_double( struct cons_pointer arg ); -long int to_long_int( struct stack_frame *frame, struct cons_pointer arg ); +long int to_long_int( struct cons_pointer arg ); struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer arg2 ); @@ -96,7 +96,7 @@ long double to_long_double( struct cons_pointer arg ) { * 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. */ -long int to_long_int( struct stack_frame *frame, struct cons_pointer arg ) { +long int to_long_int( struct cons_pointer arg ) { long int result = 0; struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { @@ -128,6 +128,28 @@ long int least_common_multiple( long int m, long int n ) { return m / greatest_common_divisor( m, n ) * n; } +struct cons_pointer simplify_ratio( struct stack_frame *frame, + struct cons_pointer arg ) { + struct cons_pointer result = arg; + long int 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 ( gcd > 1 ) { + if ( drrv / gcd == 1 ) { + result = make_integer( ddrv / gcd ); + } else { + result = + make_ratio( frame, make_integer( ddrv / gcd ), + make_integer( drrv / gcd ) ); + } + } + return result; +} + + /** * return a cons_pointer indicating a number which is the sum of * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, @@ -141,7 +163,7 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, fputws( L"; arg2 = ", stderr ); print( stderr, arg2 ); - struct cons_pointer result; + struct cons_pointer r1, result; struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); long int dd1v = @@ -158,35 +180,22 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); if ( dr1v == dr2v ) { - result = - make_ratio( frame, - make_integer( dd1v + dd2v ), - cell1.payload.ratio.divisor ); - - long int ddrv = - pointer2cell( pointer2cell( result ).payload.ratio. - dividend ).payload.integer.value, drrv = - pointer2cell( pointer2cell( result ).payload.ratio. - divisor ).payload.integer.value, gcd = - greatest_common_divisor( ddrv, drrv ); - - if ( gcd > 1 ) { - if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd ); - } else { - result = - make_ratio( frame, make_integer( ddrv / gcd ), - make_integer( drrv / gcd ) ); - } - } + r1 = make_ratio( frame, + make_integer( dd1v + dd2v ), + cell1.payload.ratio.divisor ); } else { - result = add_ratio_ratio( frame, - make_ratio( frame, - make_integer( dd1v * m1 ), - make_integer( dr1v * m1 ) ), - make_ratio( frame, - make_integer( dd2v * m2 ), - make_integer( dr2v * m2 ) ) ); + r1 = add_ratio_ratio( frame, + make_ratio( frame, + make_integer( dd1v * m1 ), + make_integer( dr1v * m1 ) ), + make_ratio( frame, + make_integer( dd2v * m2 ), + make_integer( dr2v * m2 ) ) ); + } + + result = simplify_ratio( frame, r1 ); + if ( !eq( r1, result ) ) { + dec_ref( r1 ); } fputws( L" => ", stderr ); @@ -257,6 +266,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, result = lisp_throw( c_string_to_lisp_string ( "Cannot add: not a number" ), frame ); + break; } break; case RATIOTV: @@ -275,6 +285,11 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, make_real( to_long_double( arg1 ) + to_long_double( arg2 ) ); break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot add: not a number" ), + frame ); + break; } break; case REALTV: @@ -292,7 +307,6 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, print( stderr, arg2 ); fputws( L"\n", stderr ); - return result; } @@ -306,56 +320,173 @@ struct cons_pointer lisp_add( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = make_integer( 0 ); + struct cons_pointer tmp; + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { + tmp = result; result = add_2( frame, result, frame->arg[i] ); + if ( !eq( tmp, result ) ) { + dec_ref( tmp ); + } } struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { + tmp = result; result = add_2( frame, result, c_car( more ) ); + if ( !eq( tmp, result ) ) { + dec_ref( tmp ); + } + more = c_cdr( more ); } return result; } -/** - * Internal guts of multiply. Dark and mysterious. - */ -struct cons_pointer multiply_accumulate( struct - cons_pointer arg, struct - stack_frame - *frame, long - int - *i_accumulator, long - double - *d_accumulator, int - *is_int ) { - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( arg ); - switch ( cell.tag.value ) { - case INTEGERTV: - ( *i_accumulator ) *= cell.payload.integer.value; - ( *d_accumulator ) *= numeric_value( arg ); - break; - case REALTV: - ( *d_accumulator ) *= cell.payload.real.value; - ( *is_int ) &= false; - break; - case EXCEPTIONTV: - result = arg; - break; - default: - result = - lisp_throw - ( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), frame ); +struct cons_pointer multiply_ratio_ratio( struct + stack_frame + *frame, struct + cons_pointer arg1, struct + cons_pointer arg2 ) { + fputws( L"multiply_ratio_ratio( arg1 = ", stderr ); + print( stderr, arg1 ); + fputws( L"; arg2 = ", stderr ); + print( stderr, arg2 ); + + struct cons_pointer result; + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + long int dd1v = + pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, + dd2v = + pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, + dr1v = + pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, + dr2v = + pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, + ddrv = dd1v * dd2v, drrv = dr1v * dr2v; + + struct cons_pointer unsimplified = make_ratio( frame, make_integer( ddrv ), + make_integer( drrv ) ); + result = simplify_ratio( frame, unsimplified ); + + if ( !eq( unsimplified, result ) ) { + dec_ref( unsimplified ); } + return result; } +/** + * 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. +*/ +struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) { + return multiply_ratio_ratio( frame, + make_ratio( frame, intarg, + make_integer( 1 ) ), ratarg ); +} + + +/** +* 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 arg1, + struct cons_pointer arg2 ) { + struct cons_pointer result; + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + + fputws( L"multiply_2( arg1 = ", stderr ); + print( stderr, arg1 ); + fputws( L"; arg2 = ", stderr ); + print( stderr, arg2 ); + + if ( zerop( arg1 ) ) { + result = arg2; + } else if ( zerop( arg2 ) ) { + result = arg1; + } else { + + switch ( cell1.tag.value ) { + case EXCEPTIONTV: + result = arg1; + break; + case INTEGERTV: + switch ( cell2.tag.value ) { + case EXCEPTIONTV: + result = arg2; + break; + case INTEGERTV: + result = make_integer( cell1.payload.integer.value * + cell2.payload.integer.value ); + break; + case RATIOTV: + result = multiply_integer_ratio( frame, arg1, arg2 ); + break; + case REALTV: + result = + make_real( to_long_double( arg1 ) * + to_long_double( arg2 ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), + frame ); + break; + } + break; + case RATIOTV: + switch ( cell2.tag.value ) { + case EXCEPTIONTV: + result = arg2; + break; + case INTEGERTV: + result = multiply_integer_ratio( frame, arg2, arg1 ); + break; + case RATIOTV: + result = multiply_ratio_ratio( frame, arg1, arg2 ); + break; + case REALTV: + result = + make_real( to_long_double( arg1 ) * + to_long_double( arg2 ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), + frame ); + } + break; + case REALTV: + result = + make_real( to_long_double( arg1 ) * + to_long_double( arg2 ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), + frame ); + break; + } + } + + fputws( L"}; => ", stderr ); + print( stderr, arg2 ); + fputws( L"\n", stderr ); + + return result; +} + + /** * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; @@ -366,40 +497,79 @@ struct cons_pointer lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) { - struct cons_pointer result = NIL; - long int i_accumulator = 1; - long double d_accumulator = 1; - int is_int = true; + struct cons_pointer result = make_integer( 1 ); + struct cons_pointer tmp; + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { - result = - multiply_accumulate( frame->arg[i], - frame, - &i_accumulator, &d_accumulator, &is_int ); + tmp = result; + result = multiply_2( frame, result, frame->arg[i] ); + + if ( !eq( tmp, result ) ) { + dec_ref( tmp ); + } } struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { - result = - multiply_accumulate( c_car - ( more ), - frame, - &i_accumulator, &d_accumulator, &is_int ); + tmp = result; + result = multiply_2( frame, result, c_car( more ) ); + if ( !eq( tmp, result ) ) { + dec_ref( tmp ); + } + more = c_cdr( more ); } - if ( !exceptionp( result ) ) { - if ( is_int ) { - result = make_integer( i_accumulator ); - } else { - result = make_real( d_accumulator ); - } + return result; +} + +struct cons_pointer inverse( struct stack_frame *frame, + struct cons_pointer arg ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case EXCEPTIONTV: + result = arg; + break; + case INTEGERTV: + result = make_integer( 0 - to_long_int( arg ) ); + break; + case NILTV: + result = TRUE; + break; + case RATIOTV: + result = make_ratio( frame, + make_integer( 0 - + to_long_int( cell.payload. + ratio.dividend ) ), + cell.payload.ratio.divisor ); + break; + case REALTV: + result = make_real( 0 - to_long_double( arg ) ); + break; + case TRUETV: + result = NIL; + break; } return result; } + +struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer i = inverse( frame, arg2 ), + result = add_ratio_ratio( frame, arg1, i ); + + dec_ref( i ); + + return result; +} + /** * Subtract one number from another. * @param env the evaluation environment - ignored; @@ -411,32 +581,83 @@ struct cons_pointer lisp_subtract( struct *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); - struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); - if ( integerp( frame->arg[0] ) - && integerp( frame->arg[1] ) ) { - result = - make_integer( arg0.payload.integer.value - - arg1.payload.integer.value ); - } else if ( realp( frame->arg[0] ) - && realp( frame->arg[1] ) ) { - result = - make_real( arg0.payload.real.value - arg1.payload.real.value ); - } else if ( integerp( frame->arg[0] ) - && realp( frame->arg[1] ) ) { - result = - make_real( numeric_value - ( frame->arg[0] ) - arg1.payload.real.value ); - } else if ( realp( frame->arg[0] ) - && integerp( frame->arg[1] ) ) { - result = - make_real( arg0.payload.real.value - - numeric_value( frame->arg[1] ) ); - } else { - /* TODO: throw an exception */ - lisp_throw - ( c_string_to_lisp_string - ( "Cannot subtract: not a number" ), frame ); + struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); + struct cons_space_object cell1 = pointer2cell( frame->arg[1] ); + + switch ( cell0.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[0]; + break; + case INTEGERTV: + switch ( cell1.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[1]; + break; + case INTEGERTV: + result = make_integer( cell0.payload.integer.value + - cell1.payload.integer.value ); + break; + case RATIOTV:{ + struct cons_pointer tmp = + make_ratio( frame, frame->arg[0], + make_integer( 1 ) ); + result = + subtract_ratio_ratio( frame, tmp, frame->arg[1] ); + dec_ref( tmp ); + } + break; + case REALTV: + result = + make_real( to_long_double( frame->arg[0] ) - + to_long_double( frame->arg[1] ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), + frame ); + break; + } + break; + case RATIOTV: + switch ( cell1.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[1]; + break; + case INTEGERTV:{ + struct cons_pointer tmp = + make_ratio( frame, frame->arg[1], + make_integer( 1 ) ); + result = + subtract_ratio_ratio( frame, frame->arg[0], tmp ); + dec_ref( tmp ); + } + break; + case RATIOTV: + result = + subtract_ratio_ratio( frame, frame->arg[0], + frame->arg[1] ); + break; + case REALTV: + result = + make_real( to_long_double( frame->arg[0] ) - + to_long_double( frame->arg[1] ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), + frame ); + break; + } + break; + case REALTV: + result = + make_real( to_long_double( frame->arg[0] ) - + to_long_double( frame->arg[1] ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), frame ); + break; } // and if not nilp[frame->arg[2]) we also have an error. From 7b1cdf44405785cebe003629f359974b2f339162 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 24 Dec 2018 12:32:41 +0000 Subject: [PATCH 08/22] Ratio division --- src/consspaceobject.c | 8 +- src/equal.c | 4 +- src/peano.c | 193 +++++++++++++++++++++++++++++++----------- src/print.c | 8 +- 4 files changed, 154 insertions(+), 59 deletions(-) diff --git a/src/consspaceobject.c b/src/consspaceobject.c index d927470..72e438d 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -136,10 +136,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/equal.c b/src/equal.c index 0f0597c..ebb085e 100644 --- a/src/equal.c +++ b/src/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/peano.c b/src/peano.c index 3b6df53..24507a0 100644 --- a/src/peano.c +++ b/src/peano.c @@ -132,10 +132,10 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame, struct cons_pointer arg ) { struct cons_pointer result = arg; long int 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 ) { @@ -163,7 +163,7 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, fputws( L"; arg2 = ", stderr ); print( stderr, arg2 ); - struct cons_pointer r1, result; + struct cons_pointer r, result; struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); long int dd1v = @@ -180,22 +180,29 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); if ( dr1v == dr2v ) { - r1 = make_ratio( frame, + r = make_ratio( frame, make_integer( dd1v + dd2v ), cell1.payload.ratio.divisor ); } else { - r1 = add_ratio_ratio( frame, - make_ratio( frame, - make_integer( dd1v * m1 ), - make_integer( dr1v * m1 ) ), - make_ratio( frame, - make_integer( dd2v * m2 ), - make_integer( dr2v * m2 ) ) ); + struct cons_pointer dd1vm = make_integer( dd1v * m1 ), + dr1vm = make_integer( dr1v * m1 ), + dd2vm = make_integer( dd2v * m2 ), + dr2vm = make_integer( dr2v * m2 ), + r1 = make_ratio( frame, dd1vm, dr1vm ), + r2 = make_ratio( frame, dd2vm, dr2vm ); + + r = add_ratio_ratio( frame, r1, r2 ); + + /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were + * never incremented except when making r1 and r2, decrementing + * r1 and r2 should be enought to garbage collect them. */ + dec_ref( r1 ); + dec_ref( r2 ); } - result = simplify_ratio( frame, r1 ); - if ( !eq( r1, result ) ) { - dec_ref( r1 ); + result = simplify_ratio( frame, r ); + if ( !eq( r, result ) ) { + dec_ref( r ); } fputws( L" => ", stderr ); @@ -214,9 +221,13 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, struct cons_pointer add_integer_ratio( struct stack_frame *frame, struct cons_pointer intarg, struct cons_pointer ratarg ) { - return add_ratio_ratio( frame, - make_ratio( frame, intarg, make_integer( 1 ) ), - ratarg ); + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame, intarg, one ), + result = add_ratio_ratio( frame, ratio, ratarg ); + + dec_ref( one ); + dec_ref( ratio ); + return result; } @@ -298,8 +309,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot add: not a number" ), frame ); + result = exceptionp( arg2 ) ? arg2 : + lisp_throw( c_string_to_lisp_string + ( "Cannot add: not a number" ), frame ); } } @@ -388,9 +400,14 @@ struct cons_pointer multiply_ratio_ratio( struct struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, struct cons_pointer intarg, struct cons_pointer ratarg ) { - return multiply_ratio_ratio( frame, - make_ratio( frame, intarg, - make_integer( 1 ) ), ratarg ); + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame, intarg, one ), + result = multiply_ratio_ratio( frame, ratio, ratarg ); + + dec_ref( one); + dec_ref( ratio); + + return result; } @@ -467,7 +484,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, } break; case REALTV: - result = + result = exceptionp( arg2 ) ? arg2 : make_real( to_long_double( arg1 ) * to_long_double( arg2 ) ); break; @@ -515,6 +532,7 @@ struct cons_pointer lisp_multiply( struct && !exceptionp( result ) ) { tmp = result; result = multiply_2( frame, result, c_car( more ) ); + if ( !eq( tmp, result ) ) { dec_ref( tmp ); } @@ -543,8 +561,8 @@ struct cons_pointer inverse( struct stack_frame *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: @@ -650,7 +668,7 @@ struct cons_pointer lisp_subtract( struct } break; case REALTV: - result = + result = exceptionp( frame->arg[1] ) ? frame->arg[1] : make_real( to_long_double( frame->arg[0] ) - to_long_double( frame->arg[1] ) ); break; @@ -665,6 +683,26 @@ struct cons_pointer lisp_subtract( struct return result; } +/** + * 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. + */ +struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer i = make_ratio( frame, + pointer2cell( arg2 ).payload.ratio. + divisor, + pointer2cell( arg2 ).payload.ratio. + dividend ), result = + multiply_ratio_ratio( frame, arg1, i ); + + dec_ref( i ); + + return result; +} + /** * Divide one number by another. * @param env the evaluation environment - ignored; @@ -678,27 +716,84 @@ struct cons_pointer lisp_divide( struct struct cons_pointer result = NIL; struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); - if ( numberp( frame->arg[1] ) - && numeric_value( frame->arg[1] ) == 0 ) { - lisp_throw - ( c_string_to_lisp_string - ( "Cannot divide: divisor is zero" ), frame ); - } else if ( numberp( frame->arg[0] ) - && numberp( frame->arg[1] ) ) { - long int i = ( long int ) - numeric_value( frame->arg[0] ) / numeric_value( frame->arg[1] ); - long double r = ( long double ) - numeric_value( frame->arg[0] ) - / numeric_value( frame->arg[1] ); - if ( fabsl( ( long double ) i - r ) < 0.0000000001 ) { - result = make_integer( i ); - } else { - result = make_real( r ); - } - } else { - lisp_throw - ( c_string_to_lisp_string - ( "Cannot divide: not a number" ), frame ); + + switch ( arg0.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[0]; + break; + case INTEGERTV: + switch ( arg1.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[1]; + break; + case INTEGERTV: { + struct cons_pointer unsimplified = make_ratio( frame, frame->arg[0], frame->arg[1] ); + result = simplify_ratio(frame, unsimplified); + if (!eq(unsimplified,result)){ + dec_ref(unsimplified); + } + } + break; + case RATIOTV: { + struct cons_pointer one = make_integer( 1 ); + struct cons_pointer ratio = + make_ratio( frame, frame->arg[0], one ); + result = + divide_ratio_ratio( frame, ratio, frame->arg[1] ); + dec_ref( ratio ); + } + break; + case REALTV: + result = + make_real( to_long_double( frame->arg[0] ) / + to_long_double( frame->arg[1] ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot divide: not a number" ), + frame ); + break; + } + break; + case RATIOTV: + switch ( arg1.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[1]; + break; + case INTEGERTV: { + struct cons_pointer one = make_integer( 1 ); + struct cons_pointer ratio = + make_ratio( frame, frame->arg[1], one ); + result = divide_ratio_ratio( frame, frame->arg[0], ratio ); + dec_ref( ratio ); + } + break; + case RATIOTV: + result = + divide_ratio_ratio( frame, frame->arg[0], + frame->arg[1] ); + break; + case REALTV: + result = + make_real( to_long_double( frame->arg[0] ) / + to_long_double( frame->arg[1] ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot divide: not a number" ), + frame ); + break; + } + 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] ) ); + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot divide: not a number" ), frame ); + break; } return result; diff --git a/src/print.c b/src/print.c index 50e6f41..6101c37 100644 --- a/src/print.c +++ b/src/print.c @@ -132,8 +132,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case LAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); + cell.payload. + lambda.body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); @@ -141,8 +141,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case NLAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ), make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); + cell.payload. + lambda.body ) ) ); break; case RATIOTV: print( output, cell.payload.ratio.dividend ); From f6ff40324926f919127c541f1af5ce772023c1c6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 24 Dec 2018 15:12:17 +0000 Subject: [PATCH 09/22] Basics of vector space sort of done, but not yet working. --- Makefile | 2 +- src/conspage.c | 9 ++++++ src/consspaceobject.h | 13 ++++++-- src/vectorspace.c | 69 ++++++++++++++++++++++++++++++++++++++++++ src/vectorspace.h | 70 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 159 insertions(+), 4 deletions(-) create mode 100644 src/vectorspace.c create mode 100644 src/vectorspace.h diff --git a/Makefile b/Makefile index 4797c75..98a6bd3 100644 --- a/Makefile +++ b/Makefile @@ -17,7 +17,7 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ VERSION := "0.0.2" -CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g +CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm $(TARGET): $(OBJS) Makefile diff --git a/src/conspage.c b/src/conspage.c index 33e9828..8ba293b 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -159,6 +159,15 @@ void free_cell( struct cons_pointer pointer ) { case SYMBOLTV: dec_ref( cell->payload.string.cdr ); break; + case VECTORPOINTTV: + /* for vector space pointers, free the actual vector-space + * object. Dangerous! */ +#ifdef DEBUG + fwprintf(stderr, L"About to free vector-space object at %ld\n", cell->payload.vectorp.address); +#endif + free( (void *)cell->payload.vectorp.address); + break; + } if ( !check_tag( pointer, FREETAG ) ) { diff --git a/src/consspaceobject.h b/src/consspaceobject.h index de4d635..50ad5e1 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -127,12 +127,11 @@ * A pointer to an object in vector space. */ #define VECTORPOINTTAG "VECP" - +#define VECTORPOINTTV 0 /** * An open write stream. */ #define WRITETAG "WRIT" -/* TODO: this is wrong */ #define WRITETV 1414091351 /** @@ -222,7 +221,12 @@ * true if conspointer points to some sort of a number cell, * else false */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG)) +#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||heck_tag(conspoint,REALTAG)) + +/** + * true if thr conspointer points to a vector pointer. + */ +#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) /** * true if conspointer points to a write stream cell, else false. @@ -381,6 +385,9 @@ struct string_payload { struct cons_pointer cdr; }; +/** + * payload of a vector pointer cell. + */ struct vectorp_payload { union { char bytes[TAGLENGTH]; /* the tag (type) of the diff --git a/src/vectorspace.c b/src/vectorspace.c new file mode 100644 index 0000000..497838e --- /dev/null +++ b/src/vectorspace.c @@ -0,0 +1,69 @@ +/* + * vectorspace.c + * + * Structures common to all vector space objects. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "vectorspace.h" + + +/** + * 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`. + */ +struct cons_pointer make_vec_pointer(char *tag, uint64_t address) { + struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); + struct cons_space_object cell = pointer2cell( pointer ); + + strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 ); + cell.payload.vectorp.address = address; + + return pointer; +} + +/** + * 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`. + */ +struct cons_pointer make_vso( char *tag, long int payload_size) { + struct cons_pointer result = NIL; + long int total_size = sizeof(struct vector_space_header) + payload_size; + + struct vector_space_header *vso = malloc(total_size ); + + if (vso != NULL) { + strncpy( vso->tag.bytes[0], tag, TAGLENGTH ); + vso->vecp = make_vec_pointer(tag, (uint64_t)vso); + vso->size = payload_size; + +#ifdef DEBUG + fwprintf(stderr, L"Allocated vector-space object of type %s, total size %ld, payload size %ld\n", + tag, total_size, payload_size); +#endif + + result = vso->vecp; + } + + return result; +} + diff --git a/src/vectorspace.h b/src/vectorspace.h new file mode 100644 index 0000000..7fc90cc --- /dev/null +++ b/src/vectorspace.h @@ -0,0 +1,70 @@ +/** + * vectorspace.h + * + * Declarations common to all vector space objects. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "consspaceobject.h" + +#ifndef __vectorspace_h +#define __vectorspace_h + +/* + * part of the implementation structure of a namespace. + */ +#define HASHTAG "HASH" +#define HASHTV 0 + +/* + * a namespace (i.e. a binding of names to values, implemented as a hashmap) + */ +#define NAMESPACETAG "NMSP" +#define NAMESPACETV 0 + +/* + * a vector of cons pointers. + */ +#define VECTORTAG "VECT" +#define VECTORTV 0 + +#define pointer_to_vso(pointer)(vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : 0) + +struct cons_pointer make_vso( char *tag, long int payload_size); + +struct vector_space_header { + 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 */ + } 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 */ + char mark; /* mark bit for marking/sweeping the + * heap (not in this version) */ + char payload; /* we'll malloc `size` bytes for payload, + * `payload` is just the first of these. + * TODO: this is almost certainly not + * idiomatic C. */ +}; + +#endif + + From a5e1d3ccd86c0f5b1244305e8ff6596b8d05eb61 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 24 Dec 2018 19:27:04 +0000 Subject: [PATCH 10/22] Reorganised source files to make navigation easier All tests still pass (slightly to my surprise) --- src/{ => arith}/integer.c | 0 src/{ => arith}/integer.h | 0 src/{ => arith}/peano.c | 74 +++++++++++++++--------------- src/{ => arith}/peano.h | 0 src/{ => arith}/real.c | 0 src/{ => arith}/real.h | 0 src/{ => memory}/conspage.c | 7 +-- src/{ => memory}/conspage.h | 0 src/{ => memory}/consspaceobject.c | 8 ++-- src/{ => memory}/consspaceobject.h | 0 src/{ => memory}/stack.c | 0 src/{ => memory}/stack.h | 0 src/{ => memory}/vectorspace.c | 32 ++++++------- src/{ => memory}/vectorspace.h | 12 ++--- src/{ => ops}/equal.c | 4 +- src/{ => ops}/equal.h | 0 src/{ => ops}/intern.c | 0 src/{ => ops}/intern.h | 0 src/{ => ops}/lispops.c | 0 src/{ => ops}/lispops.h | 0 src/{ => ops}/print.c | 8 ++-- src/{ => ops}/print.h | 0 src/{ => ops}/read.c | 0 src/{ => ops}/read.h | 0 24 files changed, 73 insertions(+), 72 deletions(-) rename src/{ => arith}/integer.c (100%) rename src/{ => arith}/integer.h (100%) rename src/{ => arith}/peano.c (93%) rename src/{ => arith}/peano.h (100%) rename src/{ => arith}/real.c (100%) rename src/{ => arith}/real.h (100%) rename src/{ => memory}/conspage.c (97%) rename src/{ => memory}/conspage.h (100%) rename src/{ => memory}/consspaceobject.c (99%) rename src/{ => memory}/consspaceobject.h (100%) rename src/{ => memory}/stack.c (100%) rename src/{ => memory}/stack.h (100%) rename src/{ => memory}/vectorspace.c (62%) rename src/{ => memory}/vectorspace.h (86%) rename src/{ => ops}/equal.c (98%) rename src/{ => ops}/equal.h (100%) rename src/{ => ops}/intern.c (100%) rename src/{ => ops}/intern.h (100%) rename src/{ => ops}/lispops.c (100%) rename src/{ => ops}/lispops.h (100%) rename src/{ => ops}/print.c (96%) rename src/{ => ops}/print.h (100%) rename src/{ => ops}/read.c (100%) rename src/{ => ops}/read.h (100%) diff --git a/src/integer.c b/src/arith/integer.c similarity index 100% rename from src/integer.c rename to src/arith/integer.c diff --git a/src/integer.h b/src/arith/integer.h similarity index 100% rename from src/integer.h rename to src/arith/integer.h diff --git a/src/peano.c b/src/arith/peano.c similarity index 93% rename from src/peano.c rename to src/arith/peano.c index 24507a0..39613f5 100644 --- a/src/peano.c +++ b/src/arith/peano.c @@ -132,10 +132,10 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame, struct cons_pointer arg ) { struct cons_pointer result = arg; long int 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 ) { @@ -181,8 +181,8 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, if ( dr1v == dr2v ) { r = make_ratio( frame, - make_integer( dd1v + dd2v ), - cell1.payload.ratio.divisor ); + make_integer( dd1v + dd2v ), + cell1.payload.ratio.divisor ); } else { struct cons_pointer dd1vm = make_integer( dd1v * m1 ), dr1vm = make_integer( dr1v * m1 ), @@ -404,8 +404,8 @@ struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, ratio = make_ratio( frame, intarg, one ), result = multiply_ratio_ratio( frame, ratio, ratarg ); - dec_ref( one); - dec_ref( ratio); + dec_ref( one ); + dec_ref( ratio ); return result; } @@ -561,8 +561,8 @@ struct cons_pointer inverse( struct stack_frame *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: @@ -692,10 +692,10 @@ struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer i = make_ratio( frame, - 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, arg1, i ); dec_ref( i ); @@ -726,22 +726,23 @@ struct cons_pointer lisp_divide( struct case EXCEPTIONTV: result = frame->arg[1]; break; - case INTEGERTV: { - struct cons_pointer unsimplified = make_ratio( frame, frame->arg[0], frame->arg[1] ); - result = simplify_ratio(frame, unsimplified); - if (!eq(unsimplified,result)){ - dec_ref(unsimplified); - } - } + case INTEGERTV:{ + struct cons_pointer unsimplified = + make_ratio( frame, frame->arg[0], frame->arg[1] ); + result = simplify_ratio( frame, unsimplified ); + if ( !eq( unsimplified, result ) ) { + dec_ref( unsimplified ); + } + } break; - case RATIOTV: { - struct cons_pointer one = make_integer( 1 ); - struct cons_pointer ratio = - make_ratio( frame, frame->arg[0], one ); - result = - divide_ratio_ratio( frame, ratio, frame->arg[1] ); - dec_ref( ratio ); - } + case RATIOTV:{ + struct cons_pointer one = make_integer( 1 ); + struct cons_pointer ratio = + make_ratio( frame, frame->arg[0], one ); + result = + divide_ratio_ratio( frame, ratio, frame->arg[1] ); + dec_ref( ratio ); + } break; case REALTV: result = @@ -760,13 +761,14 @@ struct cons_pointer lisp_divide( struct case EXCEPTIONTV: result = frame->arg[1]; break; - case INTEGERTV: { - struct cons_pointer one = make_integer( 1 ); - struct cons_pointer ratio = - make_ratio( frame, frame->arg[1], one ); - result = divide_ratio_ratio( frame, frame->arg[0], ratio ); - dec_ref( ratio ); - } + case INTEGERTV:{ + struct cons_pointer one = make_integer( 1 ); + struct cons_pointer ratio = + make_ratio( frame, frame->arg[1], one ); + result = + divide_ratio_ratio( frame, frame->arg[0], ratio ); + dec_ref( ratio ); + } break; case RATIOTV: result = diff --git a/src/peano.h b/src/arith/peano.h similarity index 100% rename from src/peano.h rename to src/arith/peano.h diff --git a/src/real.c b/src/arith/real.c similarity index 100% rename from src/real.c rename to src/arith/real.c diff --git a/src/real.h b/src/arith/real.h similarity index 100% rename from src/real.h rename to src/arith/real.h diff --git a/src/conspage.c b/src/memory/conspage.c similarity index 97% rename from src/conspage.c rename to src/memory/conspage.c index 8ba293b..c5920c0 100644 --- a/src/conspage.c +++ b/src/memory/conspage.c @@ -159,13 +159,14 @@ void free_cell( struct cons_pointer pointer ) { case SYMBOLTV: dec_ref( cell->payload.string.cdr ); break; - case VECTORPOINTTV: + case VECTORPOINTTV: /* for vector space pointers, free the actual vector-space * object. Dangerous! */ #ifdef DEBUG - fwprintf(stderr, L"About to free vector-space object at %ld\n", cell->payload.vectorp.address); + fwprintf( stderr, L"About to free vector-space object at %ld\n", + cell->payload.vectorp.address ); #endif - free( (void *)cell->payload.vectorp.address); + free( ( void * ) cell->payload.vectorp.address ); break; } diff --git a/src/conspage.h b/src/memory/conspage.h similarity index 100% rename from src/conspage.h rename to src/memory/conspage.h diff --git a/src/consspaceobject.c b/src/memory/consspaceobject.c similarity index 99% rename from src/consspaceobject.c rename to src/memory/consspaceobject.c index 72e438d..d927470 100644 --- a/src/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -136,10 +136,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/consspaceobject.h b/src/memory/consspaceobject.h similarity index 100% rename from src/consspaceobject.h rename to src/memory/consspaceobject.h diff --git a/src/stack.c b/src/memory/stack.c similarity index 100% rename from src/stack.c rename to src/memory/stack.c diff --git a/src/stack.h b/src/memory/stack.h similarity index 100% rename from src/stack.h rename to src/memory/stack.h diff --git a/src/vectorspace.c b/src/memory/vectorspace.c similarity index 62% rename from src/vectorspace.c rename to src/memory/vectorspace.c index 497838e..6e331d6 100644 --- a/src/vectorspace.c +++ b/src/memory/vectorspace.c @@ -29,14 +29,14 @@ * NOTE that `tag` should be the vector-space tag of the particular type of * vector-space object, NOT `VECTORPOINTTAG`. */ -struct cons_pointer make_vec_pointer(char *tag, uint64_t address) { +struct cons_pointer make_vec_pointer( char *tag, uint64_t address ) { struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object cell = pointer2cell( pointer ); strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 ); cell.payload.vectorp.address = address; - return pointer; + return pointer; } /** @@ -45,25 +45,25 @@ struct cons_pointer make_vec_pointer(char *tag, uint64_t address) { * NOTE that `tag` should be the vector-space tag of the particular type of * vector-space object, NOT `VECTORPOINTTAG`. */ -struct cons_pointer make_vso( char *tag, long int payload_size) { - struct cons_pointer result = NIL; - long int total_size = sizeof(struct vector_space_header) + payload_size; +struct cons_pointer make_vso( char *tag, long int payload_size ) { + struct cons_pointer result = NIL; + long int total_size = sizeof( struct vector_space_header ) + payload_size; - struct vector_space_header *vso = malloc(total_size ); + struct vector_space_header *vso = malloc( total_size ); - if (vso != NULL) { - strncpy( vso->tag.bytes[0], tag, TAGLENGTH ); - vso->vecp = make_vec_pointer(tag, (uint64_t)vso); - vso->size = payload_size; + if ( vso != NULL ) { + strncpy( &vso->tag.bytes[0], tag, TAGLENGTH ); + vso->vecp = make_vec_pointer( tag, ( uint64_t ) vso ); + vso->size = payload_size; #ifdef DEBUG - fwprintf(stderr, L"Allocated vector-space object of type %s, total size %ld, payload size %ld\n", - tag, total_size, payload_size); + fwprintf( stderr, + L"Allocated vector-space object of type %s, total size %ld, payload size %ld\n", + tag, total_size, payload_size ); #endif - result = vso->vecp; - } + result = vso->vecp; + } - return result; + return result; } - diff --git a/src/vectorspace.h b/src/memory/vectorspace.h similarity index 86% rename from src/vectorspace.h rename to src/memory/vectorspace.h index 7fc90cc..b338766 100644 --- a/src/vectorspace.h +++ b/src/memory/vectorspace.h @@ -42,10 +42,10 @@ #define pointer_to_vso(pointer)(vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : 0) -struct cons_pointer make_vso( char *tag, long int payload_size); +struct cons_pointer make_vso( char *tag, long int payload_size ); struct vector_space_header { - union { + union { char bytes[TAGLENGTH]; /* the tag (type) of the * vector-space object this cell * points to, considered as bytes. @@ -56,15 +56,13 @@ struct vector_space_header { } 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 */ - char mark; /* mark bit for marking/sweeping the + uint64_t size; /* the size of my payload, in bytes */ + char mark; /* mark bit for marking/sweeping the * heap (not in this version) */ - char payload; /* we'll malloc `size` bytes for payload, + char payload; /* we'll malloc `size` bytes for payload, * `payload` is just the first of these. * TODO: this is almost certainly not * idiomatic C. */ }; #endif - - diff --git a/src/equal.c b/src/ops/equal.c similarity index 98% rename from src/equal.c rename to src/ops/equal.c index ebb085e..0f0597c 100644 --- a/src/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/equal.h b/src/ops/equal.h similarity index 100% rename from src/equal.h rename to src/ops/equal.h diff --git a/src/intern.c b/src/ops/intern.c similarity index 100% rename from src/intern.c rename to src/ops/intern.c diff --git a/src/intern.h b/src/ops/intern.h similarity index 100% rename from src/intern.h rename to src/ops/intern.h diff --git a/src/lispops.c b/src/ops/lispops.c similarity index 100% rename from src/lispops.c rename to src/ops/lispops.c diff --git a/src/lispops.h b/src/ops/lispops.h similarity index 100% rename from src/lispops.h rename to src/ops/lispops.h diff --git a/src/print.c b/src/ops/print.c similarity index 96% rename from src/print.c rename to src/ops/print.c index 6101c37..50e6f41 100644 --- a/src/print.c +++ b/src/ops/print.c @@ -132,8 +132,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case LAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body ) ) ); + cell.payload.lambda. + body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); @@ -141,8 +141,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case NLAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "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/print.h b/src/ops/print.h similarity index 100% rename from src/print.h rename to src/ops/print.h diff --git a/src/read.c b/src/ops/read.c similarity index 100% rename from src/read.c rename to src/ops/read.c diff --git a/src/read.h b/src/ops/read.h similarity index 100% rename from src/read.h rename to src/ops/read.h From ad9b1cd7f8c2b88bcccb40dc3d4fe2f767f78e8f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 24 Dec 2018 20:31:20 +0000 Subject: [PATCH 11/22] Ratio arithmetic separated out into its own files. --- src/arith/integer.c | 3 +- src/arith/peano.c | 205 +--------------------- src/arith/ratio.c | 330 +++++++++++++++++++++++++++++++++++ src/arith/ratio.h | 48 +++++ src/arith/real.c | 8 +- src/memory/consspaceobject.c | 25 --- src/ops/lispops.c | 3 +- src/ops/read.c | 1 + 8 files changed, 393 insertions(+), 230 deletions(-) create mode 100644 src/arith/ratio.c create mode 100644 src/arith/ratio.h diff --git a/src/arith/integer.c b/src/arith/integer.c index 999c803..e069f52 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -13,7 +13,6 @@ #include "conspage.h" #include "consspaceobject.h" -#include "read.h" /** * return the numeric value of this cell, as a C primitive double, not @@ -41,7 +40,9 @@ struct cons_pointer make_integer( long int value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; +#ifdef DEBUG dump_object( stderr, result ); +#endif return result; } diff --git a/src/arith/peano.c b/src/arith/peano.c index 39613f5..d43c768 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -21,6 +21,7 @@ #include "intern.h" #include "lispops.h" #include "print.h" +#include "ratio.h" #include "read.h" #include "real.h" #include "stack.h" @@ -113,123 +114,6 @@ long int to_long_int( struct cons_pointer arg ) { return result; } -long int greatest_common_divisor( long int m, long int n ) { - int o; - while ( m ) { - o = m; - m = n % m; - n = o; - } - - return o; -} - -long int least_common_multiple( long int m, long int n ) { - return m / greatest_common_divisor( m, n ) * n; -} - -struct cons_pointer simplify_ratio( struct stack_frame *frame, - struct cons_pointer arg ) { - struct cons_pointer result = arg; - long int 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 ( gcd > 1 ) { - if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd ); - } else { - result = - make_ratio( frame, make_integer( ddrv / gcd ), - make_integer( drrv / gcd ) ); - } - } - return result; -} - - -/** - * 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. -*/ -struct cons_pointer add_ratio_ratio( struct stack_frame *frame, - struct cons_pointer arg1, - struct cons_pointer arg2 ) { - fputws( L"add_ratio_ratio( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - - struct cons_pointer r, result; - struct cons_space_object cell1 = pointer2cell( arg1 ); - struct cons_space_object cell2 = pointer2cell( arg2 ); - long int dd1v = - pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, - dd2v = - pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, - dr1v = - pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, - dr2v = - pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, - lcm = least_common_multiple( dr1v, dr2v ), - m1 = lcm / dr1v, m2 = lcm / dr2v; - - fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); - - if ( dr1v == dr2v ) { - r = make_ratio( frame, - make_integer( dd1v + dd2v ), - 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 ), - r1 = make_ratio( frame, dd1vm, dr1vm ), - r2 = make_ratio( frame, dd2vm, dr2vm ); - - r = add_ratio_ratio( frame, r1, r2 ); - - /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were - * never incremented except when making r1 and r2, decrementing - * r1 and r2 should be enought to garbage collect them. */ - dec_ref( r1 ); - dec_ref( r2 ); - } - - result = simplify_ratio( frame, r ); - if ( !eq( r, result ) ) { - dec_ref( r ); - } - - fputws( L" => ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); - - return result; -} - - -/** - * 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. -*/ -struct cons_pointer add_integer_ratio( struct stack_frame *frame, - struct cons_pointer intarg, - struct cons_pointer ratarg ) { - struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame, intarg, one ), - result = add_ratio_ratio( frame, ratio, ratarg ); - - dec_ref( one ); - dec_ref( ratio ); - return result; -} - /** * return a cons_pointer indicating a number which is the sum of @@ -358,58 +242,6 @@ struct cons_pointer lisp_add( struct stack_frame return result; } -struct cons_pointer multiply_ratio_ratio( struct - stack_frame - *frame, struct - cons_pointer arg1, struct - cons_pointer arg2 ) { - fputws( L"multiply_ratio_ratio( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - - struct cons_pointer result; - struct cons_space_object cell1 = pointer2cell( arg1 ); - struct cons_space_object cell2 = pointer2cell( arg2 ); - long int dd1v = - pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, - dd2v = - pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, - dr1v = - pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, - dr2v = - pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, - ddrv = dd1v * dd2v, drrv = dr1v * dr2v; - - struct cons_pointer unsimplified = make_ratio( frame, make_integer( ddrv ), - make_integer( drrv ) ); - result = simplify_ratio( frame, unsimplified ); - - if ( !eq( unsimplified, result ) ) { - dec_ref( unsimplified ); - } - - return result; -} - -/** - * 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. -*/ -struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, - struct cons_pointer intarg, - struct cons_pointer ratarg ) { - struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame, intarg, one ), - result = multiply_ratio_ratio( frame, ratio, ratarg ); - - dec_ref( one ); - dec_ref( ratio ); - - return result; -} - /** * return a cons_pointer indicating a number which is the product of @@ -543,6 +375,10 @@ struct cons_pointer lisp_multiply( struct return result; } +/** + * return a cons_pointer indicating a number which is the + * inverse of the number indicated by `arg`. + */ struct cons_pointer inverse( struct stack_frame *frame, struct cons_pointer arg ) { struct cons_pointer result = NIL; @@ -577,17 +413,6 @@ struct cons_pointer inverse( struct stack_frame *frame, } -struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, - struct cons_pointer arg1, - struct cons_pointer arg2 ) { - struct cons_pointer i = inverse( frame, arg2 ), - result = add_ratio_ratio( frame, arg1, i ); - - dec_ref( i ); - - return result; -} - /** * Subtract one number from another. * @param env the evaluation environment - ignored; @@ -683,26 +508,6 @@ struct cons_pointer lisp_subtract( struct return result; } -/** - * 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. - */ -struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, - struct cons_pointer arg1, - struct cons_pointer arg2 ) { - struct cons_pointer i = make_ratio( frame, - pointer2cell( arg2 ).payload. - ratio.divisor, - pointer2cell( arg2 ).payload. - ratio.dividend ), result = - multiply_ratio_ratio( frame, arg1, i ); - - dec_ref( i ); - - return result; -} - /** * Divide one number by another. * @param env the evaluation environment - ignored; diff --git a/src/arith/ratio.c b/src/arith/ratio.c new file mode 100644 index 0000000..28ba59a --- /dev/null +++ b/src/arith/ratio.c @@ -0,0 +1,330 @@ +/* + * ratio.c + * + * functions for rational number cells. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#define _GNU_SOURCE +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "equal.h" +#include "integer.h" +#include "lispops.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 stack_frame *frame, + struct cons_pointer arg ); + +/** + * return, as a long int, the greatest common divisor of `m` and `n`, + */ +long int greatest_common_divisor( long int m, long int n ) { + int o; + while ( m ) { + o = m; + m = n % m; + n = o; + } + + return o; +} + +/** + * return, as a long int, the least common multiple of `m` and `n`, + */ +long int least_common_multiple( long int m, long int 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. If `arg` isn't a ratio, + * will throw exception. + */ +struct cons_pointer simplify_ratio( struct stack_frame *frame, + struct cons_pointer arg ) { + struct cons_pointer result = arg; + + if (ratiop(arg)) { + long int 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 ( gcd > 1 ) { + if ( drrv / gcd == 1 ) { + result = make_integer( ddrv / gcd ); + } else { + result = + make_ratio( frame, make_integer( ddrv / gcd ), + make_integer( drrv / gcd ) ); + } + } + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to simplify_ratio" ), + frame ); + } + + return result; +} + + + +/** + * 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. + */ +struct cons_pointer add_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer r, result; + +#ifdef DEBUG + fputws( L"add_ratio_ratio( arg1 = ", stderr ); + print( stderr, arg1 ); + fputws( L"; arg2 = ", stderr ); + print( stderr, arg2 ); + fputws( L")\n", stderr); +#endif + + if ( ratiop(arg1) && ratiop(arg2)) { + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + long int dd1v = + pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, + dd2v = + pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, + dr1v = + pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, + dr2v = + pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, + lcm = least_common_multiple( dr1v, dr2v ), + m1 = lcm / dr1v, m2 = lcm / dr2v; + +#ifdef DEBUG + fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); +#endif + + if ( dr1v == dr2v ) { + r = make_ratio( frame, + make_integer( dd1v + dd2v ), + 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 ), + r1 = make_ratio( frame, dd1vm, dr1vm ), + r2 = make_ratio( frame, dd2vm, dr2vm ); + + r = add_ratio_ratio( frame, r1, r2 ); + + /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were + * never incremented except when making r1 and r2, decrementing + * r1 and r2 should be enought to garbage collect them. */ + dec_ref( r1 ); + dec_ref( r2 ); + } + + result = simplify_ratio( frame, r ); + if ( !eq( r, result ) ) { + dec_ref( r ); + } + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to add_ratio_ratio" ), + frame ); + } + +#ifdef DEBUG + fputws( L" => ", stderr ); + print( stderr, result ); + fputws( L"\n", stderr ); +#endif + + return result; +} + + +/** + * 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. + */ +struct cons_pointer add_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) { + struct cons_pointer result; + + if (integerp(intarg) && ratiop(ratarg)) { + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame, intarg, one ); + + result = add_ratio_ratio( frame, ratio, ratarg ); + + dec_ref( one ); + dec_ref( ratio ); + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to add_integer_ratio" ), + frame ); + } + + return result; +} + +/** + * 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. + */ +struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer i = make_ratio( frame, + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), result = + multiply_ratio_ratio( frame, arg1, i ); + + dec_ref( i ); + + return result; +} + +/** + * 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. + */ +struct cons_pointer multiply_ratio_ratio( struct + stack_frame + *frame, struct + cons_pointer arg1, struct + cons_pointer arg2 ) { + struct cons_pointer result; + +#ifdef DEBUG + fputws( L"multiply_ratio_ratio( arg1 = ", stderr ); + print( stderr, arg1 ); + fputws( L"; arg2 = ", stderr ); + print( stderr, arg2 ); + fputws( L")\n", stderr); +#endif + if ( ratiop(arg1) && ratiop(arg2)) { + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + long int dd1v = + pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, + dd2v = + pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, + dr1v = + pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, + dr2v = + pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, + ddrv = dd1v * dd2v, drrv = dr1v * dr2v; + + struct cons_pointer unsimplified = make_ratio( frame, make_integer( ddrv ), + make_integer( drrv ) ); + result = simplify_ratio( frame, unsimplified ); + + if ( !eq( unsimplified, result ) ) { + dec_ref( unsimplified ); + } + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), + frame ); + } + + return result; +} + +/** + * 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. + */ +struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) { + struct cons_pointer result; + + if (integerp(intarg) && ratiop(ratarg)) { + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame, intarg, one ); + result = multiply_ratio_ratio( frame, ratio, ratarg ); + + dec_ref( one ); + dec_ref( ratio ); + } else { + result = lisp_throw( + c_string_to_lisp_string( "Shouldn't happen: bad arg to multiply_integer_ratio" ), + frame ); + } + + return result; +} + + +/** + * 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. + */ +struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer i = inverse( frame, arg2 ), + result = add_ratio_ratio( frame, arg1, i ); + + dec_ref( i ); + + return result; +} + + +/** + * Construct a ratio frame from these two pointers, expected to be integers + * or (later) bignums, in the context of this stack_frame. + */ +struct cons_pointer make_ratio( struct stack_frame *frame, + struct cons_pointer dividend, + struct cons_pointer divisor ) { + struct cons_pointer result; + if ( integerp( dividend ) && integerp( divisor ) ) { + inc_ref( dividend ); + inc_ref( divisor ); + result = allocate_cell( RATIOTAG ); + struct cons_space_object *cell = &pointer2cell( result ); + cell->payload.ratio.dividend = dividend; + cell->payload.ratio.divisor = divisor; + } else { + result = + lisp_throw( c_string_to_lisp_string + ( "Dividend and divisor of a ratio must be integers" ), + frame ); + } +#ifdef DEBUG + dump_object( stderr, result ); +#endif + + return result; +} diff --git a/src/arith/ratio.h b/src/arith/ratio.h new file mode 100644 index 0000000..fe650a7 --- /dev/null +++ b/src/arith/ratio.h @@ -0,0 +1,48 @@ +/** + * ratio.h + * + * functions for rational number cells. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __ratio_h +#define __ratio_h + +struct cons_pointer simplify_ratio( struct stack_frame *frame, + struct cons_pointer arg ) ; + +struct cons_pointer add_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) ; + +struct cons_pointer add_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) ; + +struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) ; + +struct cons_pointer multiply_ratio_ratio( struct + stack_frame + *frame, struct + cons_pointer arg1, struct + cons_pointer arg2 ) ; + +struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, + struct cons_pointer intarg, + struct cons_pointer ratarg ) ; + +struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, + struct cons_pointer arg1, + struct cons_pointer arg2 ) ; + +struct cons_pointer make_ratio( struct stack_frame *frame, + struct cons_pointer dividend, + struct cons_pointer divisor ) ; + + +#endif diff --git a/src/arith/real.c b/src/arith/real.c index 526dca5..ea3cc29 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -12,7 +12,7 @@ #include "read.h" /** - * Allocate a real number cell representing this value and return a cons + * Allocate a real number cell representing this value and return a cons * pointer to it. * @param value the value to wrap; * @return a real number cell wrapping this value. @@ -22,5 +22,9 @@ struct cons_pointer make_real( long double value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; - return result; +#ifdef DEBUG + dump_object( stderr, result ); +#endif + + return result; } diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index d927470..96f2cdd 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -247,31 +247,6 @@ struct cons_pointer make_nlambda( struct cons_pointer args, return pointer; } -/** - * Construct a ratio frame from these two pointers, expected to be integers - * or (later) bignums, in the context of this stack_frame. - */ -struct cons_pointer make_ratio( struct stack_frame *frame, - struct cons_pointer dividend, - struct cons_pointer divisor ) { - struct cons_pointer result; - if ( integerp( dividend ) && integerp( divisor ) ) { - inc_ref( dividend ); - inc_ref( divisor ); - result = allocate_cell( RATIOTAG ); - struct cons_space_object *cell = &pointer2cell( result ); - cell->payload.ratio.dividend = dividend; - cell->payload.ratio.divisor = divisor; - } else { - result = - make_exception( c_string_to_lisp_string - ( "Dividend and divisor of a ratio must be integers" ), - frame ); - } - - 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 diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 371779c..5dae587 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -129,8 +129,7 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) { * used to construct the body for `lambda` and `nlambda` expressions. */ struct cons_pointer compose_body( struct stack_frame *frame ) { - struct cons_pointer body = - !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL; + struct cons_pointer body = frame->more; for ( int i = args_in_frame - 1; i > 0; i-- ) { if ( !nilp( body ) ) { diff --git a/src/ops/read.c b/src/ops/read.c index 458c3f8..e5a41a5 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -22,6 +22,7 @@ #include "intern.h" #include "lispops.h" #include "print.h" +#include "ratio.h" #include "read.h" #include "real.h" From 6ee9f9b59a922ae2f7c7d0ccef8a0d13a683d103 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 25 Dec 2018 13:18:37 +0000 Subject: [PATCH 12/22] Begun work on bignums; changed integer size to 64 bits I'm fairly sure the size of a long int on my machines is 64 bit anyway, but for portability it needs to be explicit. --- src/arith/bignum.c | 14 ++++++++++++++ src/arith/bignum.h | 16 ++++++++++++++++ src/arith/integer.c | 2 +- src/arith/integer.h | 2 +- src/arith/peano.c | 19 ++++++++++++++----- src/arith/ratio.c | 14 +++++++------- src/memory/conspage.c | 6 ++++-- src/memory/consspaceobject.h | 27 ++++++++++++++++++++++++--- src/memory/vectorspace.c | 4 ++-- src/memory/vectorspace.h | 7 ++++++- src/ops/read.c | 4 ++-- utils_src/tagvalcalc/tagvalcalc.c | 19 ++++++++++++++++++- utils_src/tagvalcalc/tvc | Bin 8432 -> 8544 bytes 13 files changed, 109 insertions(+), 25 deletions(-) create mode 100644 src/arith/bignum.c create mode 100644 src/arith/bignum.h diff --git a/src/arith/bignum.c b/src/arith/bignum.c new file mode 100644 index 0000000..a21a7df --- /dev/null +++ b/src/arith/bignum.c @@ -0,0 +1,14 @@ +/* + * 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 new file mode 100644 index 0000000..05c9073 --- /dev/null +++ b/src/arith/bignum.h @@ -0,0 +1,16 @@ +/** + * 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 e069f52..60ce8c3 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -35,7 +35,7 @@ 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( long int value ) { +struct cons_pointer make_integer( int64_t value ) { struct cons_pointer result = allocate_cell( INTEGERTAG ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; diff --git a/src/arith/integer.h b/src/arith/integer.h index d44f34d..00b94a6 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -16,6 +16,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( long int value ); +struct cons_pointer make_integer( int64_t value ); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index d43c768..2b0183d 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -27,7 +27,7 @@ #include "stack.h" long double to_long_double( struct cons_pointer arg ); -long int to_long_int( struct cons_pointer arg ); +int64_t to_long_int( struct cons_pointer arg ); struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer arg2 ); @@ -97,8 +97,8 @@ long double to_long_double( struct cons_pointer arg ) { * 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. */ -long int to_long_int( struct cons_pointer arg ) { - long int result = 0; +int64_t to_long_int( struct cons_pointer arg ) { + int64_t result = 0; struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: @@ -125,10 +125,13 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); +#ifdef DEBUG fputws( L"add_2( arg1 = ", stderr ); print( stderr, arg1 ); fputws( L"; arg2 = ", stderr ); print( stderr, arg2 ); + fputws( L")\n", stderr); +#endif if ( zerop( arg1 ) ) { result = arg2; @@ -199,9 +202,11 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, } } +#ifdef DEBUG fputws( L"}; => ", stderr ); print( stderr, arg2 ); fputws( L"\n", stderr ); +#endif return result; } @@ -254,17 +259,19 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); +#ifdef DEBUG fputws( L"multiply_2( arg1 = ", stderr ); print( stderr, arg1 ); fputws( L"; arg2 = ", stderr ); print( stderr, arg2 ); + fputws( L")\n", stderr); +#endif if ( zerop( arg1 ) ) { result = arg2; } else if ( zerop( arg2 ) ) { result = arg1; } else { - switch ( cell1.tag.value ) { case EXCEPTIONTV: result = arg1; @@ -328,9 +335,11 @@ struct cons_pointer multiply_2( struct stack_frame *frame, } } - fputws( L"}; => ", stderr ); +#ifdef DEBUG + fputws( L" => ", stderr ); print( stderr, arg2 ); fputws( L"\n", stderr ); +#endif return result; } diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 28ba59a..ff716ec 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -28,9 +28,9 @@ struct cons_pointer inverse( struct stack_frame *frame, struct cons_pointer arg ); /** - * return, as a long int, the greatest common divisor of `m` and `n`, + * return, as a int64_t, the greatest common divisor of `m` and `n`, */ -long int greatest_common_divisor( long int m, long int n ) { +int64_t greatest_common_divisor( int64_t m, int64_t n ) { int o; while ( m ) { o = m; @@ -42,9 +42,9 @@ long int greatest_common_divisor( long int m, long int n ) { } /** - * return, as a long int, the least common multiple of `m` and `n`, + * return, as a int64_t, the least common multiple of `m` and `n`, */ -long int least_common_multiple( long int m, long int n ) { +int64_t least_common_multiple( int64_t m, int64_t n ) { return m / greatest_common_divisor( m, n ) * n; } @@ -59,7 +59,7 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame, struct cons_pointer result = arg; if (ratiop(arg)) { - long int ddrv = + int64_t ddrv = pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). payload.integer.value, drrv = pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). @@ -106,7 +106,7 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, if ( ratiop(arg1) && ratiop(arg2)) { struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); - long int dd1v = + int64_t dd1v = pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, dd2v = pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, @@ -231,7 +231,7 @@ struct cons_pointer multiply_ratio_ratio( struct if ( ratiop(arg1) && ratiop(arg2)) { struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); - long int dd1v = + int64_t dd1v = pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, dd2v = pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, diff --git a/src/memory/conspage.c b/src/memory/conspage.c index c5920c0..13d8373 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -127,8 +127,10 @@ void dump_pages( FILE * output ) { void free_cell( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); +#ifdef DEBUG fwprintf( stderr, L"Freeing cell " ); dump_object( stderr, pointer ); +#endif switch ( cell->tag.value ) { /* for all the types of cons-space object which point to other @@ -173,7 +175,7 @@ void free_cell( struct cons_pointer pointer ) { if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { - strncpy( &cell->tag.bytes[0], FREETAG, 4 ); + strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; @@ -209,7 +211,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, 4 ); + strncpy( &cell->tag.bytes[0], tag, TAGLENGTH ); cell->count = 0; cell->payload.cons.car = NIL; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 50ad5e1..555614a 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -28,6 +28,13 @@ /** * 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 */ @@ -38,7 +45,6 @@ * An exception. */ #define EXCEPTIONTAG "EXEP" -/* TODO: this is wrong */ #define EXCEPTIONTV 1346721861 /** @@ -162,6 +168,11 @@ */ #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 */ @@ -221,7 +232,7 @@ * true if conspointer points to some sort of a number cell, * else false */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||heck_tag(conspoint,REALTAG)) +#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) /** * true if thr conspointer points to a vector pointer. @@ -274,6 +285,16 @@ struct stack_frame { struct cons_pointer function; /* the function to be called */ }; +/** + * 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. */ @@ -321,7 +342,7 @@ struct free_payload { * optional bignum object. */ struct integer_payload { - long int value; + int64_t value; }; /** diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 6e331d6..4b18b96 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -45,9 +45,9 @@ struct cons_pointer make_vec_pointer( char *tag, uint64_t address ) { * NOTE that `tag` should be the vector-space tag of the particular type of * vector-space object, NOT `VECTORPOINTTAG`. */ -struct cons_pointer make_vso( char *tag, long int payload_size ) { +struct cons_pointer make_vso( char *tag, int64_t payload_size ) { struct cons_pointer result = NIL; - long int total_size = sizeof( struct vector_space_header ) + payload_size; + int64_t total_size = sizeof( struct vector_space_header ) + payload_size; struct vector_space_header *vso = malloc( total_size ); diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index b338766..07a0b91 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -34,6 +34,11 @@ #define NAMESPACETAG "NMSP" #define NAMESPACETV 0 +/* + * a stack frame. + */ +#define STACKFRAMETAG "STAK" +#define STACKFRAMETV /* * a vector of cons pointers. */ @@ -42,7 +47,7 @@ #define pointer_to_vso(pointer)(vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : 0) -struct cons_pointer make_vso( char *tag, long int payload_size ); +struct cons_pointer make_vso( char *tag, int64_t payload_size ); struct vector_space_header { union { diff --git a/src/ops/read.c b/src/ops/read.c index e5a41a5..9c21c9a 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -125,8 +125,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, struct cons_pointer read_number( struct stack_frame *frame, FILE * input, wint_t initial, bool seen_period ) { struct cons_pointer result = NIL; - long int accumulator = 0; - long int dividend = 0; + int64_t accumulator = 0; + int64_t dividend = 0; int places_of_decimals = 0; wint_t c; fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); diff --git a/utils_src/tagvalcalc/tagvalcalc.c b/utils_src/tagvalcalc/tagvalcalc.c index 1159187..67828bd 100644 --- a/utils_src/tagvalcalc/tagvalcalc.c +++ b/utils_src/tagvalcalc/tagvalcalc.c @@ -1,9 +1,26 @@ #include #include +#include +#include + +#define TAGLENGTH 4 + +struct dummy { + union { + char bytes[TAGLENGTH]; /* the tag (type) of this cell, + * considered as bytes */ + uint32_t value; /* the tag considered as a number */ + } tag; +}; int main( int argc, char *argv[] ) { + struct dummy *b = malloc( sizeof( struct dummy)); + struct dummy buffer = *b; for (int i = 1; i < argc; i++) { - printf( "%4.4s:\t%u\n", argv[i], (uint32_t)*argv[i]); + + strncpy( &buffer.tag.bytes[0], argv[i], TAGLENGTH ); + + printf( "%4.4s:\t%d\n", argv[i], buffer.tag.value); } } diff --git a/utils_src/tagvalcalc/tvc b/utils_src/tagvalcalc/tvc index 8fb6cb3375ac08fe1a467f984717cdc492714ca7..a639364e1d9b231bea94f83e58fdd6378dcccd83 100755 GIT binary patch delta 791 zcmZ8fO=uHQ5PqB8Xp5NLji`Yd+*Km}V5uZvY0##^gLhC-VnhU4O;SlQ#*(Io3b9BO zT$X6cy9iz+9u)NuC2R3FP%7csGcdIvo1h3h1nGg4x4njK{`jsIDC>ep=HGuOxjw1={Sx> zH(BL#;>IT@@&-zs$XnOG2YbF6u7Vp&I*~H?S`G|ZUxT9DUW{589mePzM3LBFY-*%G zlI5>ueK&461}W4G|1O_aA9=fZ>iOsMs`68o)I&;=OPW4p7*nNUAu~B+WO8>%jTA#_ z!nk`YpTCzuqyd^NP83SF0ip1d+VNRC?8fkdya3lI3wZCnx3tg2_`-VlK##|(b>#$D z0NXhFAI4k#JCFTEP~4-Rz$hSzZIUl&TJ+yRwno_c`Rq(S3zJT#jr2qzJ6?1<`~iom Bzk~n) delta 542 zcmaFh^uck$1t9@`1_nk328J9U1_1&7iI40AYoMZR5J85T$%c&ff-O){DX3`6(!dJo9gfS zom+i-pP|-d2Nnw^0shHVEPg@>K!qGY12lmcWI=|)Wj#fy-!~rJCMOVVmJ|H@1U4|d00l*- z>kFX1<^znKu5VuM`v3obx9cB|<|7KRhySbg0p%GOe0pVTfs|wLf7M(dJt2cZ5J1@7}t{=g!@BB&$~IGII3 zk)xm}Gp{6#VZ!841ugCgazN!EFhOo|mx7!mEKX&BLO@@EJO&0TlOHOGvjUk8Op|#P b6{Mktq*Ugl#21&8CdDUZ=B1<-fz$#3W3_}O From 9e5af35aa0fa7c81c32db8f1b4234b2fed67ffa6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 25 Dec 2018 13:51:15 +0000 Subject: [PATCH 13/22] Read negative numbers --- src/ops/read.c | 54 +++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 47 insertions(+), 7 deletions(-) diff --git a/src/ops/read.c b/src/ops/read.c index 9c21c9a..4ba45dc 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -86,6 +86,16 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, case '"': result = read_string( input, fgetwc( input ) ); break; + case '-': { + wint_t next = fgetwc( input ); + ungetwc( next, input ); + if ( iswdigit( next ) ) { + result = read_number( frame, input, c, false ); + } else { + result = read_symbol( input, c ); + } + } + break; case '.': { wint_t next = fgetwc( input ); @@ -113,6 +123,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, ( "Unrecognised start of input character" ), frame ); } + break; } } @@ -121,6 +132,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, /** * 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. */ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, wint_t initial, bool seen_period ) { @@ -129,11 +142,19 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, int64_t dividend = 0; int places_of_decimals = 0; wint_t c; + bool negative = initial == btowc( '-'); + + if (negative) { + initial = fgetwc( input ); + } + +#ifdef DEBUG fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); +#endif for ( c = initial; iswdigit( c ) || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { - if ( seen_period || dividend > 0 ) { + if ( seen_period || dividend != 0 ) { return make_exception( c_string_to_lisp_string ( "Malformed number: too many periods" ), frame ); @@ -146,14 +167,17 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, ( "Malformed number: dividend must be integer" ), frame ); } else { - dividend = accumulator; - accumulator = 0; + dividend = negative ? 0 - accumulator : accumulator; + + accumulator = 0; } } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); +#ifdef DEBUG fwprintf( stderr, L"Added character %c, accumulator now %ld\n", c, accumulator ); +#endif if ( seen_period ) { places_of_decimals++; } @@ -167,13 +191,21 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, if ( seen_period ) { long double rv = ( long double ) ( accumulator / pow( 10, places_of_decimals ) ); + if (negative) { + rv = 0 - rv; + } +#ifdef DEBUG fwprintf( stderr, L"read_numer returning %Lf\n", rv ); +#endif result = make_real( rv ); - } else if ( dividend > 0 ) { + } else if ( dividend != 0 ) { result = make_ratio( frame, make_integer( dividend ), make_integer( accumulator ) ); } else { + if (negative) { + accumulator = 0 - accumulator; + } result = make_integer( accumulator ); } @@ -189,14 +221,19 @@ struct cons_pointer read_list( struct *frame, FILE * input, wint_t initial ) { struct cons_pointer result = NIL; if ( initial != ')' ) { - fwprintf( stderr, +#ifdef DEBUG + fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial ); - struct cons_pointer car = read_continuation( frame, input, +#endif + struct cons_pointer car = read_continuation( frame, input, initial ); result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); - } else { + } +#ifdef DEBUG + else { fwprintf( stderr, L"End of list detected\n" ); } +#endif return result; } @@ -267,9 +304,12 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { break; } +#ifdef DEBUG fputws( L"Read symbol '", stderr ); print( stderr, result ); fputws( L"'\n", stderr ); +#endif + return result; } From 9ff2f14c7d9b1e3bb6c0bb823680be7e84e44c3e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 25 Dec 2018 14:44:38 +0000 Subject: [PATCH 14/22] Reverse --- src/init.c | 1 + src/memory/consspaceobject.h | 2 ++ src/ops/lispops.c | 53 +++++++++++++++++++++++++++++++++-- src/ops/lispops.h | 7 +++-- src/ops/read.c | 4 ++- unit-tests/add.sh | 54 ++++++++++++++++++++++++++++++++++++ unit-tests/reverse.sh | 36 ++++++++++++++++++++++++ 7 files changed, 151 insertions(+), 6 deletions(-) create mode 100644 unit-tests/reverse.sh diff --git a/src/init.c b/src/init.c index 876bdad..a7e835a 100644 --- a/src/init.c +++ b/src/init.c @@ -95,6 +95,7 @@ int main( int argc, char *argv[] ) { bind_function( "oblist", &lisp_oblist ); bind_function( "print", &lisp_print ); bind_function( "progn", &lisp_progn ); + bind_function( "reverse", &lisp_reverse ); bind_function( "set", &lisp_set ); bind_function( "subtract", &lisp_subtract ); bind_function( "type", &lisp_type ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 555614a..43bdfe0 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -234,6 +234,8 @@ */ #define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) +#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) + /** * true if thr conspointer points to a vector pointer. */ diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 5dae587..a0417b7 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -169,11 +169,13 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) { } void log_binding( struct cons_pointer name, struct cons_pointer val ) { - print( stderr, c_string_to_lisp_string( "\n\tBinding " ) ); +#ifdef DEBUG + fputws( L"\n\tBinding ", stderr ); print( stderr, name ); - print( stderr, c_string_to_lisp_string( " to " ) ); + fputws( L" to ", stderr); print( stderr, val ); fputws( L"\"\n", stderr ); +#endif } /** @@ -279,8 +281,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer exep = NIL; struct stack_frame *next = make_stack_frame( frame, args, env, &exep ); +#ifdef DEBUG fputws( L"Stack frame for lambda\n", stderr ); dump_frame( stderr, next ); +#endif result = eval_lambda( fn_cell, next, env ); if ( exceptionp( result ) ) { /* if we're returning an exception, we should NOT free the @@ -296,8 +300,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { { struct stack_frame *next = make_special_frame( frame, args, env ); +#ifdef DEBUG fputws( L"Stack frame for nlambda\n", stderr ); dump_frame( stderr, next ); +#endif result = eval_lambda( fn_cell, next, env ); if ( !exceptionp( result ) ) { /* if we're returning an exception, we should NOT free the @@ -376,8 +382,10 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = frame->arg[0]; struct cons_space_object cell = pointer2cell( frame->arg[0] ); +#ifdef DEBUG fputws( L"Eval: ", stderr ); dump_frame( stderr, frame ); +#endif switch ( cell.tag.value ) { case CONSTV: @@ -415,9 +423,11 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { break; } +#ifdef DEBUG fputws( L"Eval returning ", stderr ); print( stderr, result ); fputws( L"\n", stderr ); +#endif return result; } @@ -432,17 +442,20 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { */ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { +#ifdef DEBUG fputws( L"Apply: ", stderr ); dump_frame( stderr, frame ); - +#endif set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); set_reg( frame, 1, NIL ); struct cons_pointer result = c_apply( frame, env ); +#ifdef DEBUG fputws( L"Apply returning ", stderr ); print( stderr, result ); fputws( L"\n", stderr ); +#endif return result; } @@ -641,6 +654,40 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) { } +/** + * reverse a sequence. + */ +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(o.payload.string.character, result); + break; + } + } + + return result; +} + + +/** + * (reverse sequence) + * 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 env ) { + return c_reverse( frame->arg[0]); +} + + /** * (print expr) * (print expr write-stream) diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 122e149..3ac53c7 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -40,6 +40,7 @@ struct cons_pointer c_car( struct cons_pointer arg ); */ struct cons_pointer c_cdr( struct cons_pointer arg ); +struct cons_pointer c_reverse( struct cons_pointer arg); /** * Useful building block; evaluate this single form in the context of this @@ -117,10 +118,12 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer env ); struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer env ); -struct cons_pointer lisp_read( struct stack_frame *frame, - struct cons_pointer env ); struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer env ); +struct cons_pointer lisp_read( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_reverse( struct stack_frame *frame, + struct cons_pointer env ); /** * Function: Get the Lisp type of the single argument. * @param frame My stack frame. diff --git a/src/ops/read.c b/src/ops/read.c index 4ba45dc..2acb99c 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -148,6 +148,8 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, initial = fgetwc( input ); } + + #ifdef DEBUG fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); #endif @@ -164,7 +166,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, } else if ( c == btowc( '/' ) ) { if ( seen_period || dividend > 0 ) { return make_exception( c_string_to_lisp_string - ( "Malformed number: dividend must be integer" ), + ( "Malformed number: dividend of rational must be integer" ), frame ); } else { dividend = negative ? 0 - accumulator : accumulator; diff --git a/unit-tests/add.sh b/unit-tests/add.sh index 7bb29c7..4516808 100644 --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -23,3 +23,57 @@ else exit 1 fi +expected='1/4' +actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# (+ integer ratio) should be ratio +expected='25/4' +actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# (+ ratio integer) should be ratio +expected='25/4' +actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# (+ 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` + +outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc` + +if [ "${outcome}" = "1" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + diff --git a/unit-tests/reverse.sh b/unit-tests/reverse.sh new file mode 100644 index 0000000..4e3f8f6 --- /dev/null +++ b/unit-tests/reverse.sh @@ -0,0 +1,36 @@ +#!/bin/bash + +expected='"god yzal eht revo depmuj xof nworb kciuq ehT"' +actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +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` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='esrever' +actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + From ae8ba67ed72c367f1d244816b9cd59f4127359da Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 25 Dec 2018 15:32:45 +0000 Subject: [PATCH 15/22] Better exceptions, investigation on failure to read/print wide chars. --- .gitignore | 2 + src/arith/peano.c | 8 +- src/arith/ratio.c | 240 +++++++++++++++------------- src/arith/ratio.h | 16 +- src/arith/real.c | 2 +- src/init.c | 1 + src/memory/consspaceobject.c | 8 +- src/ops/equal.c | 4 +- src/ops/lispops.c | 39 ++--- src/ops/lispops.h | 4 +- src/ops/print.c | 15 +- src/ops/read.c | 44 +++-- utils_src/readprintwc/readprintwc.c | 17 ++ 13 files changed, 217 insertions(+), 183 deletions(-) create mode 100644 utils_src/readprintwc/readprintwc.c diff --git a/.gitignore b/.gitignore index 6840d19..0742055 100644 --- a/.gitignore +++ b/.gitignore @@ -28,3 +28,5 @@ log* \.project \.settings/language\.settings\.xml + +utils_src/readprintwc/out diff --git a/src/arith/peano.c b/src/arith/peano.c index 2b0183d..423bd51 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -130,7 +130,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, print( stderr, arg1 ); fputws( L"; arg2 = ", stderr ); print( stderr, arg2 ); - fputws( L")\n", stderr); + fputws( L")\n", stderr ); #endif if ( zerop( arg1 ) ) { @@ -264,7 +264,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, print( stderr, arg1 ); fputws( L"; arg2 = ", stderr ); print( stderr, arg2 ); - fputws( L")\n", stderr); + fputws( L")\n", stderr ); #endif if ( zerop( arg1 ) ) { @@ -406,8 +406,8 @@ struct cons_pointer inverse( struct stack_frame *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 ff716ec..8a5eec7 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -58,27 +58,28 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame, struct cons_pointer arg ) { struct cons_pointer result = arg; - 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 ( 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 ( gcd > 1 ) { - if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd ); - } else { - result = - make_ratio( frame, make_integer( ddrv / gcd ), - make_integer( drrv / gcd ) ); + if ( gcd > 1 ) { + if ( drrv / gcd == 1 ) { + result = make_integer( ddrv / gcd ); + } else { + result = + make_ratio( frame, make_integer( ddrv / gcd ), + make_integer( drrv / gcd ) ); + } } + } else { + result = + lisp_throw( make_cons( c_string_to_lisp_string + ( "Shouldn't happen: bad arg to simplify_ratio" ), + arg ), frame ); } - } else { - result = lisp_throw( - c_string_to_lisp_string( "Shouldn't happen: bad arg to simplify_ratio" ), - frame ); - } return result; } @@ -100,58 +101,61 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, print( stderr, arg1 ); fputws( L"; arg2 = ", stderr ); print( stderr, arg2 ); - fputws( L")\n", stderr); + fputws( L")\n", stderr ); #endif - if ( ratiop(arg1) && ratiop(arg2)) { - struct cons_space_object cell1 = pointer2cell( arg1 ); - struct cons_space_object cell2 = pointer2cell( arg2 ); - int64_t dd1v = - pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, - dd2v = - pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, - dr1v = - pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, - dr2v = - pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, - lcm = least_common_multiple( dr1v, dr2v ), - m1 = lcm / dr1v, m2 = lcm / dr2v; + if ( ratiop( arg1 ) && ratiop( arg2 ) ) { + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + int64_t dd1v = + pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, + dd2v = + pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, + dr1v = + pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, + dr2v = + pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, + lcm = least_common_multiple( dr1v, dr2v ), + m1 = lcm / dr1v, m2 = lcm / dr2v; #ifdef DEBUG - fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); + fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); #endif - if ( dr1v == dr2v ) { - r = make_ratio( frame, - make_integer( dd1v + dd2v ), - cell1.payload.ratio.divisor ); + if ( dr1v == dr2v ) { + r = make_ratio( frame, + make_integer( dd1v + dd2v ), + 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 ), + r1 = make_ratio( frame, dd1vm, dr1vm ), + r2 = make_ratio( frame, dd2vm, dr2vm ); + + r = add_ratio_ratio( frame, r1, r2 ); + + /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were + * never incremented except when making r1 and r2, decrementing + * r1 and r2 should be enought to garbage collect them. */ + dec_ref( r1 ); + dec_ref( r2 ); + } + + result = simplify_ratio( frame, r ); + if ( !eq( r, result ) ) { + dec_ref( r ); + } } else { - struct cons_pointer dd1vm = make_integer( dd1v * m1 ), - dr1vm = make_integer( dr1v * m1 ), - dd2vm = make_integer( dd2v * m2 ), - dr2vm = make_integer( dr2v * m2 ), - r1 = make_ratio( frame, dd1vm, dr1vm ), - r2 = make_ratio( frame, dd2vm, dr2vm ); - - r = add_ratio_ratio( frame, r1, r2 ); - - /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were - * never incremented except when making r1 and r2, decrementing - * r1 and r2 should be enought to garbage collect them. */ - dec_ref( r1 ); - dec_ref( r2 ); + result = + lisp_throw( make_cons( c_string_to_lisp_string + ( "Shouldn't happen: bad arg to add_ratio_ratio" ), + make_cons( arg1, + make_cons( arg2, NIL ) ) ), + frame ); } - result = simplify_ratio( frame, r ); - if ( !eq( r, result ) ) { - dec_ref( r ); - } - } else { - result = lisp_throw( - c_string_to_lisp_string( "Shouldn't happen: bad arg to add_ratio_ratio" ), - frame ); - } - #ifdef DEBUG fputws( L" => ", stderr ); print( stderr, result ); @@ -170,23 +174,26 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, struct cons_pointer add_integer_ratio( struct stack_frame *frame, struct cons_pointer intarg, struct cons_pointer ratarg ) { - struct cons_pointer result; + struct cons_pointer result; - if (integerp(intarg) && ratiop(ratarg)) { - struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame, intarg, one ); + if ( integerp( intarg ) && ratiop( ratarg ) ) { + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame, intarg, one ); - result = add_ratio_ratio( frame, ratio, ratarg ); + result = add_ratio_ratio( frame, ratio, ratarg ); - dec_ref( one ); - dec_ref( ratio ); - } else { - result = lisp_throw( - c_string_to_lisp_string( "Shouldn't happen: bad arg to add_integer_ratio" ), - frame ); - } + dec_ref( one ); + dec_ref( ratio ); + } else { + result = + lisp_throw( make_cons( c_string_to_lisp_string + ( "Shouldn't happen: bad arg to add_integer_ratio" ), + make_cons( intarg, + make_cons( ratarg, NIL ) ) ), + frame ); + } - return result; + return result; } /** @@ -198,10 +205,10 @@ struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer i = make_ratio( frame, - 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, arg1, i ); dec_ref( i ); @@ -226,33 +233,35 @@ struct cons_pointer multiply_ratio_ratio( struct print( stderr, arg1 ); fputws( L"; arg2 = ", stderr ); print( stderr, arg2 ); - fputws( L")\n", stderr); + fputws( L")\n", stderr ); #endif - if ( ratiop(arg1) && ratiop(arg2)) { - struct cons_space_object cell1 = pointer2cell( arg1 ); - struct cons_space_object cell2 = pointer2cell( arg2 ); - int64_t dd1v = - pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, - dd2v = - pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, - dr1v = - pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, - dr2v = - pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, - ddrv = dd1v * dd2v, drrv = dr1v * dr2v; + if ( ratiop( arg1 ) && ratiop( arg2 ) ) { + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + int64_t dd1v = + pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, + dd2v = + pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, + dr1v = + pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, + dr2v = + pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, + ddrv = dd1v * dd2v, drrv = dr1v * dr2v; - struct cons_pointer unsimplified = make_ratio( frame, make_integer( ddrv ), - make_integer( drrv ) ); - result = simplify_ratio( frame, unsimplified ); + struct cons_pointer unsimplified = + make_ratio( frame, make_integer( ddrv ), + make_integer( drrv ) ); + result = simplify_ratio( frame, unsimplified ); - if ( !eq( unsimplified, result ) ) { - dec_ref( unsimplified ); + if ( !eq( unsimplified, result ) ) { + dec_ref( unsimplified ); + } + } else { + result = + lisp_throw( c_string_to_lisp_string + ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), + frame ); } - } else { - result = lisp_throw( - c_string_to_lisp_string( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), - frame ); - } return result; } @@ -265,20 +274,21 @@ struct cons_pointer multiply_ratio_ratio( struct struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, struct cons_pointer intarg, struct cons_pointer ratarg ) { - struct cons_pointer result; + struct cons_pointer result; - if (integerp(intarg) && ratiop(ratarg)) { - struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame, intarg, one ); - result = multiply_ratio_ratio( frame, ratio, ratarg ); + if ( integerp( intarg ) && ratiop( ratarg ) ) { + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame, intarg, one ); + result = multiply_ratio_ratio( frame, ratio, ratarg ); - dec_ref( one ); - dec_ref( ratio ); - } else { - result = lisp_throw( - c_string_to_lisp_string( "Shouldn't happen: bad arg to multiply_integer_ratio" ), - frame ); - } + dec_ref( one ); + dec_ref( ratio ); + } else { + result = + lisp_throw( c_string_to_lisp_string + ( "Shouldn't happen: bad arg to multiply_integer_ratio" ), + frame ); + } return result; } @@ -319,8 +329,8 @@ struct cons_pointer make_ratio( struct stack_frame *frame, } else { result = lisp_throw( c_string_to_lisp_string - ( "Dividend and divisor of a ratio must be integers" ), - frame ); + ( "Dividend and divisor of a ratio must be integers" ), + frame ); } #ifdef DEBUG dump_object( stderr, result ); diff --git a/src/arith/ratio.h b/src/arith/ratio.h index fe650a7..c4e5548 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -12,37 +12,37 @@ #define __ratio_h struct cons_pointer simplify_ratio( struct stack_frame *frame, - struct cons_pointer arg ) ; + struct cons_pointer arg ); struct cons_pointer add_ratio_ratio( struct stack_frame *frame, struct cons_pointer arg1, - struct cons_pointer arg2 ) ; + struct cons_pointer arg2 ); struct cons_pointer add_integer_ratio( struct stack_frame *frame, struct cons_pointer intarg, - struct cons_pointer ratarg ) ; + struct cons_pointer ratarg ); struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, struct cons_pointer arg1, - struct cons_pointer arg2 ) ; + struct cons_pointer arg2 ); struct cons_pointer multiply_ratio_ratio( struct stack_frame *frame, struct cons_pointer arg1, struct - cons_pointer arg2 ) ; + cons_pointer arg2 ); struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, struct cons_pointer intarg, - struct cons_pointer ratarg ) ; + struct cons_pointer ratarg ); struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, struct cons_pointer arg1, - struct cons_pointer arg2 ) ; + struct cons_pointer arg2 ); struct cons_pointer make_ratio( struct stack_frame *frame, struct cons_pointer dividend, - struct cons_pointer divisor ) ; + struct cons_pointer divisor ); #endif diff --git a/src/arith/real.c b/src/arith/real.c index ea3cc29..a499b6a 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -26,5 +26,5 @@ struct cons_pointer make_real( long double value ) { dump_object( stderr, result ); #endif - return result; + return result; } diff --git a/src/init.c b/src/init.c index a7e835a..9716365 100644 --- a/src/init.c +++ b/src/init.c @@ -111,6 +111,7 @@ int main( int argc, char *argv[] ) { */ bind_special( "cond", &lisp_cond ); bind_special( "lambda", &lisp_lambda ); + /* bind_special( "λ", &lisp_lambda ); */ bind_special( "nlambda", &lisp_nlambda ); bind_special( "progn", &lisp_progn ); bind_special( "quote", &lisp_quote ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 96f2cdd..39f464a 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -136,10 +136,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 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/lispops.c b/src/ops/lispops.c index a0417b7..9b12faa 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -172,7 +172,7 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) { #ifdef DEBUG fputws( L"\n\tBinding ", stderr ); print( stderr, name ); - fputws( L" to ", stderr); + fputws( L" to ", stderr ); print( stderr, val ); fputws( L"\"\n", stderr ); #endif @@ -657,25 +657,25 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) { /** * reverse a sequence. */ -struct cons_pointer c_reverse( struct cons_pointer arg) { - struct cons_pointer result = NIL; +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(o.payload.string.character, result); - break; + 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( o.payload.string.character, result ); + break; + } } - } - return result; + return result; } @@ -683,8 +683,9 @@ 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. */ -struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer env ) { - return c_reverse( frame->arg[0]); +struct cons_pointer lisp_reverse( struct stack_frame *frame, + struct cons_pointer env ) { + return c_reverse( frame->arg[0] ); } diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 3ac53c7..961cf2e 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -40,7 +40,7 @@ struct cons_pointer c_car( struct cons_pointer arg ); */ struct cons_pointer c_cdr( struct cons_pointer arg ); -struct cons_pointer c_reverse( struct cons_pointer arg); +struct cons_pointer c_reverse( struct cons_pointer arg ); /** * Useful building block; evaluate this single form in the context of this @@ -123,7 +123,7 @@ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer env ); struct cons_pointer lisp_reverse( struct stack_frame *frame, - struct cons_pointer env ); + 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 50e6f41..4ec5a15 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -118,7 +118,12 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case EXCEPTIONTV: fwprintf( output, L"\n%sException: ", print_use_colours ? "\x1B[31m" : "" ); - print_string_contents( output, cell.payload.exception.message ); + if ( stringp( cell.payload.exception.message ) ) { + print_string_contents( output, + cell.payload.exception.message ); + } else { + print( output, cell.payload.exception.message ); + } break; case FUNCTIONTV: fwprintf( output, L"(Function)" ); @@ -132,8 +137,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case LAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); + cell.payload. + lambda.body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); @@ -141,8 +146,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case NLAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "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 2acb99c..bd063b2 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -86,15 +86,15 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, case '"': result = read_string( input, fgetwc( input ) ); break; - case '-': { + case '-':{ wint_t next = fgetwc( input ); ungetwc( next, input ); if ( iswdigit( next ) ) { - result = read_number( frame, input, c, false ); + result = read_number( frame, input, c, false ); } else { - result = read_symbol( input, c ); + result = read_symbol( input, c ); } - } + } break; case '.': { @@ -119,11 +119,12 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, result = read_symbol( input, c ); } else { result = - make_exception( c_string_to_lisp_string - ( "Unrecognised start of input character" ), + make_exception( make_cons( c_string_to_lisp_string + ( "Unrecognised start of input character" ), + make_string( c, NIL ) ), frame ); } - break; + break; } } @@ -142,14 +143,11 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, int64_t dividend = 0; int places_of_decimals = 0; wint_t c; - bool negative = initial == btowc( '-'); + bool negative = initial == btowc( '-' ); - if (negative) { - initial = fgetwc( input ); + if ( negative ) { + initial = fgetwc( input ); } - - - #ifdef DEBUG fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); #endif @@ -171,7 +169,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, } else { dividend = negative ? 0 - accumulator : accumulator; - accumulator = 0; + accumulator = 0; } } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); @@ -193,9 +191,9 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, if ( seen_period ) { long double rv = ( long double ) ( accumulator / pow( 10, places_of_decimals ) ); - if (negative) { - rv = 0 - rv; - } + if ( negative ) { + rv = 0 - rv; + } #ifdef DEBUG fwprintf( stderr, L"read_numer returning %Lf\n", rv ); #endif @@ -205,9 +203,9 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, make_ratio( frame, make_integer( dividend ), make_integer( accumulator ) ); } else { - if (negative) { - accumulator = 0 - accumulator; - } + if ( negative ) { + accumulator = 0 - accumulator; + } result = make_integer( accumulator ); } @@ -224,15 +222,15 @@ struct cons_pointer read_list( struct struct cons_pointer result = NIL; if ( initial != ')' ) { #ifdef DEBUG - fwprintf( stderr, + fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial ); #endif - struct cons_pointer car = read_continuation( frame, input, + struct cons_pointer car = read_continuation( frame, input, initial ); result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); } #ifdef DEBUG - else { + else { fwprintf( stderr, L"End of list detected\n" ); } #endif diff --git a/utils_src/readprintwc/readprintwc.c b/utils_src/readprintwc/readprintwc.c new file mode 100644 index 0000000..e221c9c --- /dev/null +++ b/utils_src/readprintwc/readprintwc.c @@ -0,0 +1,17 @@ +#include +#include +#include +#include + +int main( int argc, char *argv[] ) { + fwide( stdin, 1 ); + fwide( stdout, 1 ); + + for (wchar_t c = fgetwc( stdin ); !feof( stdin); c = fgetwc( stdin )) { + if (c != '\n') { + fwprintf( stdout, L"Read character %d, %C\t", (int)c, c); + fputwc( c, stdout); + fputws(L"\n", stdout); + } + } +} From 9937f344dcdf3df5cebc1ae339930ba1f712e449 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 26 Dec 2018 20:30:14 +0000 Subject: [PATCH 16/22] Major refactoring. Major problems! On the right path but it doesn't work yet. --- Makefile | 2 +- src/arith/peano.c | 121 +++++++++--------- src/arith/peano.h | 8 +- src/arith/ratio.c | 77 ++++++------ src/arith/ratio.h | 18 ++- src/init.c | 2 + src/memory/consspaceobject.c | 120 +++--------------- src/memory/consspaceobject.h | 36 ++---- src/memory/dump.c | 120 ++++++++++++++++++ src/memory/dump.h | 29 +++++ src/memory/stack.c | 169 ++++++++++++++++++-------- src/memory/stack.h | 48 ++++---- src/memory/vectorspace.c | 26 ++-- src/memory/vectorspace.h | 16 ++- src/ops/lispops.c | 229 ++++++++++++++++++++--------------- src/ops/lispops.h | 57 +++++---- src/ops/print.c | 8 +- src/ops/read.c | 53 ++++---- src/ops/read.h | 4 +- src/repl.c | 58 ++++++--- 20 files changed, 695 insertions(+), 506 deletions(-) create mode 100644 src/memory/dump.c create mode 100644 src/memory/dump.h diff --git a/Makefile b/Makefile index 98a6bd3..3fc8148 100644 --- a/Makefile +++ b/Makefile @@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile .PHONY: clean clean: - $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~ + $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ repl: $(TARGET) -p 2> psse.log diff --git a/src/arith/peano.c b/src/arith/peano.c index 423bd51..63783f5 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -8,11 +8,11 @@ */ #include +#include #include #include #include #include -#include #include "consspaceobject.h" #include "conspage.h" @@ -28,7 +28,7 @@ long double to_long_double( struct cons_pointer arg ); int64_t to_long_int( struct cons_pointer arg ); -struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, +struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ); @@ -119,7 +119,7 @@ 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`. */ -struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, +struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer result; struct cons_space_object cell1 = pointer2cell( arg1 ); @@ -153,7 +153,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, cell2.payload.integer.value ); break; case RATIOTV: - result = add_integer_ratio( frame, arg1, arg2 ); + result = add_integer_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -161,9 +161,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( "Cannot add: not a number" ), - frame ); + frame_pointer ); break; } break; @@ -173,10 +173,10 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, result = arg2; break; case INTEGERTV: - result = add_integer_ratio( frame, arg2, arg1 ); + result = add_integer_ratio( frame_pointer, arg2, arg1 ); break; case RATIOTV: - result = add_ratio_ratio( frame, arg1, arg2 ); + result = add_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -184,9 +184,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( "Cannot add: not a number" ), - frame ); + frame_pointer ); break; } break; @@ -197,8 +197,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, break; default: result = exceptionp( arg2 ) ? arg2 : - lisp_throw( c_string_to_lisp_string - ( "Cannot add: not a number" ), frame ); + throw_exception( c_string_to_lisp_string + ( "Cannot add: not a number" ), frame_pointer ); } } @@ -218,7 +218,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, * @return a pointer to an integer or real. */ struct cons_pointer lisp_add( struct stack_frame - *frame, struct + *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = make_integer( 0 ); struct cons_pointer tmp; @@ -227,7 +227,7 @@ struct cons_pointer lisp_add( struct stack_frame i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { tmp = result; - result = add_2( frame, result, frame->arg[i] ); + result = add_2( frame, frame_pointer, result, frame->arg[i] ); if ( !eq( tmp, result ) ) { dec_ref( tmp ); } @@ -236,7 +236,7 @@ struct cons_pointer lisp_add( struct stack_frame struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { tmp = result; - result = add_2( frame, result, c_car( more ) ); + result = add_2( frame, frame_pointer, result, c_car( more ) ); if ( !eq( tmp, result ) ) { dec_ref( tmp ); } @@ -252,7 +252,7 @@ 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`. */ -struct cons_pointer multiply_2( struct stack_frame *frame, +struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer result; @@ -286,7 +286,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, cell2.payload.integer.value ); break; case RATIOTV: - result = multiply_integer_ratio( frame, arg1, arg2 ); + result = multiply_integer_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -294,9 +294,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( "Cannot multiply: not a number" ), - frame ); + frame_pointer ); break; } break; @@ -306,10 +306,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = multiply_integer_ratio( frame, arg2, arg1 ); + result = multiply_integer_ratio( frame_pointer, arg2, arg1 ); break; case RATIOTV: - result = multiply_ratio_ratio( frame, arg1, arg2 ); + result = multiply_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -317,9 +317,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( "Cannot multiply: not a number" ), - frame ); + frame_pointer ); } break; case REALTV: @@ -328,9 +328,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( "Cannot multiply: not a number" ), - frame ); + frame_pointer ); break; } } @@ -353,7 +353,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, */ struct cons_pointer lisp_multiply( struct stack_frame - *frame, struct + *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = make_integer( 1 ); struct cons_pointer tmp; @@ -361,7 +361,7 @@ struct cons_pointer lisp_multiply( struct for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { tmp = result; - result = multiply_2( frame, result, frame->arg[i] ); + result = multiply_2( frame, frame_pointer, result, frame->arg[i] ); if ( !eq( tmp, result ) ) { dec_ref( tmp ); @@ -372,7 +372,7 @@ struct cons_pointer lisp_multiply( struct while ( consp( more ) && !exceptionp( result ) ) { tmp = result; - result = multiply_2( frame, result, c_car( more ) ); + result = multiply_2( frame, frame_pointer, result, c_car( more ) ); if ( !eq( tmp, result ) ) { dec_ref( tmp ); @@ -388,7 +388,7 @@ struct cons_pointer lisp_multiply( struct * return a cons_pointer indicating a number which is the * inverse of the number indicated by `arg`. */ -struct cons_pointer inverse( struct stack_frame *frame, +struct cons_pointer inverse( struct cons_pointer frame, struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -430,7 +430,7 @@ struct cons_pointer inverse( struct stack_frame *frame, */ struct cons_pointer lisp_subtract( struct stack_frame - *frame, struct + *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); @@ -451,10 +451,11 @@ struct cons_pointer lisp_subtract( struct break; case RATIOTV:{ struct cons_pointer tmp = - make_ratio( frame, frame->arg[0], + make_ratio( frame_pointer, frame->arg[0], make_integer( 1 ) ); + inc_ref(tmp); result = - subtract_ratio_ratio( frame, tmp, frame->arg[1] ); + subtract_ratio_ratio( frame_pointer, tmp, frame->arg[1] ); dec_ref( tmp ); } break; @@ -464,9 +465,9 @@ struct cons_pointer lisp_subtract( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( "Cannot subtract: not a number" ), + frame_pointer ); break; } break; @@ -477,16 +478,17 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV:{ struct cons_pointer tmp = - make_ratio( frame, frame->arg[1], + make_ratio( frame_pointer, frame->arg[1], make_integer( 1 ) ); + inc_ref(tmp); result = - subtract_ratio_ratio( frame, frame->arg[0], tmp ); + subtract_ratio_ratio( frame_pointer, frame->arg[0], tmp ); dec_ref( tmp ); } break; case RATIOTV: result = - subtract_ratio_ratio( frame, frame->arg[0], + subtract_ratio_ratio( frame_pointer, frame->arg[0], frame->arg[1] ); break; case REALTV: @@ -495,9 +497,9 @@ struct cons_pointer lisp_subtract( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( "Cannot subtract: not a number" ), + frame_pointer ); break; } break; @@ -507,8 +509,8 @@ struct cons_pointer lisp_subtract( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), frame ); + result = throw_exception( c_string_to_lisp_string + ( "Cannot subtract: not a number" ), frame_pointer ); break; } @@ -525,7 +527,7 @@ struct cons_pointer lisp_subtract( struct */ struct cons_pointer lisp_divide( struct stack_frame - *frame, struct + *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); @@ -542,8 +544,10 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer unsimplified = - make_ratio( frame, frame->arg[0], frame->arg[1] ); - result = simplify_ratio( frame, unsimplified ); + make_ratio( frame_pointer, 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 ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); } @@ -552,9 +556,9 @@ struct cons_pointer lisp_divide( struct case RATIOTV:{ struct cons_pointer one = make_integer( 1 ); struct cons_pointer ratio = - make_ratio( frame, frame->arg[0], one ); + make_ratio( frame_pointer, frame->arg[0], one ); result = - divide_ratio_ratio( frame, ratio, frame->arg[1] ); + divide_ratio_ratio( frame_pointer, ratio, frame->arg[1] ); dec_ref( ratio ); } break; @@ -564,9 +568,9 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( "Cannot divide: not a number" ), - frame ); + frame_pointer ); break; } break; @@ -577,16 +581,19 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer one = make_integer( 1 ); + inc_ref( one); struct cons_pointer ratio = - make_ratio( frame, frame->arg[1], one ); + make_ratio( frame_pointer, frame->arg[1], one ); + inc_ref(ratio); result = - divide_ratio_ratio( frame, frame->arg[0], ratio ); + divide_ratio_ratio( frame_pointer, frame->arg[0], ratio ); dec_ref( ratio ); + dec_ref(one); } break; case RATIOTV: result = - divide_ratio_ratio( frame, frame->arg[0], + divide_ratio_ratio( frame_pointer, frame->arg[0], frame->arg[1] ); break; case REALTV: @@ -595,9 +602,9 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( "Cannot divide: not a number" ), - frame ); + frame_pointer ); break; } break; @@ -607,8 +614,8 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot divide: not a number" ), frame ); + result = throw_exception( c_string_to_lisp_string + ( "Cannot divide: not a number" ), frame_pointer ); break; } diff --git a/src/arith/peano.h b/src/arith/peano.h index 79735c0..46008c2 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -23,7 +23,7 @@ extern "C" { * @return a pointer to an integer or real. */ struct cons_pointer - lisp_add( struct stack_frame *frame, struct cons_pointer env ); + lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Multiply an indefinite number of numbers together @@ -32,7 +32,7 @@ extern "C" { * @return a pointer to an integer or real. */ struct cons_pointer - lisp_multiply( struct stack_frame *frame, struct cons_pointer env ); + lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Subtract one number from another. @@ -41,7 +41,7 @@ extern "C" { * @return a pointer to an integer or real. */ struct cons_pointer - lisp_subtract( struct stack_frame *frame, struct cons_pointer env ); + lisp_subtract( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Divide one number by another. @@ -50,7 +50,7 @@ extern "C" { * @return a pointer to an integer or real. */ struct cons_pointer - lisp_divide( struct stack_frame *frame, struct cons_pointer env ); + lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); #ifdef __cplusplus } diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 8a5eec7..042aea1 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -13,6 +13,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "dump.h" #include "equal.h" #include "integer.h" #include "lispops.h" @@ -24,7 +25,7 @@ * declared in peano.c, can't include piano.h here because * circularity. TODO: refactor. */ -struct cons_pointer inverse( struct stack_frame *frame, +struct cons_pointer inverse( struct cons_pointer frame_pointer, struct cons_pointer arg ); /** @@ -54,7 +55,7 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { * be in a simplified representation. If `arg` isn't a ratio, * will throw exception. */ -struct cons_pointer simplify_ratio( struct stack_frame *frame, +struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg ) { struct cons_pointer result = arg; @@ -70,15 +71,15 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame, result = make_integer( ddrv / gcd ); } else { result = - make_ratio( frame, make_integer( ddrv / gcd ), + make_ratio( frame_pointer, make_integer( ddrv / gcd ), make_integer( drrv / gcd ) ); } } } else { result = - lisp_throw( make_cons( c_string_to_lisp_string + throw_exception( make_cons( c_string_to_lisp_string ( "Shouldn't happen: bad arg to simplify_ratio" ), - arg ), frame ); + arg ), frame_pointer ); } return result; @@ -91,7 +92,7 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame, * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * this is going to break horribly. */ -struct cons_pointer add_ratio_ratio( struct stack_frame *frame, +struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer r, result; @@ -123,7 +124,7 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, #endif if ( dr1v == dr2v ) { - r = make_ratio( frame, + r = make_ratio( frame_pointer, make_integer( dd1v + dd2v ), cell1.payload.ratio.divisor ); } else { @@ -131,10 +132,10 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, dr1vm = make_integer( dr1v * m1 ), dd2vm = make_integer( dd2v * m2 ), dr2vm = make_integer( dr2v * m2 ), - r1 = make_ratio( frame, dd1vm, dr1vm ), - r2 = make_ratio( frame, dd2vm, dr2vm ); + r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), + r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); - r = add_ratio_ratio( frame, r1, r2 ); + r = add_ratio_ratio( frame_pointer, r1, r2 ); /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were * never incremented except when making r1 and r2, decrementing @@ -143,17 +144,17 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, dec_ref( r2 ); } - result = simplify_ratio( frame, r ); + result = simplify_ratio( frame_pointer, r ); if ( !eq( r, result ) ) { dec_ref( r ); } } else { result = - lisp_throw( make_cons( c_string_to_lisp_string + throw_exception( make_cons( c_string_to_lisp_string ( "Shouldn't happen: bad arg to add_ratio_ratio" ), make_cons( arg1, make_cons( arg2, NIL ) ) ), - frame ); + frame_pointer ); } #ifdef DEBUG @@ -171,26 +172,26 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, * the intger indicated by `intarg` and the ratio indicated by * `ratarg`. If you pass other types, this is going to break horribly. */ -struct cons_pointer add_integer_ratio( struct stack_frame *frame, +struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame, intarg, one ); + ratio = make_ratio( frame_pointer, intarg, one ); - result = add_ratio_ratio( frame, ratio, ratarg ); + result = add_ratio_ratio( frame_pointer, ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); } else { result = - lisp_throw( make_cons( c_string_to_lisp_string + throw_exception( make_cons( c_string_to_lisp_string ( "Shouldn't happen: bad arg to add_integer_ratio" ), make_cons( intarg, make_cons( ratarg, NIL ) ) ), - frame ); + frame_pointer ); } return result; @@ -201,15 +202,15 @@ struct cons_pointer add_integer_ratio( struct stack_frame *frame, * 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. */ -struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, +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, + struct cons_pointer i = make_ratio( frame_pointer, pointer2cell( arg2 ).payload.ratio. divisor, pointer2cell( arg2 ).payload.ratio. dividend ), result = - multiply_ratio_ratio( frame, arg1, i ); + multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -221,9 +222,7 @@ struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * this is going to break horribly. */ -struct cons_pointer multiply_ratio_ratio( struct - stack_frame - *frame, struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer result; @@ -249,18 +248,18 @@ struct cons_pointer multiply_ratio_ratio( struct ddrv = dd1v * dd2v, drrv = dr1v * dr2v; struct cons_pointer unsimplified = - make_ratio( frame, make_integer( ddrv ), + make_ratio( frame_pointer, make_integer( ddrv ), make_integer( drrv ) ); - result = simplify_ratio( frame, unsimplified ); + result = simplify_ratio( frame_pointer, unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); } } else { result = - lisp_throw( c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), - frame ); + frame_pointer ); } return result; @@ -271,23 +270,23 @@ struct cons_pointer multiply_ratio_ratio( struct * the intger indicated by `intarg` and the ratio indicated by * `ratarg`. If you pass other types, this is going to break horribly. */ -struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, +struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame, intarg, one ); - result = multiply_ratio_ratio( frame, ratio, ratarg ); + ratio = make_ratio( frame_pointer, intarg, one ); + result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); } else { result = - lisp_throw( c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( "Shouldn't happen: bad arg to multiply_integer_ratio" ), - frame ); + frame_pointer ); } return result; @@ -299,11 +298,11 @@ struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * this is going to break horribly. */ -struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, +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, arg2 ), - result = add_ratio_ratio( frame, arg1, i ); + struct cons_pointer i = inverse( frame_pointer, arg2 ), + result = add_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -315,7 +314,7 @@ struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, * Construct a ratio frame from these two pointers, expected to be integers * or (later) bignums, in the context of this stack_frame. */ -struct cons_pointer make_ratio( struct stack_frame *frame, +struct cons_pointer make_ratio( struct cons_pointer frame_pointer, struct cons_pointer dividend, struct cons_pointer divisor ) { struct cons_pointer result; @@ -328,9 +327,9 @@ struct cons_pointer make_ratio( struct stack_frame *frame, cell->payload.ratio.divisor = divisor; } else { result = - lisp_throw( c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( "Dividend and divisor of a ratio must be integers" ), - frame ); + frame_pointer ); } #ifdef DEBUG dump_object( stderr, result ); diff --git a/src/arith/ratio.h b/src/arith/ratio.h index c4e5548..feb8925 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -11,36 +11,34 @@ #ifndef __ratio_h #define __ratio_h -struct cons_pointer simplify_ratio( struct stack_frame *frame, +struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg ); -struct cons_pointer add_ratio_ratio( struct stack_frame *frame, +struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer add_integer_ratio( struct stack_frame *frame, +struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, +struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_ratio_ratio( struct - stack_frame - *frame, struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, +struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, +struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer make_ratio( struct stack_frame *frame, +struct cons_pointer make_ratio( struct cons_pointer frame_pointer, struct cons_pointer dividend, struct cons_pointer divisor ); diff --git a/src/init.c b/src/init.c index 9716365..48516f6 100644 --- a/src/init.c +++ b/src/init.c @@ -90,6 +90,7 @@ int main( int argc, char *argv[] ) { bind_function( "eq", &lisp_eq ); bind_function( "equal", &lisp_equal ); bind_function( "eval", &lisp_eval ); + bind_function( "exception", &lisp_exception ); bind_function( "multiply", &lisp_multiply ); bind_function( "read", &lisp_read ); bind_function( "oblist", &lisp_oblist ); @@ -98,6 +99,7 @@ int main( int argc, char *argv[] ) { bind_function( "reverse", &lisp_reverse ); bind_function( "set", &lisp_set ); bind_function( "subtract", &lisp_subtract ); + bind_function( "throw", &lisp_exception ); bind_function( "type", &lisp_type ); bind_function( "+", &lisp_add ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 39f464a..75a5257 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -63,98 +63,6 @@ void dec_ref( struct cons_pointer pointer ) { } } -void dump_string_cell( 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 ); - } 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: " ); - print( output, pointer ); - fwprintf( output, L"\n" ); - } -} - -/** - * dump the object at this cons_pointer to this output stream. - */ -void dump_object( FILE * output, struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - fwprintf( output, - L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n", - cell.tag.bytes[0], - cell.tag.bytes[1], - cell.tag.bytes[2], - cell.tag.bytes[3], - 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\n", - cell.payload.cons.car.page, - cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset, cell.count ); - break; - case EXCEPTIONTV: - fwprintf( output, L"\t\tException cell: " ); - print( output, cell.payload.exception.message ); - fwprintf( output, L"\n" ); - for ( struct stack_frame * frame = cell.payload.exception.frame; - frame != NULL; frame = frame->previous ) { - dump_frame( output, frame ); - } - 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 ); - break; - case INTEGERTV: - fwprintf( output, - L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); - break; - case LAMBDATV: - fwprintf( output, L"\t\tLambda cell; args: " ); - print( output, cell.payload.lambda.args ); - fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - 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 ); - break; - case READTV: - fwprintf( output, L"\t\tInput stream\n" ); - case REALTV: - 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; - } -} /** * Construct a cons cell from this pair of pointers. @@ -178,20 +86,24 @@ struct cons_pointer make_cons( struct cons_pointer car, /** * Construct an exception cell. * @param message should be a lisp string describing the problem, but actually any cons pointer will do; - * @param frame should be the frame in which the exception occurred. + * @param frame_pointer should be the pointer to the frame in which the exception occurred. */ struct cons_pointer make_exception( struct cons_pointer message, - struct stack_frame *frame ) { - struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); - struct cons_space_object *cell = &pointer2cell( pointer ); + struct cons_pointer frame_pointer ) { + struct cons_pointer result = NIL; + 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 ); - cell->payload.exception.message = message; - cell->payload.exception.frame = frame; + inc_ref( message ); + inc_ref( frame_pointer); + cell->payload.exception.message = message; + cell->payload.exception.frame = frame_pointer; - return pointer; + result = pointer; + + return result; } @@ -200,7 +112,8 @@ struct cons_pointer make_exception( struct cons_pointer message, */ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct stack_frame *, struct cons_pointer ) ) { + ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -298,7 +211,8 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct stack_frame * frame, struct cons_pointer env ) ) { + ( 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 ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 43bdfe0..b31a0bf 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -278,13 +278,14 @@ struct cons_pointer { * here to avoid circularity. TODO: refactor. */ struct stack_frame { - struct stack_frame *previous; /* the previous frame */ + struct cons_pointer previous; /* the previous frame */ 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 */ + int args; }; /** @@ -311,7 +312,7 @@ struct cons_payload { */ struct exception_payload { struct cons_pointer message; - struct stack_frame *frame; + struct cons_pointer frame; }; /** @@ -326,6 +327,7 @@ struct exception_payload { struct function_payload { struct cons_pointer source; struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ); }; @@ -379,13 +381,11 @@ struct real_payload { * 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). - * - * NOTE that this means that special forms do not appear on the lisp stack, - * which may be confusing. TODO: think about this. */ struct special_payload { struct cons_pointer source; struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ); }; @@ -421,7 +421,8 @@ struct vectorp_payload { * tag. */ uint32_t value; /* the tag considered as a number */ } tag; - uint64_t address; /* the address of the actual vector space + struct vector_space_object * address; + /* the address of the actual vector space * object (TODO: will change when I actually * implement vector space) */ }; @@ -514,20 +515,11 @@ void inc_ref( struct cons_pointer pointer ); */ void dec_ref( struct cons_pointer pointer ); -/** - * dump the object at this cons_pointer to this output stream. - */ -void dump_object( FILE * output, struct cons_pointer pointer ); - struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ); -/** - * Construct an exception cell. - * @param message should be a lisp string describing the problem, but actually any cons pointer will do; - * @param frame should be the frame in which the exception occurred. - */ + struct cons_pointer make_exception( struct cons_pointer message, - struct stack_frame *frame ); + struct cons_pointer frame_pointer ); /** * Construct a cell which points to an executable Lisp special form. @@ -535,6 +527,7 @@ struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ); /** @@ -550,20 +543,13 @@ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ); -/** - * Construct a ratio frame from these two pointers, expected to be integers - * or (later) bignums, in the context of this stack_frame. - */ -struct cons_pointer make_ratio( struct stack_frame *frame, - struct cons_pointer dividend, - struct cons_pointer divisor ); - /** * 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 ) ); /** diff --git a/src/memory/dump.c b/src/memory/dump.c new file mode 100644 index 0000000..5306801 --- /dev/null +++ b/src/memory/dump.c @@ -0,0 +1,120 @@ +/* + * dump.c + * + * Dump representations of both cons space and vector space objects. + * + * + * (c) 2018 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "print.h" +#include "stack.h" +#include "vectorspace.h" + + +void dump_string_cell( 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 ); + } 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: " ); + print( output, pointer ); + fwprintf( output, L"\n" ); + } +} + +/** + * dump the object at this cons_pointer to this output stream. + */ +void dump_object( FILE * output, struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + fwprintf( output, + L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n", + cell.tag.bytes[0], + cell.tag.bytes[1], + cell.tag.bytes[2], + cell.tag.bytes[3], + 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\n", + cell.payload.cons.car.page, + cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); + break; + case EXCEPTIONTV: + 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 ); + break; + case INTEGERTV: + fwprintf( output, + L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); + break; + case LAMBDATV: + fwprintf( output, L"\t\tLambda cell; args: " ); + print( output, cell.payload.lambda.args ); + fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + 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 ); + break; + case READTV: + fwprintf( output, L"\t\tInput stream\n" ); + case REALTV: + 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 VECTORPOINTTV: { + struct vector_space_object * vso = cell.payload.vectorp.address; + fwprintf( output, L"\t\tVector space object of type %4.4s, payload size %d bytes\n", + vso->header.tag, vso->header.size); + } + break; + } +} diff --git a/src/memory/dump.h b/src/memory/dump.h new file mode 100644 index 0000000..e49f453 --- /dev/null +++ b/src/memory/dump.h @@ -0,0 +1,29 @@ +/** + * dump.h + * + * Dump representations of both cons space and vector space objects. + * + * (c) 2018 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#ifndef __dump_h +#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 1bb8b1b..8fe268e 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -11,9 +11,6 @@ * with freelists to a more general 'equal sized object pages', so that * allocating/freeing stack frames can be more efficient. * - * Stack frames are not yet a first class object; they have no VECP pointer - * in cons space. - * * (c) 2017 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. */ @@ -25,87 +22,128 @@ #include "lispops.h" #include "print.h" #include "stack.h" +#include "vectorspace.h" + +/** + * get the actual stackframe object from this `pointer`, or NULL if + * `pointer` is not a stackframe pointer. + */ +struct stack_frame * get_stack_frame(struct cons_pointer pointer) { + struct stack_frame * result = NULL; + struct vector_space_object * vso = + pointer2cell(pointer).payload.vectorp.address; + + if (vectorpointp(pointer) && stackframep(vso)) + { + result = (struct stack_frame *) &(vso->payload); + } + + return result; +} /** * Make an empty stack frame, and return it. * @param previous the current top-of-stack; * @param env the environment in which evaluation happens. - * @return the new frame. + * @return the new frame, or NULL if memory is exhausted. */ -struct stack_frame *make_empty_frame( struct stack_frame *previous, - struct cons_pointer env ) { - struct stack_frame *result = malloc( sizeof( struct stack_frame ) ); +struct cons_pointer make_empty_frame( struct cons_pointer previous ) { + struct cons_pointer result = make_vso(STACKFRAMETAG, sizeof(struct stack_frame)); + if (!nilp(result)) { + struct stack_frame *frame = get_stack_frame(result); /* * TODO: later, pop a frame off a free-list of stack frames */ - result->previous = previous; + frame->previous = previous; + inc_ref(previous); /* * clearing the frame with memset would probably be slightly quicker, but * this is clear. */ - result->more = NIL; - result->function = NIL; + frame->more = NIL; + frame->function = NIL; + frame->args = 0; for ( int i = 0; i < args_in_frame; i++ ) { - set_reg( result, i, NIL ); + set_reg( frame, i, NIL ); } + } return result; } - /** * Allocate a new stack frame with its previous pointer set to this value, * its arguments set up from these args, evaluated in this env. * @param previous the current top-of-stack; * @args the arguments to load into this frame; * @param env the environment in which evaluation happens. - * @return the new frame. + * @return the new frame, or an exception if one occurred while building it. */ -struct stack_frame *make_stack_frame( struct stack_frame *previous, - struct cons_pointer args, - struct cons_pointer env, - struct cons_pointer *exception ) { - struct stack_frame *result = make_empty_frame( previous, env ); +struct cons_pointer make_stack_frame( struct cons_pointer previous, + struct cons_pointer args, + struct cons_pointer env ) { + struct cons_pointer result = make_empty_frame( previous ); - for ( int i = 0; i < args_in_frame && consp( args ); i++ ) { - /* iterate down the arg list filling in the arg slots in the + if (nilp(result)) + { + /* i.e. out of memory */ + result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous); + } else { + struct stack_frame * frame = get_stack_frame(result); + + for ( frame->args = 0; frame->args < args_in_frame && consp( args ); frame->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 */ - struct cons_space_object cell = pointer2cell( args ); + struct cons_space_object cell = pointer2cell( args ); - /* + /* * 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 */ - struct stack_frame *arg_frame = make_empty_frame( result, env ); + struct cons_pointer arg_frame_pointer = make_empty_frame( result); + inc_ref(arg_frame_pointer); + + if(nilp(arg_frame_pointer)) { + result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous); + break; + } else { + struct stack_frame *arg_frame = get_stack_frame( arg_frame_pointer ); set_reg( arg_frame, 0, cell.payload.cons.car ); - struct cons_pointer val = lisp_eval( arg_frame, env ); + struct cons_pointer val = lisp_eval( arg_frame, arg_frame_pointer, env ); if ( exceptionp( val ) ) { - exception = &val; - break; + result = val; + break; } else { - set_reg( result, i, val ); + set_reg( frame, frame->args, val ); } - free_stack_frame( arg_frame ); + dec_ref(arg_frame_pointer); args = cell.payload.cons.cdr; + } } - if ( consp( args ) ) { + if (!exceptionp(result)) { + if ( consp( args ) ) { /* if we still have args, eval them and stick the values on `more` */ - struct cons_pointer more = eval_forms( previous, args, env ); - result->more = more; + struct cons_pointer more = eval_forms( get_stack_frame(previous), previous, args, env ); + frame->more = more; inc_ref( more ); - } + } - dump_frame( stderr, result ); - return result; +#ifdef DEBUG + dump_frame( stderr, result ); +#endif + } + } + + return result; } /** @@ -116,25 +154,39 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, * @param env the execution environment; * @return a new special frame. */ -struct stack_frame *make_special_frame( struct stack_frame *previous, +struct cons_pointer make_special_frame( struct cons_pointer previous, struct cons_pointer args, struct cons_pointer env ) { - struct stack_frame *result = make_empty_frame( previous, env ); + struct cons_pointer result = make_empty_frame( previous ); - for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) { + if (nilp(result)) + { + /* i.e. out of memory */ + result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous); + } else { + struct stack_frame * frame = get_stack_frame(result); + + for ( frame->args = 0; frame->args < args_in_frame && !nilp( args ); frame->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 */ struct cons_space_object cell = pointer2cell( args ); - set_reg( result, i, cell.payload.cons.car ); + set_reg( frame, frame->args, cell.payload.cons.car ); args = cell.payload.cons.cdr; } - if ( consp( args ) ) { - result->more = args; + if (!exceptionp(result)) { + if ( consp( args ) ) { + frame->more = args; inc_ref( args ); + } + +#ifdef DEBUG + dump_frame( stderr, result ); +#endif } + } return result; } @@ -160,26 +212,41 @@ void free_stack_frame( struct stack_frame *frame ) { /** * Dump a stackframe to this stream for debugging * @param output the stream - * @param frame the frame + * @param frame_pointer the pointer to the frame */ -void dump_frame( FILE * output, struct stack_frame *frame ) { - fputws( L"Dumping stack frame\n", output ); - for ( int arg = 0; arg < args_in_frame; arg++ ) { - struct cons_space_object cell = pointer2cell( frame->arg[arg] ); +void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { + struct stack_frame *frame = get_stack_frame(frame_pointer); - 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 ); + if (frame != NULL) { + for ( int arg = 0; arg < frame->args; arg++ ) { + struct cons_space_object cell = pointer2cell( frame->arg[arg] ); - print( output, frame->arg[arg] ); - fputws( L"\n", output ); + 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 ); } fputws( L"More: \t", output ); print( output, frame->more ); fputws( L"\n", output ); + } } +void dump_stack_trace(FILE * output, struct cons_pointer pointer) { + if (exceptionp(pointer)) { + print( output, pointer2cell(pointer).payload.exception.message ); + fwprintf( output, L"\n" ); + dump_stack_trace(output, pointer2cell(pointer).payload.exception.frame); + } else { + while (vectorpointp(pointer) && stackframep(pointer_to_vso(pointer))) { + dump_frame( output, pointer); + pointer = get_stack_frame(pointer)->previous; + } + } +} /** * Fetch a pointer to the value of the local variable at this index. diff --git a/src/memory/stack.h b/src/memory/stack.h index d708b39..df76849 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -24,46 +24,40 @@ #ifndef __stack_h #define __stack_h +/** + * macros for the tag of a stack frame. + */ +#define STACKFRAMETAG "STAK" +#define STACKFRAMETV 1262572627 + +/** + * is this vector-space object a stack frame? + */ +#define stackframep(vso)(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) +struct stack_frame * get_stack_frame(struct cons_pointer pointer); -/** - * Make an empty stack frame, and return it. - * @param previous the current top-of-stack; - * @param env the environment in which evaluation happens. - * @return the new frame. - */ -struct stack_frame *make_empty_frame( struct stack_frame *previous, - struct cons_pointer env ); +struct cons_pointer make_empty_frame( struct cons_pointer previous ); + +struct cons_pointer make_stack_frame( struct cons_pointer previous, + struct cons_pointer args, + struct cons_pointer env ); -struct stack_frame *make_stack_frame( struct stack_frame *previous, - struct cons_pointer args, - struct cons_pointer env, - struct cons_pointer *exception ); void free_stack_frame( struct stack_frame *frame ); -/** - * Dump a stackframe to this stream for debugging - * @param output the stream - * @param frame the frame - */ -void dump_frame( FILE * output, struct stack_frame *frame ); +void dump_frame( FILE * output, struct cons_pointer pointer ); + +void dump_stack_trace(FILE * output, struct cons_pointer frame_pointer); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); -/** - * A 'special' frame is exactly like a normal stack frame except that the - * arguments are unevaluated. - * @param previous the previous stack frame; - * @param args a list of the arguments to be stored in this stack frame; - * @param env the execution environment; - * @return a new special frame. - */ -struct stack_frame *make_special_frame( struct stack_frame *previous, +struct cons_pointer make_special_frame( struct cons_pointer previous, struct cons_pointer args, struct cons_pointer env ); diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 4b18b96..c0b6f8d 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -8,6 +8,7 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include #include @@ -29,7 +30,7 @@ * NOTE that `tag` should be the vector-space tag of the particular type of * vector-space object, NOT `VECTORPOINTTAG`. */ -struct cons_pointer make_vec_pointer( char *tag, uint64_t address ) { +struct cons_pointer make_vec_pointer( char * tag, struct vector_space_object * address ) { struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object cell = pointer2cell( pointer ); @@ -44,26 +45,33 @@ struct cons_pointer make_vec_pointer( char *tag, uint64_t address ) { * 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. */ -struct cons_pointer make_vso( char *tag, int64_t payload_size ) { +struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { struct cons_pointer result = NIL; int64_t total_size = sizeof( struct vector_space_header ) + payload_size; - struct vector_space_header *vso = malloc( total_size ); + /* Pad size to 64 bit words. This is intended to promote access efficiancy + * on 64 bit machines but may just be voodoo coding */ + uint64_t padded = ceil((total_size * 8.0) / 8.0); + struct vector_space_object *vso = malloc( padded ); if ( vso != NULL ) { - strncpy( &vso->tag.bytes[0], tag, TAGLENGTH ); - vso->vecp = make_vec_pointer( tag, ( uint64_t ) vso ); - vso->size = payload_size; + strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); + vso->header.vecp = make_vec_pointer( tag, vso ); + vso->header.size = payload_size; #ifdef DEBUG fwprintf( stderr, - L"Allocated vector-space object of type %s, total size %ld, payload size %ld\n", + L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld\n", tag, total_size, payload_size ); + if (padded != total_size){ + fwprintf(stderr, L"\t\tPadded from %d to %d\n", + total_size, padded); + } #endif - result = vso->vecp; + result = vso->header.vecp; } - return result; } diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 07a0b91..83fa74c 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -34,20 +34,16 @@ #define NAMESPACETAG "NMSP" #define NAMESPACETV 0 -/* - * a stack frame. - */ -#define STACKFRAMETAG "STAK" -#define STACKFRAMETV /* * a vector of cons pointers. */ #define VECTORTAG "VECT" #define VECTORTV 0 -#define pointer_to_vso(pointer)(vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : 0) +#define pointer_to_vso(pointer)((vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : NULL)) +#define vso_get_vecp(vso)((vso->header.vecp)) -struct cons_pointer make_vso( char *tag, int64_t payload_size ); +struct cons_pointer make_vso( char *tag, uint64_t payload_size ); struct vector_space_header { union { @@ -62,8 +58,10 @@ struct vector_space_header { 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 */ - char mark; /* mark bit for marking/sweeping the - * heap (not in this version) */ +}; + +struct vector_space_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 diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 9b12faa..825222f 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -80,6 +80,7 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) { * @return the result of evaluating the form. */ struct cons_pointer eval_form( struct stack_frame *parent, + struct cons_pointer parent_pointer, struct cons_pointer form, struct cons_pointer env ) { fputws( L"eval_form: ", stderr ); @@ -87,15 +88,19 @@ struct cons_pointer eval_form( struct stack_frame *parent, fputws( L"\n", stderr ); struct cons_pointer result = NIL; - struct stack_frame *next = make_empty_frame( parent, env ); + 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 ); - result = lisp_eval( next, 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. */ - free_stack_frame( next ); + dec_ref(next_pointer); } return result; @@ -106,12 +111,13 @@ struct cons_pointer eval_form( struct stack_frame *parent, * and this `env`, and return a list of their values. If the arg passed as * `list` is not in fact a list, return nil. */ -struct cons_pointer eval_forms( struct stack_frame *frame, +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, c_car( list ), env ), - eval_forms( frame, c_cdr( list ), env ) ) : NIL; + make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), + eval_forms( frame, frame_pointer, c_cdr( list ), env ) ) : NIL; } /** @@ -120,7 +126,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame, * (oblist) */ struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) { +lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { return oblist; } @@ -153,7 +159,7 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { * @param env the environment in which it is to be intepreted. */ struct cons_pointer -lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) { +lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { return make_lambda( frame->arg[0], compose_body( frame ) ); } @@ -164,7 +170,7 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) { * @param env the environment in which it is to be intepreted. */ struct cons_pointer -lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) { +lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { return make_nlambda( frame->arg[0], compose_body( frame ) ); } @@ -182,7 +188,7 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) { * Evaluate a lambda or nlambda expression. */ struct cons_pointer -eval_lambda( struct cons_space_object cell, struct stack_frame *frame, +eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; fwprintf( stderr, L"eval_lambda called\n" ); @@ -206,10 +212,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } 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 */ struct cons_pointer vals = frame->more; for ( int i = args_in_frame - 1; i >= 0; i-- ) { - struct cons_pointer val = eval_form( frame, frame->arg[i], env ); + struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[i], env ); if ( nilp( val ) && nilp( vals ) ) { /* nothing */ } else { @@ -223,8 +230,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, while ( !nilp( body ) ) { struct cons_pointer sexpr = c_car( body ); body = c_cdr( body ); +#ifdef DEBUG fputws( L"In lambda: ", stderr ); - result = eval_form( frame, sexpr, new_env ); +#endif + result = eval_form( frame, frame_pointer, sexpr, new_env ); } return result; @@ -239,17 +248,23 @@ 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 env ) { +c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct stack_frame *fn_frame = make_empty_frame( frame, env ); + + /* construct a child frame and within it evaluate the first argument - the + * argument in the function position. */ + struct cons_pointer fn_frame_pointer = make_empty_frame( frame_pointer ); + inc_ref( fn_frame_pointer); + struct stack_frame *fn_frame = get_stack_frame(fn_frame_pointer); + set_reg( fn_frame, 0, c_car( frame->arg[0] ) ); - struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); + struct cons_pointer fn_pointer = lisp_eval( fn_frame, fn_frame_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. */ - free_stack_frame( fn_frame ); + dec_ref(fn_frame_pointer); } struct cons_space_object fn_cell = pointer2cell( fn_pointer ); @@ -263,67 +278,66 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { case FUNCTIONTV: { struct cons_pointer exep = NIL; - struct stack_frame *next = - make_stack_frame( frame, args, env, &exep ); - result = ( *fn_cell.payload.special.executable ) ( next, env ); - if ( exceptionp( exep ) ) { - /* 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. */ - result = exep; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref(next_pointer); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; } else { - free_stack_frame( next ); + 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 stack_frame *next = - make_stack_frame( frame, args, env, &exep ); -#ifdef DEBUG - fputws( L"Stack frame for lambda\n", stderr ); - dump_frame( stderr, next ); -#endif - result = eval_lambda( fn_cell, next, 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. */ - result = exep; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref(next_pointer); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; } else { - free_stack_frame( next ); + 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 stack_frame *next = - make_special_frame( frame, args, env ); -#ifdef DEBUG - fputws( L"Stack frame for nlambda\n", stderr ); - dump_frame( stderr, next ); -#endif - result = eval_lambda( fn_cell, next, env ); + 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(frame_pointer); + result = eval_lambda( fn_cell, 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. */ - free_stack_frame( next ); + dec_ref(next_pointer); } + } } break; case SPECIALTV: { - struct stack_frame *next = - make_special_frame( frame, args, env ); - result = ( *fn_cell.payload.special.executable ) ( next, env ); + 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(frame_pointer); + result = ( *fn_cell.payload.special.executable ) ( 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. */ - free_stack_frame( next ); + dec_ref(next_pointer); } + } } break; default: @@ -338,9 +352,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer message = c_string_to_lisp_string( buffer ); free( buffer ); - result = lisp_throw( message, frame ); + result = throw_exception( message, frame_pointer ); } } + dec_ref(fn_frame_pointer); return result; } @@ -378,19 +393,19 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { * If a special form, passes the cdr of s_expr to the special form as argument. */ struct cons_pointer -lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { +lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = frame->arg[0]; struct cons_space_object cell = pointer2cell( frame->arg[0] ); #ifdef DEBUG fputws( L"Eval: ", stderr ); - dump_frame( stderr, frame ); + dump_frame( stderr, frame_pointer ); #endif switch ( cell.tag.value ) { case CONSTV: { - result = c_apply( frame, env ); + result = c_apply( frame, frame_pointer, env ); } break; @@ -403,7 +418,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { make_cons( c_string_to_lisp_string ( "Attempt to take value of unbound symbol." ), frame->arg[0] ); - result = lisp_throw( message, frame ); + result = throw_exception( message, frame_pointer ); } else { result = c_assoc( canonical, env ); inc_ref( result ); @@ -441,15 +456,15 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { * the second argument */ struct cons_pointer -lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { +lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { #ifdef DEBUG fputws( L"Apply: ", stderr ); - dump_frame( stderr, frame ); + dump_frame( stderr, frame_pointer ); #endif set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); set_reg( frame, 1, NIL ); - struct cons_pointer result = c_apply( frame, env ); + struct cons_pointer result = c_apply( frame, frame_pointer, env ); #ifdef DEBUG fputws( L"Apply returning ", stderr ); @@ -469,7 +484,7 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { * this isn't at this stage checked) unevaluated. */ struct cons_pointer -lisp_quote( struct stack_frame *frame, struct cons_pointer env ) { +lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { return frame->arg[0]; } @@ -484,7 +499,7 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) { * the namespace in so doing. `namespace` defaults to the value of `oblist`. */ struct cons_pointer -lisp_set( struct stack_frame *frame, struct cons_pointer env ) { +lisp_set( 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]; @@ -497,7 +512,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) { make_exception( make_cons ( c_string_to_lisp_string ( "The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), frame ); + make_cons( frame->arg[0], NIL ) ), frame_pointer ); } return result; @@ -514,13 +529,13 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) { * the namespace in so doing. `namespace` defaults to the value of `oblist`. */ struct cons_pointer -lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { +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]; if ( symbolp( frame->arg[0] ) ) { - struct cons_pointer val = eval_form( frame, frame->arg[1], env ); + struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[1], env ); deep_bind( frame->arg[0], val ); result = val; } else { @@ -528,7 +543,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { make_exception( make_cons ( c_string_to_lisp_string ( "The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), frame ); + make_cons( frame->arg[0], NIL ) ), frame_pointer ); } return result; @@ -543,7 +558,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { * otherwise returns a new cons cell. */ struct cons_pointer -lisp_cons( struct stack_frame *frame, struct cons_pointer env ) { +lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer car = frame->arg[0]; struct cons_pointer cdr = frame->arg[1]; struct cons_pointer result; @@ -567,7 +582,7 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer env ) { * strings, and TODO read streams and other things which can be considered as sequences. */ struct cons_pointer -lisp_car( struct stack_frame *frame, struct cons_pointer env ) { +lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; if ( consp( frame->arg[0] ) ) { @@ -579,7 +594,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) { } else { struct cons_pointer message = c_string_to_lisp_string( "Attempt to take CAR of non sequence" ); - result = lisp_throw( message, frame ); + result = throw_exception( message, frame_pointer ); } return result; @@ -591,7 +606,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) { * strings, and TODO read streams and other things which can be considered as sequences. */ struct cons_pointer -lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { +lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; if ( consp( frame->arg[0] ) ) { @@ -603,7 +618,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { } else { struct cons_pointer message = c_string_to_lisp_string( "Attempt to take CDR of non sequence" ); - result = lisp_throw( message, frame ); + result = throw_exception( message, frame_pointer ); } return result; @@ -614,7 +629,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { * Returns the value associated with key in store, or NIL if not found. */ struct cons_pointer -lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) { +lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { return c_assoc( frame->arg[0], frame->arg[1] ); } @@ -622,7 +637,7 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) { * (eq a b) * Returns 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 lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } @@ -632,7 +647,7 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, * Returns T if a and b are pointers to structurally identical objects, else NIL */ struct cons_pointer -lisp_equal( struct stack_frame *frame, struct cons_pointer env ) { +lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } @@ -643,14 +658,14 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer env ) { * is a read stream, then read from that stream, else stdin. */ struct cons_pointer -lisp_read( struct stack_frame *frame, struct cons_pointer env ) { +lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { FILE *input = stdin; if ( readp( frame->arg[0] ) ) { input = pointer2cell( frame->arg[0] ).payload.stream.stream; } - return read( frame, input ); + return read( frame, frame_pointer, input ); } @@ -683,7 +698,7 @@ 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. */ -struct cons_pointer lisp_reverse( struct stack_frame *frame, +struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { return c_reverse( frame->arg[0] ); } @@ -696,7 +711,10 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, * is a write stream, then print to that stream, else stdout. */ struct cons_pointer -lisp_print( struct stack_frame *frame, struct cons_pointer env ) { +lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +#ifdef DEBUG + fputws(L"Entering print\n", stderr); +#endif struct cons_pointer result = NIL; FILE *output = stdout; @@ -706,9 +724,11 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) { result = print( output, frame->arg[0] ); +#ifdef DEBUG fputws( L"Print returning ", stderr ); - print( stderr, result ); + // print( stderr, result ); fputws( L"\n", stderr ); +#endif return result; } @@ -721,7 +741,7 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) { * @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 env ) { +lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { return c_type( frame->arg[0] ); } @@ -739,16 +759,16 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) { * argument. */ struct cons_pointer -lisp_progn( struct stack_frame *frame, struct cons_pointer env ) { +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++ ) { - result = eval_form( frame, frame->arg[i], env ); + result = eval_form( frame, frame_pointer, frame->arg[i], env ); } while ( consp( remaining ) ) { - result = eval_form( frame, c_car( remaining ), env ); + result = eval_form( frame, frame_pointer, c_car( remaining ), env ); remaining = c_cdr( remaining ); } @@ -766,7 +786,7 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) { * @return the value of the last form of the first successful clause. */ struct cons_pointer -lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; bool done = false; @@ -777,11 +797,11 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { if ( consp( clause_pointer ) ) { struct cons_space_object cell = pointer2cell( clause_pointer ); - result = eval_form( frame, c_car( clause_pointer ), env ); + result = eval_form( frame, frame_pointer, c_car( clause_pointer ), env ); if ( !nilp( result ) ) { struct cons_pointer vals = - eval_forms( frame, c_cdr( clause_pointer ), env ); + eval_forms( frame, frame_pointer,c_cdr( clause_pointer ), env ); while ( consp( vals ) ) { result = c_car( vals ); @@ -793,9 +813,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { } else if ( nilp( clause_pointer ) ) { done = true; } else { - result = lisp_throw( c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( "Arguments to `cond` must be lists" ), - frame ); + frame_pointer); } } /* TODO: if there are more than 8 clauses we need to continue into the @@ -805,15 +825,17 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { } /** - * TODO: make this do something sensible somehow. - * This requires that a frame be a heap-space object with a cons-space + * 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. * object pointing to it. Then this should become a normal lisp function * which expects a normally bound frame and environment, such that * frame->arg[0] is the message, and frame->arg[1] is the cons-space * pointer to the frame in which the exception occurred. */ struct cons_pointer -lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { +throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer ) { fwprintf( stderr, L"\nERROR: " ); print( stderr, message ); struct cons_pointer result = NIL; @@ -823,8 +845,23 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { if ( cell.tag.value == EXCEPTIONTV ) { result = message; } else { - result = make_exception( message, frame ); + result = make_exception( message, frame_pointer ); } return result; } + +/** + * (exception ) + * + * Function. Returns 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. + * If `message` is itself an exception, returns that instead. + */ +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, frame->previous); +} diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 961cf2e..059255d 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -51,6 +51,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg ); * @return the result of evaluating the form. */ struct cons_pointer eval_form( struct stack_frame *parent, + struct cons_pointer parent_pointer, struct cons_pointer form, struct cons_pointer env ); @@ -59,7 +60,7 @@ struct cons_pointer eval_form( struct stack_frame *parent, * and this `env`, and return a list of their values. If the arg passed as * `list` is not in fact a list, return nil. */ -struct cons_pointer eval_forms( struct stack_frame *frame, +struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer list, struct cons_pointer env ); @@ -67,19 +68,19 @@ struct cons_pointer eval_forms( struct stack_frame *frame, /* * special forms */ -struct cons_pointer lisp_eval( struct stack_frame *frame, +struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_apply( struct stack_frame *frame, +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 env ); +lisp_oblist( 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 env ); +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 env ); +lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Construct an interpretable function. @@ -88,7 +89,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ); * @param lexpr the lambda expression to be interpreted; * @param env the environment in which it is to be intepreted. */ -struct cons_pointer lisp_lambda( struct stack_frame *frame, +struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); /** @@ -98,31 +99,31 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame, * @param env the environment in which it is to be intepreted. */ struct cons_pointer -lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ); +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 lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); /* * functions */ -struct cons_pointer lisp_cons( struct stack_frame *frame, +struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_car( struct stack_frame *frame, +struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_cdr( 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 lisp_assoc( 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 lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_equal( struct stack_frame *frame, +struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_print( struct stack_frame *frame, +struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_read( 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_reverse( struct stack_frame *frame, +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. @@ -131,7 +132,7 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, * @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 env ); +lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); /** @@ -145,7 +146,7 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ); * argument. */ struct cons_pointer -lisp_progn( struct stack_frame *frame, struct cons_pointer env ); +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 @@ -157,10 +158,16 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ); * @return the value of the last form of the first successful clause. */ struct cons_pointer -lisp_cond( struct stack_frame *frame, struct cons_pointer env ); +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -/* - * neither, at this stage, really +/** + * 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. */ -struct cons_pointer lisp_throw( struct cons_pointer message, - struct stack_frame *frame ); +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 ); diff --git a/src/ops/print.c b/src/ops/print.c index 4ec5a15..7efd59f 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -20,6 +20,7 @@ #include "conspage.h" #include "consspaceobject.h" #include "integer.h" +#include "stack.h" #include "print.h" /** @@ -118,12 +119,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case EXCEPTIONTV: fwprintf( output, L"\n%sException: ", print_use_colours ? "\x1B[31m" : "" ); - if ( stringp( cell.payload.exception.message ) ) { - print_string_contents( output, - cell.payload.exception.message ); - } else { - print( output, cell.payload.exception.message ); - } + dump_stack_trace(output, pointer); break; case FUNCTIONTV: fwprintf( output, L"(Function)" ); diff --git a/src/ops/read.c b/src/ops/read.c index bd063b2..1a09700 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -25,6 +25,7 @@ #include "ratio.h" #include "read.h" #include "real.h" +#include "vectorspace.h" /* * for the time being things which may be read are: strings numbers - either @@ -32,9 +33,11 @@ * atoms because I don't yet know what an atom is or how it's stored. */ -struct cons_pointer read_number( struct stack_frame *frame, FILE * input, +struct cons_pointer read_number( struct stack_frame *frame, + struct cons_pointer frame_pointer, FILE * input, wint_t initial, bool seen_period ); -struct cons_pointer read_list( struct stack_frame *frame, FILE * input, +struct cons_pointer read_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, 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 ); @@ -52,7 +55,7 @@ struct cons_pointer c_quote( struct cons_pointer arg ) { * treating this initial character as the first character of the object * representation. */ -struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, +struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, FILE * input, wint_t initial ) { struct cons_pointer result = NIL; @@ -64,7 +67,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, if ( feof( input ) ) { result = make_exception( c_string_to_lisp_string - ( "End of file while reading" ), frame ); + ( "End of file while reading" ), frame_pointer ); } else { switch ( c ) { case ';': @@ -72,16 +75,16 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, /* skip all characters from semi-colon to the end of the line */ break; case EOF: - result = lisp_throw( c_string_to_lisp_string - ( "End of input while reading" ), frame ); + result = throw_exception( c_string_to_lisp_string + ( "End of input while reading" ), frame_pointer ); break; case '\'': result = c_quote( read_continuation - ( frame, input, fgetwc( input ) ) ); + ( frame, frame_pointer, input, fgetwc( input ) ) ); break; case '(': - result = read_list( frame, input, fgetwc( input ) ); + result = read_list( frame, frame_pointer, input, fgetwc( input ) ); break; case '"': result = read_string( input, fgetwc( input ) ); @@ -90,7 +93,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, wint_t next = fgetwc( input ); ungetwc( next, input ); if ( iswdigit( next ) ) { - result = read_number( frame, input, c, false ); + result = read_number( frame, frame_pointer, input, c, false ); } else { result = read_symbol( input, c ); } @@ -101,12 +104,12 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, wint_t next = fgetwc( input ); if ( iswdigit( next ) ) { ungetwc( next, input ); - result = read_number( frame, input, c, true ); + result = read_number( frame, frame_pointer, input, c, true ); } else if ( iswblank( next ) ) { /* dotted pair. TODO: this isn't right, we * really need to backtrack up a level. */ result = - read_continuation( frame, input, fgetwc( input ) ); + read_continuation( frame, frame_pointer, input, fgetwc( input ) ); } else { read_symbol( input, c ); } @@ -114,7 +117,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, break; default: if ( iswdigit( c ) ) { - result = read_number( frame, input, c, false ); + result = read_number( frame, frame_pointer, input, c, false ); } else if ( iswprint( c ) ) { result = read_symbol( input, c ); } else { @@ -122,7 +125,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, make_exception( make_cons( c_string_to_lisp_string ( "Unrecognised start of input character" ), make_string( c, NIL ) ), - frame ); + frame_pointer ); } break; } @@ -136,7 +139,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, * 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. */ -struct cons_pointer read_number( struct stack_frame *frame, FILE * input, +struct cons_pointer read_number( struct stack_frame *frame, + struct cons_pointer frame_pointer, + FILE * input, wint_t initial, bool seen_period ) { struct cons_pointer result = NIL; int64_t accumulator = 0; @@ -157,7 +162,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, if ( seen_period || dividend != 0 ) { return make_exception( c_string_to_lisp_string ( "Malformed number: too many periods" ), - frame ); + frame_pointer ); } else { seen_period = true; } @@ -165,7 +170,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, if ( seen_period || dividend > 0 ) { return make_exception( c_string_to_lisp_string ( "Malformed number: dividend of rational must be integer" ), - frame ); + frame_pointer ); } else { dividend = negative ? 0 - accumulator : accumulator; @@ -200,7 +205,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, result = make_real( rv ); } else if ( dividend != 0 ) { result = - make_ratio( frame, make_integer( dividend ), + make_ratio( frame_pointer, make_integer( dividend ), make_integer( accumulator ) ); } else { if ( negative ) { @@ -216,18 +221,18 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, * Read a list from this input stream, which no longer contains the opening * left parenthesis. */ -struct cons_pointer read_list( struct - stack_frame - *frame, FILE * input, wint_t initial ) { +struct cons_pointer read_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, + FILE * input, wint_t initial ) { struct cons_pointer result = NIL; if ( initial != ')' ) { #ifdef DEBUG fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial ); #endif - struct cons_pointer car = read_continuation( frame, input, + struct cons_pointer car = read_continuation( frame, frame_pointer, input, initial ); - result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); + result = make_cons( car, read_list( frame, frame_pointer, input, fgetwc( input ) ) ); } #ifdef DEBUG else { @@ -318,6 +323,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { */ struct cons_pointer read( struct stack_frame - *frame, FILE * input ) { - return read_continuation( frame, input, fgetwc( input ) ); + *frame, struct cons_pointer frame_pointer, FILE * input ) { + return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); } diff --git a/src/ops/read.h b/src/ops/read.h index af7574b..c144699 100644 --- a/src/ops/read.h +++ b/src/ops/read.h @@ -14,6 +14,8 @@ /** * read the next object on this input stream and return a cons_pointer to it. */ -struct cons_pointer read( struct stack_frame *frame, FILE * input ); +struct cons_pointer read( struct stack_frame *frame, + struct cons_pointer frame_pointer, + FILE * input ); #endif diff --git a/src/repl.c b/src/repl.c index f9ca5d5..5dd6567 100644 --- a/src/repl.c +++ b/src/repl.c @@ -31,44 +31,64 @@ * Dummy up a Lisp read call with its own stack frame. */ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { - struct stack_frame *frame = make_empty_frame( NULL, oblist ); + struct cons_pointer result = NIL; + struct cons_pointer frame_pointer = make_empty_frame( NIL ); + if (!nilp(frame_pointer)) { + inc_ref(frame_pointer); + struct stack_frame *frame = get_stack_frame(frame_pointer); - set_reg( frame, 0, stream_pointer ); - struct cons_pointer result = lisp_read( frame, oblist ); - free_stack_frame( frame ); + if (frame != NULL){ - return result; + set_reg( frame, 0, stream_pointer ); + struct cons_pointer result = lisp_read( frame, frame_pointer, oblist ); + } + dec_ref(frame_pointer); + } + + return result; } /** * Dummy up a Lisp eval call with its own stack frame. */ struct cons_pointer repl_eval( struct cons_pointer input ) { - struct stack_frame *frame = make_empty_frame( NULL, oblist ); + struct cons_pointer result = NIL; + struct cons_pointer frame_pointer = make_empty_frame( NIL ); + if (!nilp(frame_pointer)) { + inc_ref(frame_pointer); + struct stack_frame *frame = get_stack_frame(frame_pointer); - set_reg( frame, 0, input ); - struct cons_pointer result = lisp_eval( frame, oblist ); - - if ( !exceptionp( result ) ) { - free_stack_frame( frame ); + if (frame != NULL){ + set_reg( frame, 0, input ); + result = lisp_eval( frame, frame_pointer, oblist ); } - return result; + dec_ref(frame_pointer); + } + + 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 ) { - struct stack_frame *frame = make_empty_frame( NULL, oblist ); + struct cons_pointer value ) { + struct cons_pointer result = NIL; + struct cons_pointer frame_pointer = make_empty_frame( NIL ); + if (!nilp(frame_pointer)) { + struct stack_frame *frame = get_stack_frame(frame_pointer); - set_reg( frame, 0, value ); - set_reg( frame, 1, stream_pointer ); - struct cons_pointer result = lisp_print( frame, oblist ); - free_stack_frame( frame ); + if (frame != NULL){ + set_reg( frame, 0, value ); + set_reg( frame, 1, stream_pointer ); + result = lisp_print( frame, frame_pointer, oblist ); + free_stack_frame( frame ); + } + dec_ref(frame_pointer); + } - return result; + return result; } /** From 3d5c27cb10df058363a2f37789fea170a75451ed Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 26 Dec 2018 21:10:24 +0000 Subject: [PATCH 17/22] Horribly broken, may have to rethink. --- src/arith/peano.c | 104 +++++++------ src/arith/peano.h | 14 +- src/arith/ratio.c | 69 ++++----- src/arith/ratio.h | 10 +- src/arith/real.c | 1 + src/memory/consspaceobject.c | 26 ++-- src/memory/consspaceobject.h | 8 +- src/memory/dump.c | 23 +-- src/memory/stack.c | 282 ++++++++++++++++++++--------------- src/memory/stack.h | 8 +- src/memory/vectorspace.c | 26 +++- src/memory/vectorspace.h | 2 +- src/ops/equal.c | 4 +- src/ops/lispops.c | 194 ++++++++++++++---------- src/ops/lispops.h | 68 ++++++--- src/ops/print.c | 10 +- src/ops/read.c | 56 ++++--- src/ops/read.h | 3 +- src/repl.c | 73 ++++----- 19 files changed, 568 insertions(+), 413 deletions(-) diff --git a/src/arith/peano.c b/src/arith/peano.c index 63783f5..763414e 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -28,7 +28,9 @@ long double to_long_double( struct cons_pointer arg ); int64_t to_long_int( struct cons_pointer arg ); -struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, +struct cons_pointer add_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, struct cons_pointer arg2 ); @@ -119,7 +121,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`. */ -struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, +struct cons_pointer add_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer result; struct cons_space_object cell1 = pointer2cell( arg1 ); @@ -153,7 +157,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_ cell2.payload.integer.value ); break; case RATIOTV: - result = add_integer_ratio( frame_pointer, arg1, arg2 ); + result = + add_integer_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -162,8 +167,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_ break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot add: not a number" ), - frame_pointer ); + ( "Cannot add: not a number" ), + frame_pointer ); break; } break; @@ -173,7 +178,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_ result = arg2; break; case INTEGERTV: - result = add_integer_ratio( frame_pointer, arg2, arg1 ); + result = + add_integer_ratio( frame_pointer, arg2, arg1 ); break; case RATIOTV: result = add_ratio_ratio( frame_pointer, arg1, arg2 ); @@ -185,8 +191,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_ break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot add: not a number" ), - frame_pointer ); + ( "Cannot add: not a number" ), + frame_pointer ); break; } break; @@ -198,7 +204,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_ default: result = exceptionp( arg2 ) ? arg2 : throw_exception( c_string_to_lisp_string - ( "Cannot add: not a number" ), frame_pointer ); + ( "Cannot add: not a number" ), + frame_pointer ); } } @@ -252,7 +259,8 @@ 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`. */ -struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer frame_pointer, +struct cons_pointer multiply_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer result; @@ -286,7 +294,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f cell2.payload.integer.value ); break; case RATIOTV: - result = multiply_integer_ratio( frame_pointer, arg1, arg2 ); + result = + multiply_integer_ratio( frame_pointer, arg1, + arg2 ); break; case REALTV: result = @@ -295,8 +305,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame_pointer ); + ( "Cannot multiply: not a number" ), + frame_pointer ); break; } break; @@ -306,10 +316,13 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f result = arg2; break; case INTEGERTV: - result = multiply_integer_ratio( frame_pointer, arg2, arg1 ); + result = + multiply_integer_ratio( frame_pointer, arg2, + arg1 ); break; case RATIOTV: - result = multiply_ratio_ratio( frame_pointer, arg1, arg2 ); + result = + multiply_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -318,8 +331,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame_pointer ); + ( "Cannot multiply: not a number" ), + frame_pointer ); } break; case REALTV: @@ -329,8 +342,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame_pointer ); + ( "Cannot multiply: not a number" ), + frame_pointer ); break; } } @@ -406,8 +419,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: @@ -453,9 +466,10 @@ struct cons_pointer lisp_subtract( struct struct cons_pointer tmp = make_ratio( frame_pointer, frame->arg[0], make_integer( 1 ) ); - inc_ref(tmp); + inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, tmp, frame->arg[1] ); + subtract_ratio_ratio( frame_pointer, tmp, + frame->arg[1] ); dec_ref( tmp ); } break; @@ -466,8 +480,8 @@ struct cons_pointer lisp_subtract( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot subtract: not a number" ), - frame_pointer ); + ( "Cannot subtract: not a number" ), + frame_pointer ); break; } break; @@ -480,9 +494,10 @@ struct cons_pointer lisp_subtract( struct struct cons_pointer tmp = make_ratio( frame_pointer, frame->arg[1], make_integer( 1 ) ); - inc_ref(tmp); + inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], tmp ); + subtract_ratio_ratio( frame_pointer, frame->arg[0], + tmp ); dec_ref( tmp ); } break; @@ -498,8 +513,8 @@ struct cons_pointer lisp_subtract( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot subtract: not a number" ), - frame_pointer ); + ( "Cannot subtract: not a number" ), + frame_pointer ); break; } break; @@ -510,7 +525,8 @@ struct cons_pointer lisp_subtract( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot subtract: not a number" ), frame_pointer ); + ( "Cannot subtract: not a number" ), + frame_pointer ); break; } @@ -527,7 +543,7 @@ struct cons_pointer lisp_subtract( struct */ struct cons_pointer lisp_divide( struct stack_frame - *frame, struct cons_pointer frame_pointer, struct + *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); @@ -544,7 +560,8 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer unsimplified = - make_ratio( frame_pointer, frame->arg[0], frame->arg[1] ); + make_ratio( frame_pointer, 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 ); @@ -558,7 +575,8 @@ struct cons_pointer lisp_divide( struct struct cons_pointer ratio = make_ratio( frame_pointer, frame->arg[0], one ); result = - divide_ratio_ratio( frame_pointer, ratio, frame->arg[1] ); + divide_ratio_ratio( frame_pointer, ratio, + frame->arg[1] ); dec_ref( ratio ); } break; @@ -569,8 +587,8 @@ struct cons_pointer lisp_divide( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot divide: not a number" ), - frame_pointer ); + ( "Cannot divide: not a number" ), + frame_pointer ); break; } break; @@ -581,14 +599,15 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer one = make_integer( 1 ); - inc_ref( one); + inc_ref( one ); struct cons_pointer ratio = make_ratio( frame_pointer, frame->arg[1], one ); - inc_ref(ratio); + inc_ref( ratio ); result = - divide_ratio_ratio( frame_pointer, frame->arg[0], ratio ); + divide_ratio_ratio( frame_pointer, frame->arg[0], + ratio ); dec_ref( ratio ); - dec_ref(one); + dec_ref( one ); } break; case RATIOTV: @@ -603,8 +622,8 @@ struct cons_pointer lisp_divide( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot divide: not a number" ), - frame_pointer ); + ( "Cannot divide: not a number" ), + frame_pointer ); break; } break; @@ -615,7 +634,8 @@ struct cons_pointer lisp_divide( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot divide: not a number" ), frame_pointer ); + ( "Cannot divide: not a number" ), + frame_pointer ); break; } diff --git a/src/arith/peano.h b/src/arith/peano.h index 46008c2..f1c21b4 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -23,7 +23,8 @@ extern "C" { * @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 ); + lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Multiply an indefinite number of numbers together @@ -32,7 +33,9 @@ extern "C" { * @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 ); + lisp_multiply( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Subtract one number from another. @@ -41,7 +44,9 @@ extern "C" { * @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 ); + lisp_subtract( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Divide one number by another. @@ -50,7 +55,8 @@ extern "C" { * @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 ); + lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); #ifdef __cplusplus } diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 042aea1..afea5b0 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 ) { @@ -78,8 +78,8 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, } else { result = throw_exception( make_cons( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to simplify_ratio" ), - arg ), frame_pointer ); + ( "Shouldn't happen: bad arg to simplify_ratio" ), + arg ), frame_pointer ); } return result; @@ -124,7 +124,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, #endif if ( dr1v == dr2v ) { - r = make_ratio( frame_pointer, + r = make_ratio( frame_pointer, make_integer( dd1v + dd2v ), cell1.payload.ratio.divisor ); } else { @@ -132,8 +132,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, dr1vm = make_integer( dr1v * m1 ), dd2vm = make_integer( dd2v * m2 ), dr2vm = make_integer( dr2v * m2 ), - r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), - r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); + r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), + r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); r = add_ratio_ratio( frame_pointer, r1, r2 ); @@ -144,17 +144,17 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, dec_ref( r2 ); } - result = simplify_ratio( frame_pointer, r ); + result = simplify_ratio( frame_pointer, r ); if ( !eq( r, result ) ) { dec_ref( r ); } } else { result = throw_exception( make_cons( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to add_ratio_ratio" ), - make_cons( arg1, - make_cons( arg2, NIL ) ) ), - frame_pointer ); + ( "Shouldn't happen: bad arg to add_ratio_ratio" ), + make_cons( arg1, + make_cons( arg2, NIL ) ) ), + frame_pointer ); } #ifdef DEBUG @@ -181,17 +181,18 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer one = make_integer( 1 ), ratio = make_ratio( frame_pointer, intarg, one ); - result = add_ratio_ratio( frame_pointer, ratio, ratarg ); + result = add_ratio_ratio( frame_pointer, ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); } else { result = throw_exception( make_cons( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to add_integer_ratio" ), - make_cons( intarg, - make_cons( ratarg, NIL ) ) ), - frame_pointer ); + ( "Shouldn't happen: bad arg to add_integer_ratio" ), + make_cons( intarg, + make_cons( ratarg, + NIL ) ) ), + frame_pointer ); } return result; @@ -205,12 +206,12 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, 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 = - multiply_ratio_ratio( frame_pointer, arg1, i ); + struct cons_pointer i = make_ratio( frame_pointer, + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), result = + multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -248,7 +249,7 @@ 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_ratio( frame_pointer, make_integer( ddrv ), make_integer( drrv ) ); result = simplify_ratio( frame_pointer, unsimplified ); @@ -258,8 +259,8 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str } else { result = throw_exception( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), - frame_pointer ); + ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), + frame_pointer ); } return result; @@ -278,15 +279,15 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, if ( integerp( intarg ) && ratiop( ratarg ) ) { struct cons_pointer one = make_integer( 1 ), ratio = make_ratio( frame_pointer, intarg, one ); - result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); + result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); } else { result = throw_exception( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to multiply_integer_ratio" ), - frame_pointer ); + ( "Shouldn't happen: bad arg to multiply_integer_ratio" ), + frame_pointer ); } return result; @@ -302,7 +303,7 @@ 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 ), - result = add_ratio_ratio( frame_pointer, arg1, i ); + result = add_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -328,8 +329,8 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer, } else { result = throw_exception( c_string_to_lisp_string - ( "Dividend and divisor of a ratio must be integers" ), - frame_pointer ); + ( "Dividend and divisor of a ratio must be integers" ), + frame_pointer ); } #ifdef DEBUG dump_object( stderr, result ); diff --git a/src/arith/ratio.h b/src/arith/ratio.h index feb8925..5a3b0d6 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -14,15 +14,15 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg ); -struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, +struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, +struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, +struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ); @@ -30,11 +30,11 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, +struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer subtract_ratio_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 ); diff --git a/src/arith/real.c b/src/arith/real.c index a499b6a..d3786dd 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -9,6 +9,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "dump.h" #include "read.h" /** diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 75a5257..acca2a8 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -89,21 +89,21 @@ struct cons_pointer make_cons( struct cons_pointer car, * @param frame_pointer should be the pointer to the frame in which the exception occurred. */ 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_space_object *cell = &pointer2cell( pointer ); + struct cons_pointer frame_pointer ) { + struct cons_pointer result = NIL; + 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); - cell->payload.exception.message = message; - cell->payload.exception.frame = frame_pointer; + inc_ref( message ); + inc_ref( frame_pointer ); + cell->payload.exception.message = message; + cell->payload.exception.frame = frame_pointer; - result = pointer; + result = pointer; - return result; + return result; } @@ -113,7 +113,7 @@ struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, - struct cons_pointer, struct cons_pointer ) ) { + struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -212,7 +212,7 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame * frame, - struct cons_pointer, struct cons_pointer env ) ) { + struct cons_pointer, struct cons_pointer env ) ) { struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index b31a0bf..44b6a79 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -421,10 +421,10 @@ struct vectorp_payload { * tag. */ uint32_t value; /* the tag considered as a number */ } tag; - struct vector_space_object * address; - /* the address of the actual vector space - * object (TODO: will change when I actually - * implement vector space) */ + struct vector_space_object *address; + /* the address of the actual vector space + * object (TODO: will change when I actually + * implement vector space) */ }; /** diff --git a/src/memory/dump.c b/src/memory/dump.c index 5306801..5aaedfb 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -72,7 +72,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { break; case EXCEPTIONTV: fwprintf( output, L"\t\tException cell: " ); - dump_stack_trace( output, pointer); + dump_stack_trace( output, pointer ); break; case FREETV: fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", @@ -93,10 +93,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" ); @@ -110,11 +110,12 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case SYMBOLTV: dump_string_cell( output, L"Symbol", pointer ); break; - case VECTORPOINTTV: { - struct vector_space_object * vso = cell.payload.vectorp.address; - fwprintf( output, L"\t\tVector space object of type %4.4s, payload size %d bytes\n", - vso->header.tag, vso->header.size); - } - break; + case VECTORPOINTTV:{ + struct vector_space_object *vso = cell.payload.vectorp.address; + fwprintf( output, + L"\t\tVector space object of type %4.4s, payload size %d bytes\n", + vso->header.tag, vso->header.size ); + } + break; } } diff --git a/src/memory/stack.c b/src/memory/stack.c index 8fe268e..9f0f6f8 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -28,17 +28,26 @@ * get the actual stackframe object from this `pointer`, or NULL if * `pointer` is not a stackframe pointer. */ -struct stack_frame * get_stack_frame(struct cons_pointer pointer) { - struct stack_frame * result = NULL; - struct vector_space_object * vso = - pointer2cell(pointer).payload.vectorp.address; +struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { + struct stack_frame *result = NULL; + fputws + ( L"get_stack_frame: about to get a pointer to the vector space object\n", + stderr ); + struct vector_space_object *vso = + pointer2cell( pointer ).payload.vectorp.address; + fputws( L"get_stack_frame: got a pointer, about to test it\n", stderr ); - if (vectorpointp(pointer) && stackframep(vso)) - { - result = (struct stack_frame *) &(vso->payload); - } + if ( vectorpointp( pointer ) ) { // && stackframep(vso)){ + fputws( L"get_stack_frame: pointer is good, about to set the result\n", + stderr ); - return result; + result = ( struct stack_frame * ) &( vso->payload ); + fputws( L"get_stack_frame: all good, returning\n", stderr ); + } else { + fputws( L"get_stack_frame: fail, returning NULL\n", stderr ); + } + + return result; } /** @@ -48,28 +57,38 @@ struct stack_frame * get_stack_frame(struct cons_pointer pointer) { * @return the new frame, or NULL if memory is exhausted. */ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { - struct cons_pointer result = make_vso(STACKFRAMETAG, sizeof(struct stack_frame)); - if (!nilp(result)) { - struct stack_frame *frame = get_stack_frame(result); - /* - * TODO: later, pop a frame off a free-list of stack frames - */ + fputws( L"Entering make_empty_frame\n", stderr ); + struct cons_pointer result = + make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) ); + if ( !nilp( result ) ) { + fputws( L"make_empty_frame: about to call get_stack_frame\n", stderr ); + struct stack_frame *frame = get_stack_frame( result ); + /* + * TODO: later, pop a frame off a free-list of stack frames + */ - frame->previous = previous; - inc_ref(previous); + fwprintf( stderr, + L"make_empty_frame: about to set previous to %4.4s\n", + pointer2cell( previous ).tag ); + frame->previous = previous; + fputws( L"make_empty_frame: about to call inc_ref\n", stderr ); + inc_ref( previous ); - /* - * clearing the frame with memset would probably be slightly quicker, but - * this is clear. - */ - frame->more = NIL; - frame->function = NIL; - frame->args = 0; + /* + * clearing the frame with memset would probably be slightly quicker, but + * this is clear. + */ + frame->more = NIL; + frame->function = NIL; + frame->args = 0; - for ( int i = 0; i < args_in_frame; i++ ) { - set_reg( frame, i, NIL ); + fputws( L"make_empty_frame: about to initialise arg registers\n", + stderr ); + for ( int i = 0; i < args_in_frame; i++ ) { + set_reg( frame, i, NIL ); + } } - } + fputws( L"Leaving make_empty_frame\n", stderr ); return result; } @@ -83,67 +102,76 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { * @return the new frame, or an exception if one occurred while building it. */ struct cons_pointer make_stack_frame( struct cons_pointer previous, - struct cons_pointer args, - struct cons_pointer env ) { - struct cons_pointer result = make_empty_frame( previous ); + struct cons_pointer args, + struct cons_pointer env ) { + fputws( L"Entering make_stack_frame\n", stderr ); + struct cons_pointer result = make_empty_frame( previous ); - if (nilp(result)) - { - /* i.e. out of memory */ - result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous); - } else { - struct stack_frame * frame = get_stack_frame(result); + if ( nilp( result ) ) { + /* i.e. out of memory */ + result = + make_exception( c_string_to_lisp_string( "Memory exhausted." ), + previous ); + } else { + struct stack_frame *frame = get_stack_frame( result ); - for ( frame->args = 0; frame->args < args_in_frame && consp( args ); frame->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 */ - struct cons_space_object cell = pointer2cell( args ); + for ( frame->args = 0; frame->args < args_in_frame && consp( args ); + frame->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 */ + struct cons_space_object cell = pointer2cell( args ); - /* - * 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 - */ - struct cons_pointer arg_frame_pointer = make_empty_frame( result); - inc_ref(arg_frame_pointer); + /* + * 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 + */ + struct cons_pointer arg_frame_pointer = make_empty_frame( result ); + inc_ref( arg_frame_pointer ); - if(nilp(arg_frame_pointer)) { - result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous); - break; - } else { - struct stack_frame *arg_frame = get_stack_frame( arg_frame_pointer ); - set_reg( arg_frame, 0, cell.payload.cons.car ); + if ( nilp( arg_frame_pointer ) ) { + result = + make_exception( c_string_to_lisp_string + ( "Memory exhausted." ), previous ); + break; + } else { + struct stack_frame *arg_frame = + get_stack_frame( arg_frame_pointer ); + set_reg( arg_frame, 0, cell.payload.cons.car ); - struct cons_pointer val = lisp_eval( arg_frame, arg_frame_pointer, env ); - if ( exceptionp( val ) ) { - result = val; - break; - } else { - set_reg( frame, frame->args, val ); + struct cons_pointer val = + lisp_eval( arg_frame, arg_frame_pointer, env ); + if ( exceptionp( val ) ) { + result = val; + break; + } else { + set_reg( frame, frame->args, val ); + } + + dec_ref( arg_frame_pointer ); + + args = cell.payload.cons.cdr; + } } - - dec_ref(arg_frame_pointer); - - args = cell.payload.cons.cdr; - } - } - if (!exceptionp(result)) { - if ( consp( args ) ) { - /* if we still have args, eval them and stick the values on `more` */ - struct cons_pointer more = eval_forms( get_stack_frame(previous), previous, args, env ); - frame->more = more; - inc_ref( more ); - } - + if ( !exceptionp( result ) ) { + if ( consp( args ) ) { + /* if we still have args, eval them and stick the values on `more` */ + struct cons_pointer more = + eval_forms( get_stack_frame( previous ), previous, args, + env ); + frame->more = more; + inc_ref( more ); + } #ifdef DEBUG - dump_frame( stderr, result ); + dump_frame( stderr, result ); #endif + } } - } + fputws( L"Leaving make_stack_frame\n", stderr ); - return result; + return result; } /** @@ -157,36 +185,40 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_pointer make_special_frame( struct cons_pointer previous, struct cons_pointer args, struct cons_pointer env ) { - struct cons_pointer result = make_empty_frame( previous ); + fputws( L"Entering make_special_frame\n", stderr ); - if (nilp(result)) - { - /* i.e. out of memory */ - result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous); - } else { - struct stack_frame * frame = get_stack_frame(result); + struct cons_pointer result = make_empty_frame( previous ); - for ( frame->args = 0; frame->args < args_in_frame && !nilp( args ); frame->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 */ - struct cons_space_object cell = pointer2cell( args ); + if ( nilp( result ) ) { + /* i.e. out of memory */ + result = + make_exception( c_string_to_lisp_string( "Memory exhausted." ), + previous ); + } else { + struct stack_frame *frame = get_stack_frame( result ); - set_reg( frame, frame->args, cell.payload.cons.car ); + for ( frame->args = 0; frame->args < args_in_frame && !nilp( args ); + frame->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 */ + struct cons_space_object cell = pointer2cell( args ); - args = cell.payload.cons.cdr; - } - if (!exceptionp(result)) { - if ( consp( args ) ) { - frame->more = args; - inc_ref( args ); - } + set_reg( frame, frame->args, cell.payload.cons.car ); + args = cell.payload.cons.cdr; + } + if ( !exceptionp( result ) ) { + if ( consp( args ) ) { + frame->more = args; + inc_ref( args ); + } #ifdef DEBUG - dump_frame( stderr, result ); + dump_frame( stderr, result ); #endif + } } - } + fputws( L"Leaving make_special_frame\n", stderr ); return result; } @@ -215,37 +247,39 @@ void free_stack_frame( struct stack_frame *frame ) { * @param frame_pointer the pointer to the frame */ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { - struct stack_frame *frame = get_stack_frame(frame_pointer); + struct stack_frame *frame = get_stack_frame( frame_pointer ); - if (frame != NULL) { - for ( int arg = 0; arg < frame->args; arg++ ) { - struct cons_space_object cell = pointer2cell( frame->arg[arg] ); + if ( frame != NULL ) { + 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 ); + 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 ); + print( output, frame->arg[arg] ); + fputws( L"\n", output ); + } + fputws( L"More: \t", output ); + print( output, frame->more ); + fputws( L"\n", output ); } - fputws( L"More: \t", output ); - print( output, frame->more ); - fputws( L"\n", output ); - } } -void dump_stack_trace(FILE * output, struct cons_pointer pointer) { - if (exceptionp(pointer)) { - print( output, pointer2cell(pointer).payload.exception.message ); - fwprintf( output, L"\n" ); - dump_stack_trace(output, pointer2cell(pointer).payload.exception.frame); - } else { - while (vectorpointp(pointer) && stackframep(pointer_to_vso(pointer))) { - dump_frame( output, pointer); - pointer = get_stack_frame(pointer)->previous; +void dump_stack_trace( FILE * output, struct cons_pointer pointer ) { + if ( exceptionp( pointer ) ) { + print( output, pointer2cell( pointer ).payload.exception.message ); + fwprintf( output, L"\n" ); + dump_stack_trace( output, + pointer2cell( pointer ).payload.exception.frame ); + } else { + while ( vectorpointp( pointer ) + && stackframep( pointer_to_vso( pointer ) ) ) { + dump_frame( output, pointer ); + pointer = get_stack_frame( pointer )->previous; + } } - } } /** diff --git a/src/memory/stack.h b/src/memory/stack.h index df76849..20acd73 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -41,19 +41,19 @@ */ #define set_reg(frame,register,value)frame->arg[register]=value; inc_ref(value) -struct stack_frame * get_stack_frame(struct cons_pointer pointer); +struct stack_frame *get_stack_frame( struct cons_pointer pointer ); struct cons_pointer make_empty_frame( struct cons_pointer previous ); struct cons_pointer make_stack_frame( struct cons_pointer previous, - struct cons_pointer args, - struct cons_pointer env ); + struct cons_pointer args, + struct cons_pointer env ); void free_stack_frame( struct stack_frame *frame ); void dump_frame( FILE * output, struct cons_pointer pointer ); -void dump_stack_trace(FILE * output, struct cons_pointer frame_pointer); +void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer ); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index c0b6f8d..db39b48 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -30,12 +30,19 @@ * NOTE that `tag` should be the vector-space tag of the particular type of * vector-space object, NOT `VECTORPOINTTAG`. */ -struct cons_pointer make_vec_pointer( char * tag, struct vector_space_object * address ) { +struct cons_pointer make_vec_pointer( char *tag, + struct vector_space_object *address ) { + fputws( L"Entered make_vec_pointer\n", stderr ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object cell = pointer2cell( pointer ); - + fwprintf( stderr, + L"make_vec_pointer: allocated cell, about to write tag '%s'\n", + tag ); strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 ); + fputws( L"make_vec_pointer: tag written, about to set pointer address\n", + stderr ); cell.payload.vectorp.address = address; + fputws( L"make_vec_pointer: all good, returning\n", stderr ); return pointer; } @@ -48,15 +55,18 @@ struct cons_pointer make_vec_pointer( char * tag, struct vector_space_object * a * Returns NIL if the vector could not be allocated due to memory exhaustion. */ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { + fputws( L"Entered make_vso\n", stderr ); struct cons_pointer result = NIL; int64_t total_size = sizeof( struct vector_space_header ) + payload_size; /* Pad size to 64 bit words. This is intended to promote access efficiancy * on 64 bit machines but may just be voodoo coding */ - uint64_t padded = ceil((total_size * 8.0) / 8.0); + uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 ); + fputws( L"make_vso: about to malloc\n", stderr ); struct vector_space_object *vso = malloc( padded ); if ( vso != NULL ) { + fwprintf( stderr, L"make_vso: about to write tag '%s'\n", tag ); strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); vso->header.vecp = make_vec_pointer( tag, vso ); vso->header.size = payload_size; @@ -65,13 +75,15 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { fwprintf( stderr, L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld\n", tag, total_size, payload_size ); - if (padded != total_size){ - fwprintf(stderr, L"\t\tPadded from %d to %d\n", - total_size, padded); - } + if ( padded != total_size ) { + fwprintf( stderr, L"\t\tPadded from %d to %d\n", + total_size, padded ); + } #endif result = vso->header.vecp; } + fputws( L"make_vso: all good, returning\n", stderr ); + return result; } diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 83fa74c..caec968 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -61,7 +61,7 @@ struct vector_space_header { }; struct vector_space_object { - struct vector_space_header header; + 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 diff --git a/src/ops/equal.c b/src/ops/equal.c index ebb085e..0f0597c 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 825222f..1e6712d 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -89,9 +89,9 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer result = NIL; struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); - inc_ref( next_pointer); + inc_ref( next_pointer ); - struct stack_frame * next = get_stack_frame(next_pointer); + struct stack_frame *next = get_stack_frame( next_pointer ); set_reg( next, 0, form ); result = lisp_eval( next, next_pointer, env ); @@ -100,7 +100,7 @@ struct cons_pointer eval_form( struct stack_frame *parent, /* 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); + dec_ref( next_pointer ); } return result; @@ -111,13 +111,15 @@ struct cons_pointer eval_form( struct stack_frame *parent, * and this `env`, and return a list of their values. If the arg passed as * `list` is not in fact a list, return nil. */ -struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, +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. */ + /* 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; + eval_forms( frame, frame_pointer, c_cdr( list ), + env ) ) : NIL; } /** @@ -126,7 +128,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer f * (oblist) */ struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return oblist; } @@ -159,7 +162,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { * @param env the environment in which it is to be intepreted. */ struct cons_pointer -lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return make_lambda( frame->arg[0], compose_body( frame ) ); } @@ -170,7 +174,8 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struc * @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 ) { +lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return make_nlambda( frame->arg[0], compose_body( frame ) ); } @@ -188,8 +193,8 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) { * Evaluate a lambda or nlambda expression. */ struct cons_pointer -eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { +eval_lambda( struct cons_space_object cell, struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; fwprintf( stderr, L"eval_lambda called\n" ); @@ -216,7 +221,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct co struct cons_pointer vals = frame->more; for ( int i = args_in_frame - 1; i >= 0; i-- ) { - struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[i], env ); + struct cons_pointer val = + eval_form( frame, frame_pointer, frame->arg[i], env ); if ( nilp( val ) && nilp( vals ) ) { /* nothing */ } else { @@ -248,23 +254,25 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct co * @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 ) { struct cons_pointer result = NIL; - /* construct a child frame and within it evaluate the first argument - the - * argument in the function position. */ + /* construct a child frame and within it evaluate the first argument - the + * argument in the function position. */ struct cons_pointer fn_frame_pointer = make_empty_frame( frame_pointer ); - inc_ref( fn_frame_pointer); - struct stack_frame *fn_frame = get_stack_frame(fn_frame_pointer); + inc_ref( fn_frame_pointer ); + struct stack_frame *fn_frame = get_stack_frame( fn_frame_pointer ); set_reg( fn_frame, 0, c_car( frame->arg[0] ) ); - struct cons_pointer fn_pointer = lisp_eval( fn_frame, fn_frame_pointer, env ); + struct cons_pointer fn_pointer = + lisp_eval( fn_frame, fn_frame_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(fn_frame_pointer); + dec_ref( fn_frame_pointer ); } struct cons_space_object fn_cell = pointer2cell( fn_pointer ); @@ -280,14 +288,17 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co struct cons_pointer exep = NIL; struct cons_pointer next_pointer = make_stack_frame( frame_pointer, args, env ); - inc_ref(next_pointer); + inc_ref( next_pointer ); if ( exceptionp( next_pointer ) ) { result = next_pointer; } else { - struct stack_frame *next = get_stack_frame(next_pointer); + 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; @@ -296,48 +307,53 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co 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 ) ) { + 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); + 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 ) ) { + 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(frame_pointer); - result = eval_lambda( fn_cell, next, next_pointer, env ); - if ( !exceptionp( result ) ) { - dec_ref(next_pointer); + struct stack_frame *next = + get_stack_frame( frame_pointer ); + result = eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + 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 ) ) { + 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(frame_pointer); - result = ( *fn_cell.payload.special.executable ) ( next, next_pointer, env ); - if ( !exceptionp( result ) ) { - dec_ref(next_pointer); + struct stack_frame *next = + get_stack_frame( frame_pointer ); + result = + ( *fn_cell.payload.special.executable ) ( next, + next_pointer, + env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); + } } - } } break; default: @@ -355,7 +371,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co result = throw_exception( message, frame_pointer ); } } - dec_ref(fn_frame_pointer); + dec_ref( fn_frame_pointer ); return result; } @@ -393,7 +409,8 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { * If a special form, passes the cdr of s_expr to the special form as argument. */ struct cons_pointer -lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer result = frame->arg[0]; struct cons_space_object cell = pointer2cell( frame->arg[0] ); @@ -456,7 +473,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * the second argument */ struct cons_pointer -lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { #ifdef DEBUG fputws( L"Apply: ", stderr ); dump_frame( stderr, frame_pointer ); @@ -484,7 +502,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * this isn't at this stage checked) unevaluated. */ struct cons_pointer -lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return frame->arg[0]; } @@ -499,7 +518,8 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * the namespace in so doing. `namespace` defaults to the value of `oblist`. */ struct cons_pointer -lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_set( 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]; @@ -512,7 +532,8 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c make_exception( make_cons ( c_string_to_lisp_string ( "The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), frame_pointer ); + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -529,13 +550,15 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c * the namespace in so doing. `namespace` defaults to the value of `oblist`. */ struct cons_pointer -lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +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]; if ( symbolp( frame->arg[0] ) ) { - struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[1], env ); + struct cons_pointer val = + eval_form( frame, frame_pointer, frame->arg[1], env ); deep_bind( frame->arg[0], val ); result = val; } else { @@ -543,7 +566,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s make_exception( make_cons ( c_string_to_lisp_string ( "The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), frame_pointer ); + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -558,7 +582,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s * otherwise returns a new cons cell. */ struct cons_pointer -lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer car = frame->arg[0]; struct cons_pointer cdr = frame->arg[1]; struct cons_pointer result; @@ -582,7 +607,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * strings, and TODO read streams and other things which can be considered as sequences. */ struct cons_pointer -lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer result = NIL; if ( consp( frame->arg[0] ) ) { @@ -606,7 +632,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c * strings, and TODO read streams and other things which can be considered as sequences. */ struct cons_pointer -lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer result = NIL; if ( consp( frame->arg[0] ) ) { @@ -629,7 +656,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c * Returns 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, struct cons_pointer env ) { +lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return c_assoc( frame->arg[0], frame->arg[1] ); } @@ -637,7 +665,8 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * (eq a b) * Returns 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, +struct cons_pointer lisp_eq( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ) { return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } @@ -647,7 +676,8 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer fram * Returns T if a and b are pointers to structurally identical objects, else NIL */ struct cons_pointer -lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } @@ -658,7 +688,8 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * is a read stream, then read from that stream, else stdin. */ struct cons_pointer -lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { FILE *input = stdin; if ( readp( frame->arg[0] ) ) { @@ -698,7 +729,8 @@ 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. */ -struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, +struct cons_pointer lisp_reverse( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ) { return c_reverse( frame->arg[0] ); } @@ -711,9 +743,10 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer * is a write stream, then print to that stream, else stdout. */ struct cons_pointer -lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { #ifdef DEBUG - fputws(L"Entering print\n", stderr); + fputws( L"Entering print\n", stderr ); #endif struct cons_pointer result = NIL; FILE *output = stdout; @@ -741,7 +774,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * @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 ) { +lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return c_type( frame->arg[0] ); } @@ -759,7 +793,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * argument. */ struct cons_pointer -lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +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; @@ -786,7 +821,8 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * @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 ) { +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer result = NIL; bool done = false; @@ -797,11 +833,14 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct if ( consp( clause_pointer ) ) { struct cons_space_object cell = pointer2cell( clause_pointer ); - result = eval_form( frame, frame_pointer, c_car( clause_pointer ), env ); + result = + eval_form( frame, frame_pointer, c_car( clause_pointer ), + env ); if ( !nilp( result ) ) { struct cons_pointer vals = - eval_forms( frame, frame_pointer,c_cdr( clause_pointer ), env ); + eval_forms( frame, frame_pointer, c_cdr( clause_pointer ), + env ); while ( consp( vals ) ) { result = c_car( vals ); @@ -814,8 +853,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct done = true; } else { result = throw_exception( c_string_to_lisp_string - ( "Arguments to `cond` must be lists" ), - frame_pointer); + ( "Arguments to `cond` must be lists" ), + frame_pointer ); } } /* TODO: if there are more than 8 clauses we need to continue into the @@ -835,7 +874,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * pointer to the frame in which the exception occurred. */ struct cons_pointer -throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer ) { +throw_exception( struct cons_pointer message, + struct cons_pointer frame_pointer ) { fwprintf( stderr, L"\nERROR: " ); print( stderr, message ); struct cons_pointer result = NIL; @@ -861,7 +901,9 @@ throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer * If `message` is itself an exception, returns that instead. */ 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, frame->previous); +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, + frame->previous ); } diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 059255d..a1dee81 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -60,7 +60,8 @@ struct cons_pointer eval_form( struct stack_frame *parent, * and this `env`, and return a list of their values. If the arg passed as * `list` is not in fact a list, return nil. */ -struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, +struct cons_pointer eval_forms( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer list, struct cons_pointer env ); @@ -68,19 +69,24 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer f /* * special forms */ -struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, +struct cons_pointer lisp_eval( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_apply( 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 ); struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +lisp_oblist( 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 ); +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 ); +lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Construct an interpretable function. @@ -89,7 +95,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s * @param lexpr the lambda expression to be interpreted; * @param env the environment in which it is to be intepreted. */ -struct cons_pointer lisp_lambda( 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 ); /** @@ -99,31 +106,42 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer * @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 ); +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, +struct cons_pointer lisp_quote( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); /* * functions */ -struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, +struct cons_pointer lisp_cons( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, +struct cons_pointer lisp_car( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, +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 lisp_assoc( 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 lisp_eq( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, +struct cons_pointer lisp_equal( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, +struct cons_pointer lisp_print( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, +struct cons_pointer lisp_read( 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 lisp_reverse( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Function: Get the Lisp type of the single argument. @@ -132,7 +150,8 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer * @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 ); +lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** @@ -146,7 +165,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * argument. */ struct cons_pointer -lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +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 @@ -158,7 +178,8 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * @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 ); +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Throw an exception. @@ -167,7 +188,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct * 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 frame_pointer ); struct cons_pointer -lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +lisp_exception( 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 7efd59f..99cd7f3 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -119,7 +119,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case EXCEPTIONTV: fwprintf( output, L"\n%sException: ", print_use_colours ? "\x1B[31m" : "" ); - dump_stack_trace(output, pointer); + dump_stack_trace( output, pointer ); break; case FUNCTIONTV: fwprintf( output, L"(Function)" ); @@ -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( "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( "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 1a09700..7d21dbe 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -34,10 +34,11 @@ */ struct cons_pointer read_number( struct stack_frame *frame, - struct cons_pointer frame_pointer, FILE * input, - wint_t initial, bool seen_period ); + struct cons_pointer frame_pointer, + 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, 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 ); @@ -55,8 +56,9 @@ struct cons_pointer c_quote( struct cons_pointer arg ) { * treating this initial character as the first character of the object * representation. */ -struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, FILE * input, - wint_t initial ) { +struct cons_pointer read_continuation( struct stack_frame *frame, + struct cons_pointer frame_pointer, + FILE * input, wint_t initial ) { struct cons_pointer result = NIL; wint_t c; @@ -76,15 +78,18 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po break; case EOF: result = throw_exception( c_string_to_lisp_string - ( "End of input while reading" ), frame_pointer ); + ( "End of input while reading" ), + frame_pointer ); break; case '\'': result = c_quote( read_continuation - ( frame, frame_pointer, input, fgetwc( input ) ) ); + ( frame, frame_pointer, input, + fgetwc( input ) ) ); break; case '(': - result = read_list( frame, frame_pointer, input, fgetwc( input ) ); + result = + read_list( frame, frame_pointer, input, fgetwc( input ) ); break; case '"': result = read_string( input, fgetwc( input ) ); @@ -93,7 +98,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po wint_t next = fgetwc( input ); ungetwc( next, input ); if ( iswdigit( next ) ) { - result = read_number( frame, frame_pointer, input, c, false ); + result = + read_number( frame, frame_pointer, input, c, + false ); } else { result = read_symbol( input, c ); } @@ -104,12 +111,15 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po wint_t next = fgetwc( input ); if ( iswdigit( next ) ) { ungetwc( next, input ); - result = read_number( frame, frame_pointer, input, c, true ); + result = + read_number( frame, frame_pointer, input, c, + true ); } 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, fgetwc( input ) ); + read_continuation( frame, frame_pointer, input, + fgetwc( input ) ); } else { read_symbol( input, c ); } @@ -117,7 +127,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po break; default: if ( iswdigit( c ) ) { - result = read_number( frame, frame_pointer, input, c, false ); + result = + read_number( frame, frame_pointer, input, c, false ); } else if ( iswprint( c ) ) { result = read_symbol( input, c ); } else { @@ -140,8 +151,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po * input stream into a Lisp string, and then convert it to a number. */ struct cons_pointer read_number( struct stack_frame *frame, - struct cons_pointer frame_pointer, - FILE * input, + struct cons_pointer frame_pointer, + FILE * input, wint_t initial, bool seen_period ) { struct cons_pointer result = NIL; int64_t accumulator = 0; @@ -222,17 +233,21 @@ 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, - FILE * input, wint_t initial ) { + struct cons_pointer frame_pointer, + FILE * input, wint_t initial ) { struct cons_pointer result = NIL; if ( initial != ')' ) { #ifdef DEBUG fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial ); #endif - struct cons_pointer car = read_continuation( frame, frame_pointer, input, - initial ); - result = make_cons( car, read_list( frame, frame_pointer, input, fgetwc( input ) ) ); + struct cons_pointer car = + read_continuation( frame, frame_pointer, input, + initial ); + result = + make_cons( car, + read_list( frame, frame_pointer, input, + fgetwc( input ) ) ); } #ifdef DEBUG else { @@ -323,6 +338,7 @@ 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 ) { + *frame, struct cons_pointer frame_pointer, + FILE * input ) { return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); } diff --git a/src/ops/read.h b/src/ops/read.h index c144699..c6dbba3 100644 --- a/src/ops/read.h +++ b/src/ops/read.h @@ -15,7 +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, FILE * input ); #endif diff --git a/src/repl.c b/src/repl.c index 5dd6567..d077ba8 100644 --- a/src/repl.c +++ b/src/repl.c @@ -31,64 +31,65 @@ * Dummy up a Lisp read call with its own stack frame. */ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { - struct cons_pointer result = NIL; - struct cons_pointer frame_pointer = make_empty_frame( NIL ); - if (!nilp(frame_pointer)) { - inc_ref(frame_pointer); - struct stack_frame *frame = get_stack_frame(frame_pointer); + struct cons_pointer result = NIL; + struct cons_pointer frame_pointer = make_empty_frame( NIL ); + if ( !nilp( frame_pointer ) ) { + inc_ref( frame_pointer ); + struct stack_frame *frame = get_stack_frame( frame_pointer ); - if (frame != NULL){ + if ( frame != NULL ) { - set_reg( frame, 0, stream_pointer ); - struct cons_pointer result = lisp_read( frame, frame_pointer, oblist ); + set_reg( frame, 0, stream_pointer ); + struct cons_pointer result = + lisp_read( frame, frame_pointer, oblist ); + } + dec_ref( frame_pointer ); } - dec_ref(frame_pointer); - } - return result; + return result; } /** * Dummy up a Lisp eval call with its own stack frame. */ struct cons_pointer repl_eval( struct cons_pointer input ) { - struct cons_pointer result = NIL; - struct cons_pointer frame_pointer = make_empty_frame( NIL ); - if (!nilp(frame_pointer)) { - inc_ref(frame_pointer); - struct stack_frame *frame = get_stack_frame(frame_pointer); + struct cons_pointer result = NIL; + struct cons_pointer frame_pointer = make_empty_frame( NIL ); + if ( !nilp( frame_pointer ) ) { + inc_ref( frame_pointer ); + struct stack_frame *frame = get_stack_frame( frame_pointer ); - if (frame != NULL){ - set_reg( frame, 0, input ); - result = lisp_eval( frame, frame_pointer, oblist ); + if ( frame != NULL ) { + set_reg( frame, 0, input ); + result = lisp_eval( frame, frame_pointer, oblist ); + } + + dec_ref( frame_pointer ); } - dec_ref(frame_pointer); - } - - return result; + 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 ) { - struct cons_pointer result = NIL; - struct cons_pointer frame_pointer = make_empty_frame( NIL ); - if (!nilp(frame_pointer)) { - struct stack_frame *frame = get_stack_frame(frame_pointer); + struct cons_pointer value ) { + struct cons_pointer result = NIL; + struct cons_pointer frame_pointer = make_empty_frame( NIL ); + if ( !nilp( frame_pointer ) ) { + struct stack_frame *frame = get_stack_frame( frame_pointer ); - if (frame != NULL){ - set_reg( frame, 0, value ); - set_reg( frame, 1, stream_pointer ); - result = lisp_print( frame, frame_pointer, oblist ); - free_stack_frame( frame ); + if ( frame != NULL ) { + set_reg( frame, 0, value ); + set_reg( frame, 1, stream_pointer ); + result = lisp_print( frame, frame_pointer, oblist ); + free_stack_frame( frame ); + } + dec_ref( frame_pointer ); } - dec_ref(frame_pointer); - } - return result; + return result; } /** From 75abfb4050f7c6c74f7d913cc44a6b2f72d79758 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 27 Dec 2018 21:37:38 +0000 Subject: [PATCH 18/22] Much better debugging, but it still doesn't work --- Doxyfile | 138 +++++++++++++++++------------------ Makefile | 2 +- src/arith/integer.c | 5 +- src/arith/peano.c | 45 +++++------- src/arith/ratio.c | 7 +- src/arith/real.c | 6 +- src/debug.c | 65 +++++++++++++++++ src/debug.h | 28 +++++++ src/init.c | 22 +++++- src/memory/conspage.c | 3 +- src/memory/conspage.h | 4 +- src/memory/consspaceobject.h | 11 +-- src/memory/cursor.c | 9 +++ src/memory/cursor.h | Bin 0 -> 614 bytes src/memory/dump.c | 17 ++++- src/memory/stack.c | 63 +++++++++------- src/memory/stack.h | 4 +- src/memory/vectorspace.c | 42 ++++++----- src/memory/vectorspace.h | 2 +- src/ops/intern.c | 31 +++++--- src/ops/lispops.c | 79 ++++++++++---------- src/ops/read.c | 26 +++---- src/repl.c | 19 ++++- 23 files changed, 395 insertions(+), 233 deletions(-) create mode 100644 src/debug.c create mode 100644 src/debug.h create mode 100644 src/memory/cursor.c create mode 100644 src/memory/cursor.h diff --git a/Doxyfile b/Doxyfile index b94ec20..955cb32 100644 --- a/Doxyfile +++ b/Doxyfile @@ -32,13 +32,13 @@ DOXYFILE_ENCODING = UTF-8 # title of most generated pages and in a few other places. # The default value is: My Project. -PROJECT_NAME = "\"Post Scarcity\"" +PROJECT_NAME = "Post Scarcity" # The PROJECT_NUMBER tag can be used to enter a project or revision number. This # could be handy for archiving the generated documentation or if some version # control system is used. -PROJECT_NUMBER = +PROJECT_NUMBER = # Using the PROJECT_BRIEF tag one can provide an optional one line description # for a project that appears at the top of each page and should give viewer a @@ -51,14 +51,14 @@ PROJECT_BRIEF = "A prototype for a post scarcity programming environmen # pixels and the maximum width should not exceed 200 pixels. Doxygen will copy # the logo to the output directory. -PROJECT_LOGO = +PROJECT_LOGO = # The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path # into which the generated documentation will be written. If a relative path is # entered, it will be relative to the location where doxygen was started. If # left blank the current directory will be used. -OUTPUT_DIRECTORY = /home/simon/workspace/post-scarcity/doc +OUTPUT_DIRECTORY = doc # If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- # directories (in 2 levels) under the output directory of each output format and @@ -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 = # 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 @@ -171,7 +171,7 @@ STRIP_FROM_PATH = # specify the list of include paths that are normally passed to the compiler # using the -I flag. -STRIP_FROM_INC_PATH = +STRIP_FROM_INC_PATH = # If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but # less readable) file names. This can be useful is your file systems doesn't @@ -238,13 +238,13 @@ TAB_SIZE = 4 # "Side Effects:". You can put \n's in the value part of an alias to insert # newlines. -ALIASES = +ALIASES = # This tag can be used to specify a number of word-keyword mappings (TCL only). # A mapping has the form "name=value". For example adding "class=itcl::class" # will allow you to use the command class in the itcl::class meaning. -TCL_SUBST = +TCL_SUBST = # Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources # only. Doxygen will then generate output that is more tailored for C. For @@ -291,7 +291,7 @@ OPTIMIZE_OUTPUT_VHDL = NO # Note that for custom extensions you also need to set FILE_PATTERNS otherwise # the files are not read by doxygen. -EXTENSION_MAPPING = +EXTENSION_MAPPING = # If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments # according to the Markdown format, which allows for more readable @@ -648,7 +648,7 @@ GENERATE_DEPRECATEDLIST= YES # sections, marked by \if ... \endif and \cond # ... \endcond blocks. -ENABLED_SECTIONS = +ENABLED_SECTIONS = # The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the # initial value of a variable or macro / define can have for it to appear in the @@ -690,7 +690,7 @@ SHOW_NAMESPACES = YES # by doxygen. Whatever the program writes to standard output is used as the file # version. For an example see the documentation. -FILE_VERSION_FILTER = +FILE_VERSION_FILTER = # The LAYOUT_FILE tag can be used to specify a layout file which will be parsed # by doxygen. The layout file controls the global structure of the generated @@ -703,7 +703,7 @@ FILE_VERSION_FILTER = # DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE # tag is left empty. -LAYOUT_FILE = +LAYOUT_FILE = # The CITE_BIB_FILES tag can be used to specify one or more bib files containing # the reference definitions. This must be a list of .bib files. The .bib @@ -713,7 +713,7 @@ LAYOUT_FILE = # LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the # search path. See also \cite for info how to create references. -CITE_BIB_FILES = +CITE_BIB_FILES = #--------------------------------------------------------------------------- # Configuration options related to warning and progress messages @@ -778,7 +778,7 @@ WARN_FORMAT = "$file:$line: $text" # messages should be written. If left blank the output is written to standard # error (stderr). -WARN_LOGFILE = +WARN_LOGFILE = doxy.log #--------------------------------------------------------------------------- # Configuration options related to the input files @@ -790,7 +790,7 @@ WARN_LOGFILE = # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. -INPUT = /home/simon/workspace/post-scarcity/src +INPUT = src src/arith src/memory src/ops # 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 @@ -873,7 +873,7 @@ RECURSIVE = NO # Note that relative paths are relative to the directory from which doxygen is # run. -EXCLUDE = +EXCLUDE = # The EXCLUDE_SYMLINKS tag can be used to select whether or not files or # directories that are symbolic links (a Unix file system feature) are excluded @@ -889,7 +889,7 @@ EXCLUDE_SYMLINKS = NO # Note that the wildcards are matched against the file with absolute path, so to # exclude all test directories for example use the pattern */test/* -EXCLUDE_PATTERNS = +EXCLUDE_PATTERNS = # The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names # (namespaces, classes, functions, etc.) that should be excluded from the @@ -900,13 +900,13 @@ EXCLUDE_PATTERNS = # Note that the wildcards are matched against the file with absolute path, so to # exclude all test directories use the pattern */test/* -EXCLUDE_SYMBOLS = +EXCLUDE_SYMBOLS = # The EXAMPLE_PATH tag can be used to specify one or more files or directories # that contain example code fragments that are included (see the \include # command). -EXAMPLE_PATH = +EXAMPLE_PATH = # If the value of the EXAMPLE_PATH tag contains directories, you can use the # EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and @@ -926,7 +926,7 @@ EXAMPLE_RECURSIVE = NO # that contain images that are to be included in the documentation (see the # \image command). -IMAGE_PATH = +IMAGE_PATH = # The INPUT_FILTER tag can be used to specify a program that doxygen should # invoke to filter for each input file. Doxygen will invoke the filter program @@ -947,7 +947,7 @@ IMAGE_PATH = # need to set EXTENSION_MAPPING for the extension otherwise the files are not # properly processed by doxygen. -INPUT_FILTER = +INPUT_FILTER = # The FILTER_PATTERNS tag can be used to specify filters on a per file pattern # basis. Doxygen will compare the file name with each pattern and apply the @@ -960,7 +960,7 @@ INPUT_FILTER = # need to set EXTENSION_MAPPING for the extension otherwise the files are not # properly processed by doxygen. -FILTER_PATTERNS = +FILTER_PATTERNS = # If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using # INPUT_FILTER) will also be used to filter the input files that are used for @@ -975,14 +975,14 @@ FILTER_SOURCE_FILES = NO # *.ext= (so without naming a filter). # This tag requires that the tag FILTER_SOURCE_FILES is set to YES. -FILTER_SOURCE_PATTERNS = +FILTER_SOURCE_PATTERNS = # If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that # is part of the input, its contents will be placed on the main page # (index.html). This can be useful if you have a project on for instance GitHub # and want to reuse the introduction page also for the doxygen output. -USE_MDFILE_AS_MAINPAGE = +USE_MDFILE_AS_MAINPAGE = #--------------------------------------------------------------------------- # Configuration options related to source browsing @@ -1087,7 +1087,7 @@ CLANG_ASSISTED_PARSING = NO # specified with INPUT and INCLUDE_PATH. # This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES. -CLANG_OPTIONS = +CLANG_OPTIONS = #--------------------------------------------------------------------------- # Configuration options related to the alphabetical class index @@ -1113,7 +1113,7 @@ COLS_IN_ALPHA_INDEX = 5 # while generating the index headers. # This tag requires that the tag ALPHABETICAL_INDEX is set to YES. -IGNORE_PREFIX = +IGNORE_PREFIX = #--------------------------------------------------------------------------- # Configuration options related to the HTML output @@ -1157,7 +1157,7 @@ HTML_FILE_EXTENSION = .html # of the possible markers and block names see the documentation. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_HEADER = +HTML_HEADER = # The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each # generated HTML page. If the tag is left blank doxygen will generate a standard @@ -1167,7 +1167,7 @@ HTML_HEADER = # that doxygen normally uses. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_FOOTER = +HTML_FOOTER = # The HTML_STYLESHEET tag can be used to specify a user-defined cascading style # sheet that is used by each HTML page. It can be used to fine-tune the look of @@ -1179,7 +1179,7 @@ HTML_FOOTER = # obsolete. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_STYLESHEET = +HTML_STYLESHEET = # The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined # cascading style sheets that are included after the standard style sheets @@ -1192,7 +1192,7 @@ HTML_STYLESHEET = # list). For an example see the documentation. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_EXTRA_STYLESHEET = +HTML_EXTRA_STYLESHEET = # The HTML_EXTRA_FILES tag can be used to specify one or more extra images or # other source files which should be copied to the HTML output directory. Note @@ -1202,7 +1202,7 @@ HTML_EXTRA_STYLESHEET = # files will be copied as-is; there are no commands or markers available. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_EXTRA_FILES = +HTML_EXTRA_FILES = # The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen # will adjust the colors in the style sheet and background images according to @@ -1331,7 +1331,7 @@ GENERATE_HTMLHELP = NO # written to the html output directory. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. -CHM_FILE = +CHM_FILE = # The HHC_LOCATION tag can be used to specify the location (absolute path # including file name) of the HTML help compiler (hhc.exe). If non-empty, @@ -1339,7 +1339,7 @@ CHM_FILE = # The file has to be specified with full path. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. -HHC_LOCATION = +HHC_LOCATION = # The GENERATE_CHI flag controls if a separate .chi index file is generated # (YES) or that it should be included in the master .chm file (NO). @@ -1352,7 +1352,7 @@ GENERATE_CHI = NO # and project file content. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. -CHM_INDEX_ENCODING = +CHM_INDEX_ENCODING = # The BINARY_TOC flag controls whether a binary table of contents is generated # (YES) or a normal table of contents (NO) in the .chm file. Furthermore it @@ -1383,7 +1383,7 @@ GENERATE_QHP = NO # the HTML output folder. # This tag requires that the tag GENERATE_QHP is set to YES. -QCH_FILE = +QCH_FILE = # The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help # Project output. For more information please see Qt Help Project / Namespace @@ -1408,7 +1408,7 @@ QHP_VIRTUAL_FOLDER = doc # filters). # This tag requires that the tag GENERATE_QHP is set to YES. -QHP_CUST_FILTER_NAME = +QHP_CUST_FILTER_NAME = # The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the # custom filter to add. For more information please see Qt Help Project / Custom @@ -1416,21 +1416,21 @@ QHP_CUST_FILTER_NAME = # filters). # This tag requires that the tag GENERATE_QHP is set to YES. -QHP_CUST_FILTER_ATTRS = +QHP_CUST_FILTER_ATTRS = # The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this # project's filter section matches. Qt Help Project / Filter Attributes (see: # http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes). # This tag requires that the tag GENERATE_QHP is set to YES. -QHP_SECT_FILTER_ATTRS = +QHP_SECT_FILTER_ATTRS = # The QHG_LOCATION tag can be used to specify the location of Qt's # qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the # generated .qhp file. # This tag requires that the tag GENERATE_QHP is set to YES. -QHG_LOCATION = +QHG_LOCATION = # If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be # generated, together with the HTML files, they form an Eclipse help plugin. To @@ -1563,7 +1563,7 @@ MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest # MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols # This tag requires that the tag USE_MATHJAX is set to YES. -MATHJAX_EXTENSIONS = +MATHJAX_EXTENSIONS = # The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces # of code that will be used on startup of the MathJax code. See the MathJax site @@ -1571,7 +1571,7 @@ MATHJAX_EXTENSIONS = # example see the documentation. # This tag requires that the tag USE_MATHJAX is set to YES. -MATHJAX_CODEFILE = +MATHJAX_CODEFILE = # When the SEARCHENGINE tag is enabled doxygen will generate a search box for # the HTML output. The underlying search engine uses javascript and DHTML and @@ -1631,7 +1631,7 @@ EXTERNAL_SEARCH = NO # Searching" for details. # This tag requires that the tag SEARCHENGINE is set to YES. -SEARCHENGINE_URL = +SEARCHENGINE_URL = # When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the unindexed # search data is written to a file for indexing by an external tool. With the @@ -1647,7 +1647,7 @@ SEARCHDATA_FILE = searchdata.xml # projects and redirect the results back to the right project. # This tag requires that the tag SEARCHENGINE is set to YES. -EXTERNAL_SEARCH_ID = +EXTERNAL_SEARCH_ID = # The EXTRA_SEARCH_MAPPINGS tag can be used to enable searching through doxygen # projects other than the one defined by this configuration file, but that are @@ -1657,7 +1657,7 @@ EXTERNAL_SEARCH_ID = # EXTRA_SEARCH_MAPPINGS = tagname1=loc1 tagname2=loc2 ... # This tag requires that the tag SEARCHENGINE is set to YES. -EXTRA_SEARCH_MAPPINGS = +EXTRA_SEARCH_MAPPINGS = #--------------------------------------------------------------------------- # Configuration options related to the LaTeX output @@ -1721,7 +1721,7 @@ PAPER_TYPE = a4 # If left blank no extra packages will be included. # This tag requires that the tag GENERATE_LATEX is set to YES. -EXTRA_PACKAGES = +EXTRA_PACKAGES = # The LATEX_HEADER tag can be used to specify a personal LaTeX header for the # generated LaTeX document. The header should contain everything until the first @@ -1737,7 +1737,7 @@ EXTRA_PACKAGES = # to HTML_HEADER. # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_HEADER = +LATEX_HEADER = # The LATEX_FOOTER tag can be used to specify a personal LaTeX footer for the # generated LaTeX document. The footer should contain everything after the last @@ -1748,7 +1748,7 @@ LATEX_HEADER = # Note: Only use a user-defined footer if you know what you are doing! # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_FOOTER = +LATEX_FOOTER = # The LATEX_EXTRA_STYLESHEET tag can be used to specify additional user-defined # LaTeX style sheets that are included after the standard style sheets created @@ -1759,7 +1759,7 @@ LATEX_FOOTER = # list). # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_EXTRA_STYLESHEET = +LATEX_EXTRA_STYLESHEET = # The LATEX_EXTRA_FILES tag can be used to specify one or more extra images or # other source files which should be copied to the LATEX_OUTPUT output @@ -1767,7 +1767,7 @@ LATEX_EXTRA_STYLESHEET = # markers available. # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_EXTRA_FILES = +LATEX_EXTRA_FILES = # If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated is # prepared for conversion to PDF (using ps2pdf or pdflatex). The PDF file will @@ -1875,14 +1875,14 @@ RTF_HYPERLINKS = NO # default style sheet that doxygen normally uses. # This tag requires that the tag GENERATE_RTF is set to YES. -RTF_STYLESHEET_FILE = +RTF_STYLESHEET_FILE = # Set optional variables used in the generation of an RTF document. Syntax is # similar to doxygen's config file. A template extensions file can be generated # using doxygen -e rtf extensionFile. # This tag requires that the tag GENERATE_RTF is set to YES. -RTF_EXTENSIONS_FILE = +RTF_EXTENSIONS_FILE = # If the RTF_SOURCE_CODE tag is set to YES then doxygen will include source code # with syntax highlighting in the RTF output. @@ -1927,7 +1927,7 @@ MAN_EXTENSION = .3 # MAN_EXTENSION with the initial . removed. # This tag requires that the tag GENERATE_MAN is set to YES. -MAN_SUBDIR = +MAN_SUBDIR = # If the MAN_LINKS tag is set to YES and doxygen generates man output, then it # will generate one additional man file for each entity documented in the real @@ -2040,7 +2040,7 @@ PERLMOD_PRETTY = YES # overwrite each other's variables. # This tag requires that the tag GENERATE_PERLMOD is set to YES. -PERLMOD_MAKEVAR_PREFIX = +PERLMOD_MAKEVAR_PREFIX = #--------------------------------------------------------------------------- # Configuration options related to the preprocessor @@ -2081,7 +2081,7 @@ SEARCH_INCLUDES = YES # preprocessor. # This tag requires that the tag SEARCH_INCLUDES is set to YES. -INCLUDE_PATH = +INCLUDE_PATH = # You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard # patterns (like *.h and *.hpp) to filter out the header-files in the @@ -2089,7 +2089,7 @@ INCLUDE_PATH = # used. # This tag requires that the tag ENABLE_PREPROCESSING is set to YES. -INCLUDE_FILE_PATTERNS = +INCLUDE_FILE_PATTERNS = # The PREDEFINED tag can be used to specify one or more macro names that are # defined before the preprocessor is started (similar to the -D option of e.g. @@ -2099,7 +2099,7 @@ INCLUDE_FILE_PATTERNS = # recursively expanded use the := operator instead of the = operator. # This tag requires that the tag ENABLE_PREPROCESSING is set to YES. -PREDEFINED = +PREDEFINED = # If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then this # tag can be used to specify a list of macro names that should be expanded. The @@ -2108,7 +2108,7 @@ PREDEFINED = # definition found in the source code. # This tag requires that the tag ENABLE_PREPROCESSING is set to YES. -EXPAND_AS_DEFINED = +EXPAND_AS_DEFINED = # If the SKIP_FUNCTION_MACROS tag is set to YES then doxygen's preprocessor will # remove all references to function-like macros that are alone on a line, have @@ -2137,13 +2137,13 @@ SKIP_FUNCTION_MACROS = YES # the path). If a tag file is not located in the directory in which doxygen is # run, you must also specify the path to the tagfile here. -TAGFILES = +TAGFILES = # When a file name is specified after GENERATE_TAGFILE, doxygen will create a # tag file that is based on the input files it reads. See section "Linking to # external documentation" for more information about the usage of tag files. -GENERATE_TAGFILE = +GENERATE_TAGFILE = # If the ALLEXTERNALS tag is set to YES, all external class will be listed in # the class index. If set to NO, only the inherited external classes will be @@ -2192,14 +2192,14 @@ CLASS_DIAGRAMS = YES # the mscgen tool resides. If left empty the tool is assumed to be found in the # default search path. -MSCGEN_PATH = +MSCGEN_PATH = # You can include diagrams made with dia in doxygen documentation. Doxygen will # then run dia to produce the diagram and insert it in the documentation. The # DIA_PATH tag allows you to specify the directory where the dia binary resides. # If left empty dia is assumed to be found in the default search path. -DIA_PATH = +DIA_PATH = # If set to YES the inheritance and collaboration graphs will hide inheritance # and usage relations if the target is undocumented or is not a class. @@ -2248,7 +2248,7 @@ DOT_FONTSIZE = 10 # the path where dot can find it using this tag. # This tag requires that the tag HAVE_DOT is set to YES. -DOT_FONTPATH = +DOT_FONTPATH = # If the CLASS_GRAPH tag is set to YES then doxygen will generate a graph for # each documented class showing the direct and indirect inheritance relations. @@ -2394,26 +2394,26 @@ INTERACTIVE_SVG = YES # found. If left blank, it is assumed the dot tool can be found in the path. # This tag requires that the tag HAVE_DOT is set to YES. -DOT_PATH = +DOT_PATH = # The DOTFILE_DIRS tag can be used to specify one or more directories that # contain dot files that are included in the documentation (see the \dotfile # command). # This tag requires that the tag HAVE_DOT is set to YES. -DOTFILE_DIRS = +DOTFILE_DIRS = # The MSCFILE_DIRS tag can be used to specify one or more directories that # contain msc files that are included in the documentation (see the \mscfile # command). -MSCFILE_DIRS = +MSCFILE_DIRS = # The DIAFILE_DIRS tag can be used to specify one or more directories that # contain dia files that are included in the documentation (see the \diafile # command). -DIAFILE_DIRS = +DIAFILE_DIRS = # When using plantuml, the PLANTUML_JAR_PATH tag should be used to specify the # path where java can find the plantuml.jar file. If left blank, it is assumed @@ -2421,17 +2421,17 @@ DIAFILE_DIRS = # generate a warning when it encounters a \startuml command in this case and # will not generate output for the diagram. -PLANTUML_JAR_PATH = +PLANTUML_JAR_PATH = # When using plantuml, the PLANTUML_CFG_FILE tag can be used to specify a # configuration file for plantuml. -PLANTUML_CFG_FILE = +PLANTUML_CFG_FILE = # When using plantuml, the specified paths are searched for files specified by # the !include statement in a plantuml block. -PLANTUML_INCLUDE_PATH = +PLANTUML_INCLUDE_PATH = # The DOT_GRAPH_MAX_NODES tag can be used to set the maximum number of nodes # that will be shown in the graph. If the number of nodes in a graph becomes diff --git a/Makefile b/Makefile index 3fc8148..c368d50 100644 --- a/Makefile +++ b/Makefile @@ -23,7 +23,7 @@ LDFLAGS := -lm $(TARGET): $(OBJS) Makefile $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) -doc: $(SRCS) Makefile +doc: $(SRCS) Makefile Doxyfile doxygen format: $(SRCS) $(HDRS) Makefile diff --git a/src/arith/integer.c b/src/arith/integer.c index 60ce8c3..5239746 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -13,6 +13,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" /** * return the numeric value of this cell, as a C primitive double, not @@ -40,9 +41,7 @@ struct cons_pointer make_integer( int64_t value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; -#ifdef DEBUG - dump_object( stderr, result ); -#endif + debug_dump_object( result, DEBUG_ARITH ); return result; } diff --git a/src/arith/peano.c b/src/arith/peano.c index 763414e..4cb8abd 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -16,6 +16,7 @@ #include "consspaceobject.h" #include "conspage.h" +#include "debug.h" #include "equal.h" #include "integer.h" #include "intern.h" @@ -86,8 +87,8 @@ long double to_long_double( struct cons_pointer arg ) { break; } - fputws( L"to_long_double( ", stderr ); - print( stderr, arg ); + debug_print( L"to_long_double( ", DEBUG_ARITH ); + debug_print_object( arg, DEBUG_ARITH ); fwprintf( stderr, L") => %lf\n", result ); return result; @@ -129,13 +130,11 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); -#ifdef DEBUG - fputws( L"add_2( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - fputws( L")\n", stderr ); -#endif + debug_print( L"add_2( arg1 = ", DEBUG_ARITH ); + debug_print_object( arg1, DEBUG_ARITH ); + debug_print( L"; arg2 = ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { result = arg2; @@ -209,11 +208,9 @@ struct cons_pointer add_2( struct stack_frame *frame, } } -#ifdef DEBUG - fputws( L"}; => ", stderr ); - print( stderr, arg2 ); - fputws( L"\n", stderr ); -#endif + debug_print( L"}; => ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); return result; } @@ -267,13 +264,11 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); -#ifdef DEBUG - fputws( L"multiply_2( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - fputws( L")\n", stderr ); -#endif + debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH ); + debug_print_object( arg1, DEBUG_ARITH ); + debug_print( L"; arg2 = ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L")", DEBUG_ARITH ); if ( zerop( arg1 ) ) { result = arg2; @@ -348,11 +343,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, } } -#ifdef DEBUG - fputws( L" => ", stderr ); - print( stderr, arg2 ); - fputws( L"\n", stderr ); -#endif + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); return result; } diff --git a/src/arith/ratio.c b/src/arith/ratio.c index afea5b0..f12acbb 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -13,7 +13,7 @@ #include "conspage.h" #include "consspaceobject.h" -#include "dump.h" +#include "debug.h" #include "equal.h" #include "integer.h" #include "lispops.h" @@ -332,9 +332,8 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer, ( "Dividend and divisor of a ratio must be integers" ), frame_pointer ); } -#ifdef DEBUG - dump_object( stderr, result ); -#endif + debug_dump_object( result, DEBUG_ARITH ); + return result; } diff --git a/src/arith/real.c b/src/arith/real.c index d3786dd..84ba899 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -9,7 +9,7 @@ #include "conspage.h" #include "consspaceobject.h" -#include "dump.h" +#include "debug.h" #include "read.h" /** @@ -23,9 +23,7 @@ struct cons_pointer make_real( long double value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; -#ifdef DEBUG - dump_object( stderr, result ); -#endif + debug_dump_object( result, DEBUG_ARITH ); return result; } diff --git a/src/debug.c b/src/debug.c new file mode 100644 index 0000000..27f7634 --- /dev/null +++ b/src/debug.c @@ -0,0 +1,65 @@ +/** + * debug.c + * + * Better debug log messages. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "consspaceobject.h" +#include "debug.h" +#include "dump.h" +#include "print.h" + +/** + * the controlling flags for `debug_print`; set in `init.c`, 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 + * turn debugging on for only one part of the system. + */ +void debug_print( wchar_t *message, int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + fputws( message, stderr ); + } +#endif +} + +/** + * print the object indicated by this `pointer` to stderr, if `verbosity` + * matches `level`.`verbosity is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. + */ +void debug_print_object( struct cons_pointer pointer, int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + print( stderr, pointer ); + } +#endif +} + +/** + * Like `dump_object`, q.v., but protected by the verbosity mechanism. + */ +void debug_dump_object( struct cons_pointer pointer, int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + dump_object( stderr, pointer ); + } +#endif +} diff --git a/src/debug.h b/src/debug.h new file mode 100644 index 0000000..9c0448b --- /dev/null +++ b/src/debug.h @@ -0,0 +1,28 @@ +/** + * debug.h + * + * Better debug log messages. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include + +#ifndef __debug_print_h +#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 + +extern int verbosity; +void debug_print( wchar_t *message, int level ); +void debug_print_object( struct cons_pointer pointer, int level ); +void debug_dump_object( struct cons_pointer pointer, int level ); +#endif diff --git a/src/init.c b/src/init.c index 48516f6..bb722ae 100644 --- a/src/init.c +++ b/src/init.c @@ -11,26 +11,32 @@ #include #include +#include #include #include #include "version.h" #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "intern.h" #include "lispops.h" #include "peano.h" #include "print.h" #include "repl.h" +// extern char *optarg; /* defined in unistd.h */ + void bind_function( char *name, struct cons_pointer ( *executable ) - ( struct stack_frame *, struct cons_pointer ) ) { + ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ) { deep_bind( c_string_to_lisp_symbol( name ), make_function( NIL, executable ) ); } void bind_special( char *name, struct cons_pointer ( *executable ) - ( struct stack_frame * frame, struct cons_pointer env ) ) { + ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ) { deep_bind( c_string_to_lisp_symbol( name ), make_special( NIL, executable ) ); } @@ -46,7 +52,7 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; - while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) { + while ( ( option = getopt( argc, argv, "pdcv:" ) ) != -1 ) { switch ( option ) { case 'c': print_use_colours = true; @@ -57,6 +63,8 @@ int main( int argc, char *argv[] ) { case 'p': show_prompt = true; break; + case 'v': + verbosity = atoi( optarg ); default: fwprintf( stderr, L"Unexpected option %c\n", option ); break; @@ -68,9 +76,15 @@ int main( int argc, char *argv[] ) { L"Post scarcity software environment version %s\n\n", VERSION ); } - +#ifdef DEBUG + fputws( L"About to initialise cons pages\n", stderr ); +#endif initialise_cons_pages( ); +#ifdef DEBUG + fputws( L"Initialised cons pages, about to bind\n", stderr ); +#endif + /* * privileged variables (keywords) */ diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 13d8373..75bcdc8 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -18,6 +18,7 @@ #include "consspaceobject.h" #include "conspage.h" +#include "dump.h" /** * Flag indicating whether conspage initialisation has been done. @@ -168,7 +169,7 @@ void free_cell( struct cons_pointer pointer ) { fwprintf( stderr, L"About to free vector-space object at %ld\n", cell->payload.vectorp.address ); #endif - free( ( void * ) cell->payload.vectorp.address ); + //free( ( void * ) cell->payload.vectorp.address ); break; } diff --git a/src/memory/conspage.h b/src/memory/conspage.h index 7b8b930..bc1361e 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -19,7 +19,7 @@ * 4294967296. * * Note that this means the total number of addressable cons cells is - * 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are + * 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are * up to a maximum of 4e9 of heap space objects, each of potentially * 4e9 bytes. So we're talking about a potential total of 8e100 bytes * of addressable memory, which is only slightly more than the @@ -38,7 +38,7 @@ struct cons_page { }; /** - * The (global) pointer to the (global) freelist. Not sure whether this ultimately + * The (global) pointer to the (global) freelist. Not sure whether this ultimately * belongs in this file. */ extern struct cons_pointer freelist; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 44b6a79..47bbed0 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -133,7 +133,7 @@ * A pointer to an object in vector space. */ #define VECTORPOINTTAG "VECP" -#define VECTORPOINTTV 0 +#define VECTORPOINTTV 1346585942 /** * An open write stream. */ @@ -263,9 +263,10 @@ * An indirect pointer to a cons cell */ struct cons_pointer { - uint32_t page; /* the index of the page on which this cell - * resides */ - uint32_t offset; /* the index of the cell within the page */ + /** the index of the page on which this cell resides */ + uint32_t page; + /** the index of the cell within the page */ + uint32_t offset; }; /* @@ -421,7 +422,7 @@ struct vectorp_payload { * tag. */ uint32_t value; /* the tag considered as a number */ } tag; - struct vector_space_object *address; + void *address; /* the address of the actual vector space * object (TODO: will change when I actually * implement vector space) */ diff --git a/src/memory/cursor.c b/src/memory/cursor.c new file mode 100644 index 0000000..31a38b2 --- /dev/null +++ b/src/memory/cursor.c @@ -0,0 +1,9 @@ +/* + * a cursor is a cons-space object which holds: + * 1. a pointer to a vector (i.e. a vector-space object which holds an + * array of `cons_pointer`); + * 2. an integer offset into that array. + * + * this provides a mechanism for iterating through vectors (actually, in + * either direction) + */ diff --git a/src/memory/cursor.h b/src/memory/cursor.h new file mode 100644 index 0000000000000000000000000000000000000000..a50aff600d3015faae07bdd40e47973ce43ee241 GIT binary patch literal 614 zcmZWm!A=4(6!g4b@d6hmWLeOJpvH)3xR5|Vx$c&3$rei=X}gg9dtX~H7&qC&wDac8 zbb6gm0v!Ne8;d5b2n75txMGGmiP{3k{T?+q1f~=rIj~UxU*@T3WK-&4hC6& z2rKDl-VEZmfM@H`>kez9MYCr*<@_b^XOatTMG3Vog@Nf}21j8m?S(;_bpcHmn1hBU z0T12}VcmdYj_7BqH_%Ixw%n4)7Vfyfx^&xaAx5-WN1CG$cHvj+t literal 0 HcmV?d00001 diff --git a/src/memory/dump.c b/src/memory/dump.c index 5aaedfb..e0c2bbc 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -20,6 +20,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "print.h" #include "stack.h" #include "vectorspace.h" @@ -111,11 +112,25 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { dump_string_cell( output, L"Symbol", pointer ); break; case VECTORPOINTTV:{ + fwprintf( output, + L"\t\tPointer to vector-space object at %p\n", + cell.payload.vectorp.address ); struct vector_space_object *vso = cell.payload.vectorp.address; fwprintf( output, L"\t\tVector space object of type %4.4s, payload size %d bytes\n", - vso->header.tag, vso->header.size ); + &vso->header.tag.bytes, vso->header.size ); + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + dump_frame( output, pointer ); + break; + default: + fputws( L"(Unknown vector type)\n", output ); + break; + } } break; + default: + fputws( L"(Unknown cons space type)\n", output ); + break; } } diff --git a/src/memory/stack.c b/src/memory/stack.c index 9f0f6f8..069b1ed 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -19,6 +19,8 @@ #include "consspaceobject.h" #include "conspage.h" +#include "debug.h" +#include "dump.h" #include "lispops.h" #include "print.h" #include "stack.h" @@ -30,21 +32,24 @@ */ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { struct stack_frame *result = NULL; - fputws + debug_print ( L"get_stack_frame: about to get a pointer to the vector space object\n", - stderr ); + DEBUG_ALLOC ); struct vector_space_object *vso = pointer2cell( pointer ).payload.vectorp.address; - fputws( L"get_stack_frame: got a pointer, about to test it\n", stderr ); + debug_print( L"get_stack_frame: got a pointer, about to test it\n", + DEBUG_ALLOC ); - if ( vectorpointp( pointer ) ) { // && stackframep(vso)){ - fputws( L"get_stack_frame: pointer is good, about to set the result\n", - stderr ); + if ( vectorpointp( pointer ) && stackframep( vso ) ) { + debug_print + ( L"get_stack_frame: pointer is good, about to set the result\n", + DEBUG_ALLOC ); result = ( struct stack_frame * ) &( vso->payload ); - fputws( L"get_stack_frame: all good, returning\n", stderr ); + fwprintf( stderr, L"get_stack_frame: all good, returning %p\n", + result ); } else { - fputws( L"get_stack_frame: fail, returning NULL\n", stderr ); + debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_ALLOC ); } return result; @@ -57,11 +62,20 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { * @return the new frame, or NULL if memory is exhausted. */ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { - fputws( L"Entering make_empty_frame\n", stderr ); + debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC ); struct cons_pointer result = make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) ); + + debug_dump_object( result, DEBUG_ALLOC ); + + fwprintf( stderr, + 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 ) ) { - fputws( L"make_empty_frame: about to call get_stack_frame\n", stderr ); + debug_print( L"make_empty_frame: about to call get_stack_frame\n", + DEBUG_ALLOC ); struct stack_frame *frame = get_stack_frame( result ); /* * TODO: later, pop a frame off a free-list of stack frames @@ -69,9 +83,10 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { fwprintf( stderr, L"make_empty_frame: about to set previous to %4.4s\n", - pointer2cell( previous ).tag ); + &pointer2cell( previous ).tag.bytes ); frame->previous = previous; - fputws( L"make_empty_frame: about to call inc_ref\n", stderr ); + debug_print( L"make_empty_frame: about to call inc_ref\n", + DEBUG_ALLOC ); inc_ref( previous ); /* @@ -82,13 +97,13 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { frame->function = NIL; frame->args = 0; - fputws( L"make_empty_frame: about to initialise arg registers\n", - stderr ); + debug_print( L"make_empty_frame: about to initialise arg registers\n", + DEBUG_ALLOC ); for ( int i = 0; i < args_in_frame; i++ ) { set_reg( frame, i, NIL ); } } - fputws( L"Leaving make_empty_frame\n", stderr ); + debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); return result; } @@ -104,7 +119,7 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_pointer args, struct cons_pointer env ) { - fputws( L"Entering make_stack_frame\n", stderr ); + debug_print( L"Entering make_stack_frame\n", DEBUG_ALLOC ); struct cons_pointer result = make_empty_frame( previous ); if ( nilp( result ) ) { @@ -164,12 +179,11 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, frame->more = more; inc_ref( more ); } -#ifdef DEBUG - dump_frame( stderr, result ); -#endif + + debug_dump_object( result, DEBUG_ALLOC ); } } - fputws( L"Leaving make_stack_frame\n", stderr ); + debug_print( L"Leaving make_stack_frame\n", DEBUG_ALLOC ); return result; } @@ -185,7 +199,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_pointer make_special_frame( struct cons_pointer previous, struct cons_pointer args, struct cons_pointer env ) { - fputws( L"Entering make_special_frame\n", stderr ); + debug_print( L"Entering make_special_frame\n", DEBUG_ALLOC ); struct cons_pointer result = make_empty_frame( previous ); @@ -213,12 +227,11 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, frame->more = args; inc_ref( args ); } -#ifdef DEBUG - dump_frame( stderr, result ); -#endif + + debug_dump_object( result, DEBUG_ALLOC ); } } - fputws( L"Leaving make_special_frame\n", stderr ); + debug_print( L"Leaving make_special_frame\n", DEBUG_ALLOC ); return result; } diff --git a/src/memory/stack.h b/src/memory/stack.h index 20acd73..b56f432 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -33,13 +33,13 @@ /** * is this vector-space object a stack frame? */ -#define stackframep(vso)(vso->header.tag.value == STACKFRAMETV) +#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) +#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);} struct stack_frame *get_stack_frame( struct cons_pointer pointer ); diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index db39b48..7dbe682 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -21,6 +21,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "dump.h" #include "vectorspace.h" @@ -30,19 +31,18 @@ * NOTE that `tag` should be the vector-space tag of the particular type of * vector-space object, NOT `VECTORPOINTTAG`. */ -struct cons_pointer make_vec_pointer( char *tag, - struct vector_space_object *address ) { +struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { fputws( L"Entered make_vec_pointer\n", stderr ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); - struct cons_space_object cell = pointer2cell( pointer ); + struct cons_space_object *cell = &pointer2cell( pointer ); fwprintf( stderr, - L"make_vec_pointer: allocated cell, about to write tag '%s'\n", - tag ); - strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 ); - fputws( L"make_vec_pointer: tag written, about to set pointer address\n", - stderr ); - cell.payload.vectorp.address = address; - fputws( L"make_vec_pointer: all good, returning\n", stderr ); + L"make_vec_pointer: tag written, about to set pointer address to %p\n", + address ); + cell->payload.vectorp.address = address; + fwprintf( stderr, L"make_vec_pointer: all good, returning pointer to %p\n", + cell->payload.vectorp.address ); + + dump_object( stderr, pointer ); return pointer; } @@ -66,24 +66,32 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { struct vector_space_object *vso = malloc( padded ); if ( vso != NULL ) { - fwprintf( stderr, L"make_vso: about to write tag '%s'\n", tag ); + fwprintf( stderr, + 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.vecp = make_vec_pointer( tag, vso ); + result = make_vec_pointer( vso ); + dump_object( stderr, result ); + vso->header.vecp = result; + // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); + vso->header.size = payload_size; #ifdef DEBUG fwprintf( stderr, - L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld\n", - tag, total_size, payload_size ); + L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n", + &vso->header.tag.bytes, total_size, vso->header.size, vso, + &vso->payload ); if ( padded != total_size ) { fwprintf( stderr, L"\t\tPadded from %d to %d\n", total_size, padded ); } #endif - - result = vso->header.vecp; } - fputws( L"make_vso: all good, returning\n", stderr ); +#ifdef DEBUG + fwprintf( stderr, L"make_vso: all good, returning pointer to %p\n", + pointer2cell( result ).payload.vectorp.address ); +#endif return result; } diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index caec968..1438d37 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -40,7 +40,7 @@ #define VECTORTAG "VECT" #define VECTORTV 0 -#define pointer_to_vso(pointer)((vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : NULL)) +#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)) struct cons_pointer make_vso( char *tag, uint64_t payload_size ); diff --git a/src/ops/intern.c b/src/ops/intern.c index 100589a..8dea7c8 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -21,6 +21,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "equal.h" #include "lispops.h" #include "print.h" @@ -56,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_space_object entry = pointer2cell( pointer2cell( next ).payload.cons.car ); - fputws( L"Internedp: checking whether `", stderr ); - print( stderr, key ); - fputws( L"` equals `", stderr ); - print( stderr, entry.payload.cons.car ); - fputws( L"`\n", stderr ); + 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 ); if ( equal( key, entry.payload.cons.car ) ) { result = entry.payload.cons.car; } } } else { - fputws( L"`", stderr ); - print( stderr, key ); - fputws( L"` is a ", stderr ); - print( stderr, c_type( key ) ); - fputws( L", not a SYMB", stderr ); + 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 ); } return result; @@ -120,7 +121,17 @@ 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 ); + oblist = bind( key, value, oblist ); + + debug_print( L"Leaving deep_bind\n", DEBUG_ALLOC ); + return oblist; } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 1e6712d..da3bc82 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -26,6 +26,8 @@ #include "consspaceobject.h" #include "conspage.h" +#include "debug.h" +#include "dump.h" #include "equal.h" #include "integer.h" #include "intern.h" @@ -83,9 +85,8 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer parent_pointer, struct cons_pointer form, struct cons_pointer env ) { - fputws( L"eval_form: ", stderr ); - print( stderr, form ); - fputws( L"\n", stderr ); + debug_print( L"eval_form: ", DEBUG_EVAL ); + debug_dump_object( form, DEBUG_EVAL ); struct cons_pointer result = NIL; struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); @@ -148,9 +149,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { } } - fputws( L"compose_body returning ", stderr ); - print( stderr, body ); - fputws( L"\n", stderr ); + debug_print( L"compose_body returning ", DEBUG_LAMBDA ); + debug_dump_object( body, DEBUG_LAMBDA ); return body; } @@ -180,13 +180,10 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, } void log_binding( struct cons_pointer name, struct cons_pointer val ) { -#ifdef DEBUG - fputws( L"\n\tBinding ", stderr ); - print( stderr, name ); - fputws( L" to ", stderr ); - print( stderr, val ); - fputws( L"\"\n", stderr ); -#endif + debug_print( L"\n\tBinding ", DEBUG_ALLOC ); + debug_dump_object( name, DEBUG_ALLOC ); + debug_print( L" to ", DEBUG_ALLOC ); + debug_dump_object( val, DEBUG_ALLOC ); } /** @@ -236,9 +233,9 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, while ( !nilp( body ) ) { struct cons_pointer sexpr = c_car( body ); body = c_cdr( body ); -#ifdef DEBUG - fputws( L"In lambda: ", stderr ); -#endif + + debug_print( L"In lambda: ", DEBUG_LAMBDA ); + result = eval_form( frame, frame_pointer, sexpr, new_env ); } @@ -414,8 +411,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer result = frame->arg[0]; struct cons_space_object cell = pointer2cell( frame->arg[0] ); + debug_print( L"Eval: ", DEBUG_EVAL ); #ifdef DEBUG - fputws( L"Eval: ", stderr ); dump_frame( stderr, frame_pointer ); #endif @@ -455,11 +452,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, break; } -#ifdef DEBUG - fputws( L"Eval returning ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); -#endif + debug_print( L"Eval returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); return result; } @@ -476,7 +470,7 @@ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { #ifdef DEBUG - fputws( L"Apply: ", stderr ); + debug_print( L"Apply: ", DEBUG_EVAL ); dump_frame( stderr, frame_pointer ); #endif set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); @@ -484,11 +478,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer result = c_apply( frame, frame_pointer, env ); -#ifdef DEBUG - fputws( L"Apply returning ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); -#endif + debug_print( L"Apply returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); return result; } @@ -690,13 +681,20 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { +#ifdef DEBUG + debug_print( L"entering lisp_read\n", DEBUG_IO ); +#endif FILE *input = stdin; if ( readp( frame->arg[0] ) ) { input = pointer2cell( frame->arg[0] ).payload.stream.stream; } - return read( frame, frame_pointer, input ); + struct cons_pointer result = read( frame, frame_pointer, input ); + debug_print( L"lisp_read returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + return result; } @@ -745,23 +743,22 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { -#ifdef DEBUG - fputws( L"Entering print\n", stderr ); -#endif + debug_print( L"Entering print\n", DEBUG_IO ); struct cons_pointer result = NIL; FILE *output = stdout; if ( writep( frame->arg[1] ) ) { + 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_print( L"lisp_print: about to print\n", DEBUG_IO ); + debug_dump_object( frame->arg[0], DEBUG_IO ); result = print( output, frame->arg[0] ); -#ifdef DEBUG - fputws( L"Print returning ", stderr ); - // print( stderr, result ); - fputws( L"\n", stderr ); -#endif + debug_print( L"lisp_print returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); return result; } @@ -828,8 +825,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, for ( int i = 0; i < args_in_frame && !done; i++ ) { struct cons_pointer clause_pointer = frame->arg[i]; - fputws( L"Cond clause: ", stderr ); - print( stderr, clause_pointer ); + debug_print( L"Cond clause: ", DEBUG_EVAL ); + debug_dump_object( clause_pointer, DEBUG_EVAL ); if ( consp( clause_pointer ) ) { struct cons_space_object cell = pointer2cell( clause_pointer ); @@ -876,8 +873,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer ) { - fwprintf( stderr, L"\nERROR: " ); - print( stderr, message ); + debug_print( L"\nERROR: ", DEBUG_EVAL ); + debug_dump_object( message, DEBUG_EVAL ); struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( message ); diff --git a/src/ops/read.c b/src/ops/read.c index 7d21dbe..e3cb480 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -18,6 +18,8 @@ #include #include "consspaceobject.h" +#include "debug.h" +#include "dump.h" #include "integer.h" #include "intern.h" #include "lispops.h" @@ -59,6 +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 ) { + debug_print( L"entering read_continuation\n", DEBUG_IO ); struct cons_pointer result = NIL; wint_t c; @@ -141,6 +144,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, break; } } + debug_print( L"read_continuation returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); return result; } @@ -154,6 +159,7 @@ 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; int64_t accumulator = 0; int64_t dividend = 0; @@ -210,9 +216,6 @@ struct cons_pointer read_number( struct stack_frame *frame, if ( negative ) { rv = 0 - rv; } -#ifdef DEBUG - fwprintf( stderr, L"read_numer returning %Lf\n", rv ); -#endif result = make_real( rv ); } else if ( dividend != 0 ) { result = @@ -225,6 +228,9 @@ struct cons_pointer read_number( struct stack_frame *frame, result = make_integer( accumulator ); } + debug_print( L"read_number returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + return result; } @@ -248,12 +254,9 @@ struct cons_pointer read_list( struct stack_frame *frame, make_cons( car, read_list( frame, frame_pointer, input, fgetwc( input ) ) ); + } else { + debug_print( L"End of list detected\n", DEBUG_IO ); } -#ifdef DEBUG - else { - fwprintf( stderr, L"End of list detected\n" ); - } -#endif return result; } @@ -324,11 +327,8 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { break; } -#ifdef DEBUG - fputws( L"Read symbol '", stderr ); - print( stderr, result ); - fputws( L"'\n", stderr ); -#endif + debug_print( L"read_symbol returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); return result; } diff --git a/src/repl.c b/src/repl.c index d077ba8..f0dcbfa 100644 --- a/src/repl.c +++ b/src/repl.c @@ -13,6 +13,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "dump.h" #include "intern.h" #include "lispops.h" #include "read.h" @@ -32,19 +33,25 @@ */ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { struct cons_pointer result = NIL; + fputws( L"Entered repl_read\n", stderr ); struct cons_pointer frame_pointer = make_empty_frame( NIL ); + fputws( L"repl_read: got stack_frame pointer\n", stderr ); + dump_object( stderr, frame_pointer ); if ( !nilp( frame_pointer ) ) { inc_ref( frame_pointer ); struct stack_frame *frame = get_stack_frame( frame_pointer ); if ( frame != NULL ) { - + fputws( L"repl_read: about to set register\n", stderr ); set_reg( frame, 0, stream_pointer ); + fputws( L"repl_read: about to read\n", stderr ); struct cons_pointer result = lisp_read( frame, frame_pointer, oblist ); } dec_ref( frame_pointer ); } + fputws( L"repl_read: returning\n", stderr ); + dump_object( stderr, result ); return result; } @@ -53,6 +60,7 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { * Dummy up a Lisp eval call with its own stack frame. */ struct cons_pointer repl_eval( struct cons_pointer input ) { + fputws( L"Entered repl_eval\n", stderr ); struct cons_pointer result = NIL; struct cons_pointer frame_pointer = make_empty_frame( NIL ); if ( !nilp( frame_pointer ) ) { @@ -66,6 +74,8 @@ struct cons_pointer repl_eval( struct cons_pointer input ) { dec_ref( frame_pointer ); } + fputws( L"repl_eval: returning\n", stderr ); + dump_object( stderr, result ); return result; } @@ -75,6 +85,7 @@ struct cons_pointer repl_eval( struct cons_pointer input ) { */ struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer value ) { + struct cons_pointer result = NIL; struct cons_pointer frame_pointer = make_empty_frame( NIL ); if ( !nilp( frame_pointer ) ) { @@ -102,12 +113,12 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer, void repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, bool show_prompt ) { + fputws( L"Entered repl\n", stderr ); struct cons_pointer input_stream = make_read_stream( in_stream ); - pointer2cell( input_stream ).count = MAXREFERENCE; + inc_ref( input_stream ); struct cons_pointer output_stream = make_write_stream( out_stream ); - pointer2cell( output_stream ).count = MAXREFERENCE; - + inc_ref( output_stream ); while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { if ( show_prompt ) { fwprintf( out_stream, L"\n:: " ); From e52ccce0ebce25dc02e170db050a51365f171f2a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 28 Dec 2018 15:50:37 +0000 Subject: [PATCH 19/22] Much progress! Half the unit tests pass. --- src/arith/peano.c | 26 ++++----- src/arith/ratio.c | 52 ++++++++---------- src/debug.c | 19 +++++++ src/debug.h | 4 ++ src/init.c | 88 +++++++++++++++--------------- src/memory/conspage.c | 29 ++++------ src/memory/consspaceobject.c | 25 +++++---- src/memory/consspaceobject.h | 4 +- src/memory/dump.c | 26 +++++---- src/memory/stack.c | 57 ++++++++++--------- src/memory/vectorspace.c | 24 ++++---- src/ops/lispops.c | 45 +++++++-------- src/ops/print.c | 9 ++- src/ops/read.c | 36 ++++++------ src/repl.c | 62 ++++++++------------- utils_src/debugflags/debugflags | Bin 0 -> 8520 bytes utils_src/debugflags/debugflags.c | 43 +++++++++++++++ 17 files changed, 296 insertions(+), 253 deletions(-) create mode 100755 utils_src/debugflags/debugflags create mode 100644 utils_src/debugflags/debugflags.c diff --git a/src/arith/peano.c b/src/arith/peano.c index 4cb8abd..9f5e0fb 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -89,7 +89,7 @@ long double to_long_double( struct cons_pointer arg ) { debug_print( L"to_long_double( ", DEBUG_ARITH ); debug_print_object( arg, DEBUG_ARITH ); - fwprintf( stderr, L") => %lf\n", result ); + debug_printf( DEBUG_ARITH, L") => %lf\n", result ); return result; } @@ -166,7 +166,7 @@ struct cons_pointer add_2( struct stack_frame *frame, break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot add: not a number" ), + ( L"Cannot add: not a number" ), frame_pointer ); break; } @@ -190,7 +190,7 @@ struct cons_pointer add_2( struct stack_frame *frame, break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot add: not a number" ), + ( L"Cannot add: not a number" ), frame_pointer ); break; } @@ -203,7 +203,7 @@ struct cons_pointer add_2( struct stack_frame *frame, default: result = exceptionp( arg2 ) ? arg2 : throw_exception( c_string_to_lisp_string - ( "Cannot add: not a number" ), + ( L"Cannot add: not a number" ), frame_pointer ); } } @@ -300,7 +300,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), + ( L"Cannot multiply: not a number" ), frame_pointer ); break; } @@ -326,7 +326,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), + ( L"Cannot multiply: not a number" ), frame_pointer ); } break; @@ -337,7 +337,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), + ( L"Cannot multiply: not a number" ), frame_pointer ); break; } @@ -473,7 +473,7 @@ struct cons_pointer lisp_subtract( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot subtract: not a number" ), + ( L"Cannot subtract: not a number" ), frame_pointer ); break; } @@ -506,7 +506,7 @@ struct cons_pointer lisp_subtract( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot subtract: not a number" ), + ( L"Cannot subtract: not a number" ), frame_pointer ); break; } @@ -518,7 +518,7 @@ struct cons_pointer lisp_subtract( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot subtract: not a number" ), + ( L"Cannot subtract: not a number" ), frame_pointer ); break; } @@ -580,7 +580,7 @@ struct cons_pointer lisp_divide( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot divide: not a number" ), + ( L"Cannot divide: not a number" ), frame_pointer ); break; } @@ -615,7 +615,7 @@ struct cons_pointer lisp_divide( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot divide: not a number" ), + ( L"Cannot divide: not a number" ), frame_pointer ); break; } @@ -627,7 +627,7 @@ struct cons_pointer lisp_divide( struct break; default: result = throw_exception( c_string_to_lisp_string - ( "Cannot divide: not a number" ), + ( L"Cannot divide: not a number" ), frame_pointer ); break; } diff --git a/src/arith/ratio.c b/src/arith/ratio.c index f12acbb..ca83335 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -78,7 +78,7 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, } else { result = throw_exception( make_cons( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to simplify_ratio" ), + ( L"Shouldn't happen: bad arg to simplify_ratio" ), arg ), frame_pointer ); } @@ -97,13 +97,11 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg2 ) { struct cons_pointer r, result; -#ifdef DEBUG - fputws( L"add_ratio_ratio( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - fputws( L")\n", stderr ); -#endif + debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH ); + debug_print_object( arg1, DEBUG_ARITH ); + debug_print( L"; arg2 = ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); @@ -119,9 +117,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, lcm = least_common_multiple( dr1v, dr2v ), m1 = lcm / dr1v, m2 = lcm / dr2v; -#ifdef DEBUG - fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); -#endif + debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); if ( dr1v == dr2v ) { r = make_ratio( frame_pointer, @@ -151,17 +147,15 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, } else { result = throw_exception( make_cons( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to add_ratio_ratio" ), + ( L"Shouldn't happen: bad arg to add_ratio_ratio" ), make_cons( arg1, make_cons( arg2, NIL ) ) ), frame_pointer ); } -#ifdef DEBUG - fputws( L" => ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); -#endif + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); return result; } @@ -188,7 +182,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, } else { result = throw_exception( make_cons( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to add_integer_ratio" ), + ( L"Shouldn't happen: bad arg to add_integer_ratio" ), make_cons( intarg, make_cons( ratarg, NIL ) ) ), @@ -210,7 +204,8 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, pointer2cell( arg2 ).payload. ratio.divisor, pointer2cell( arg2 ).payload. - ratio.dividend ), result = + ratio.dividend ), + result = multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -228,13 +223,12 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str cons_pointer arg2 ) { struct cons_pointer result; -#ifdef DEBUG - fputws( L"multiply_ratio_ratio( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - fputws( L")\n", stderr ); -#endif + debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH ); + debug_print_object( arg1, DEBUG_ARITH ); + debug_print( L"; arg2 = ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); + if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); @@ -259,7 +253,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str } else { result = throw_exception( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), + ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), frame_pointer ); } @@ -286,7 +280,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, } else { result = throw_exception( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to multiply_integer_ratio" ), + ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), frame_pointer ); } @@ -329,7 +323,7 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer, } else { result = throw_exception( c_string_to_lisp_string - ( "Dividend and divisor of a ratio must be integers" ), + ( L"Dividend and divisor of a ratio must be integers" ), frame_pointer ); } debug_dump_object( result, DEBUG_ARITH ); diff --git a/src/debug.c b/src/debug.c index 27f7634..657998f 100644 --- a/src/debug.c +++ b/src/debug.c @@ -8,6 +8,7 @@ */ #include +#include #include #include #include @@ -35,11 +36,27 @@ int verbosity = 0; void debug_print( wchar_t *message, int level ) { #ifdef DEBUG if ( level & verbosity ) { + fwide( stderr, 1 ); fputws( message, stderr ); } #endif } +/** + * `wprintf` adapted for the debug logging system. Print to stderr only + * `verbosity` matches `level`. All other arguments as for `wprintf`. + */ +void debug_printf( int level, wchar_t * format, ...) { + #ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + va_list(args); + va_start(args, format); + vfwprintf(stderr, format, args); + } + #endif +} + /** * print the object indicated by this `pointer` to stderr, if `verbosity` * matches `level`.`verbosity is a set of flags, see debug_print.h; so you can @@ -48,6 +65,7 @@ void debug_print( wchar_t *message, int level ) { void debug_print_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG if ( level & verbosity ) { + fwide( stderr, 1 ); print( stderr, pointer ); } #endif @@ -59,6 +77,7 @@ void debug_print_object( struct cons_pointer pointer, int level ) { void debug_dump_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG if ( level & verbosity ) { + fwide( stderr, 1 ); dump_object( stderr, pointer ); } #endif diff --git a/src/debug.h b/src/debug.h index 9c0448b..10d07c3 100644 --- a/src/debug.h +++ b/src/debug.h @@ -20,9 +20,13 @@ #define DEBUG_LAMBDA 16 #define DEBUG_BOOTSTRAP 32 #define DEBUG_IO 64 +#define DEBUG_REPL 128 extern int verbosity; + void debug_print( wchar_t *message, int level ); +void debug_printf( int level, wchar_t * format, ...); void debug_print_object( struct cons_pointer pointer, int level ); void debug_dump_object( struct cons_pointer pointer, int level ); + #endif diff --git a/src/init.c b/src/init.c index bb722ae..d81aa00 100644 --- a/src/init.c +++ b/src/init.c @@ -27,14 +27,14 @@ // extern char *optarg; /* defined in unistd.h */ -void bind_function( char *name, struct cons_pointer ( *executable ) +void bind_function( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { deep_bind( c_string_to_lisp_symbol( name ), make_function( NIL, executable ) ); } -void bind_special( char *name, struct cons_pointer ( *executable ) +void bind_special( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { deep_bind( c_string_to_lisp_symbol( name ), @@ -52,7 +52,7 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; - while ( ( option = getopt( argc, argv, "pdcv:" ) ) != -1 ) { + while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { case 'c': print_use_colours = true; @@ -65,6 +65,7 @@ int main( int argc, char *argv[] ) { break; case 'v': verbosity = atoi( optarg ); + break; default: fwprintf( stderr, L"Unexpected option %c\n", option ); break; @@ -76,62 +77,61 @@ int main( int argc, char *argv[] ) { L"Post scarcity software environment version %s\n\n", VERSION ); } -#ifdef DEBUG - fputws( L"About to initialise cons pages\n", stderr ); -#endif + + debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP ); + initialise_cons_pages( ); -#ifdef DEBUG - fputws( L"Initialised cons pages, about to bind\n", stderr ); -#endif + debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP ); /* * privileged variables (keywords) */ - deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); - deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); + deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL ); + deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE ); /* * primitive function operations */ - bind_function( "add", &lisp_add ); - bind_function( "apply", &lisp_apply ); - bind_function( "assoc", &lisp_assoc ); - bind_function( "car", &lisp_car ); - bind_function( "cdr", &lisp_cdr ); - bind_function( "cons", &lisp_cons ); - bind_function( "divide", &lisp_divide ); - bind_function( "eq", &lisp_eq ); - bind_function( "equal", &lisp_equal ); - bind_function( "eval", &lisp_eval ); - bind_function( "exception", &lisp_exception ); - bind_function( "multiply", &lisp_multiply ); - bind_function( "read", &lisp_read ); - bind_function( "oblist", &lisp_oblist ); - bind_function( "print", &lisp_print ); - bind_function( "progn", &lisp_progn ); - bind_function( "reverse", &lisp_reverse ); - bind_function( "set", &lisp_set ); - bind_function( "subtract", &lisp_subtract ); - bind_function( "throw", &lisp_exception ); - bind_function( "type", &lisp_type ); + bind_function( L"add", &lisp_add ); + bind_function( L"apply", &lisp_apply ); + bind_function( L"assoc", &lisp_assoc ); + bind_function( L"car", &lisp_car ); + bind_function( L"cdr", &lisp_cdr ); + bind_function( L"cons", &lisp_cons ); + bind_function( L"divide", &lisp_divide ); + bind_function( L"eq", &lisp_eq ); + bind_function( L"equal", &lisp_equal ); + bind_function( L"eval", &lisp_eval ); + bind_function( L"exception", &lisp_exception ); + bind_function( L"multiply", &lisp_multiply ); + bind_function( L"read", &lisp_read ); + bind_function( L"oblist", &lisp_oblist ); + bind_function( L"print", &lisp_print ); + bind_function( L"progn", &lisp_progn ); + bind_function( L"reverse", &lisp_reverse ); + bind_function( L"set", &lisp_set ); + bind_function( L"subtract", &lisp_subtract ); + bind_function( L"throw", &lisp_exception ); + bind_function( L"type", &lisp_type ); - bind_function( "+", &lisp_add ); - bind_function( "*", &lisp_multiply ); - bind_function( "-", &lisp_subtract ); - bind_function( "/", &lisp_divide ); - bind_function( "=", &lisp_equal ); + bind_function( L"+", &lisp_add ); + bind_function( L"*", &lisp_multiply ); + bind_function( L"-", &lisp_subtract ); + bind_function( L"/", &lisp_divide ); + bind_function( L"=", &lisp_equal ); /* * primitive special forms */ - bind_special( "cond", &lisp_cond ); - bind_special( "lambda", &lisp_lambda ); - /* bind_special( "λ", &lisp_lambda ); */ - bind_special( "nlambda", &lisp_nlambda ); - bind_special( "progn", &lisp_progn ); - bind_special( "quote", &lisp_quote ); - bind_special( "set!", &lisp_set_shriek ); + bind_special( L"cond", &lisp_cond ); + bind_special( L"lambda", &lisp_lambda ); + // bind_special( L"λ", &lisp_lambda ); + bind_special( L"nlambda", &lisp_nlambda ); + // bind_special( L"nλ", &lisp_nlambda ); + bind_special( L"progn", &lisp_progn ); + bind_special( L"quote", &lisp_quote ); + bind_special( L"set!", &lisp_set_shriek ); repl( stdin, stdout, stderr, show_prompt ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 75bcdc8..cf87028 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -18,6 +18,7 @@ #include "consspaceobject.h" #include "conspage.h" +#include "debug.h" #include "dump.h" /** @@ -65,7 +66,7 @@ void make_cons_page( ) { cell->count = MAXREFERENCE; cell->payload.free.car = NIL; cell->payload.free.cdr = NIL; - fwprintf( stderr, L"Allocated special cell NIL\n" ); + debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" ); break; case 1: /* @@ -79,7 +80,7 @@ void make_cons_page( ) { cell->payload.free.cdr = ( struct cons_pointer ) { 0, 1 }; - fwprintf( stderr, L"Allocated special cell T\n" ); + debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" ); break; } } else { @@ -96,7 +97,7 @@ void make_cons_page( ) { initialised_cons_pages++; } else { - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"FATAL: Failed to allocate memory for cons page %d\n", initialised_cons_pages ); exit( 1 ); @@ -128,10 +129,8 @@ void dump_pages( FILE * output ) { void free_cell( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); -#ifdef DEBUG - fwprintf( stderr, L"Freeing cell " ); - dump_object( stderr, pointer ); -#endif + debug_printf( DEBUG_ALLOC, L"Freeing cell " ); + debug_dump_object( pointer, DEBUG_ALLOC ); switch ( cell->tag.value ) { /* for all the types of cons-space object which point to other @@ -165,10 +164,8 @@ void free_cell( struct cons_pointer pointer ) { case VECTORPOINTTV: /* for vector space pointers, free the actual vector-space * object. Dangerous! */ -#ifdef DEBUG - fwprintf( stderr, L"About to free vector-space object at %ld\n", + debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n", cell->payload.vectorp.address ); -#endif //free( ( void * ) cell->payload.vectorp.address ); break; @@ -181,12 +178,12 @@ void free_cell( struct cons_pointer pointer ) { cell->payload.free.cdr = freelist; freelist = pointer; } else { - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", cell->count, pointer.page, pointer.offset ); } } else { - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", pointer.page, pointer.offset ); } @@ -218,13 +215,11 @@ struct cons_pointer allocate_cell( char *tag ) { cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; -#ifdef DEBUG - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"Allocated cell of type '%s' at %d, %d \n", tag, result.page, result.offset ); -#endif } else { - fwprintf( stderr, L"WARNING: Allocating non-free cell!" ); + debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); } } @@ -243,7 +238,7 @@ void initialise_cons_pages( ) { make_cons_page( ); conspageinitihasbeencalled = true; } else { - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); } } diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index acca2a8..f5cc8b8 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -20,6 +20,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "print.h" #include "stack.h" @@ -178,11 +179,13 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; /* TODO: There's a problem here. Sometimes the offsets on - * strings are quite massively off. */ + * strings are quite massively off. Fix is probably + * cell->payload.string.cdr = tsil */ cell->payload.string.cdr.offset = tail.offset; } else { - fwprintf( stderr, - L"Warning: only NIL and %s can be appended to %s\n", + // TODO: should throw an exception! + debug_printf( DEBUG_ALLOC, + L"Warning: only NIL and %s can be prepended to %s\n", tag, tag ); } @@ -249,26 +252,26 @@ struct cons_pointer make_write_stream( FILE * output ) { } /** - * Return a lisp string representation of this old skool ASCII string. + * Return a lisp string representation of this wide character string. */ -struct cons_pointer c_string_to_lisp_string( char *string ) { +struct cons_pointer c_string_to_lisp_string( wchar_t *string ) { struct cons_pointer result = NIL; - for ( int i = strlen( string ); i > 0; i-- ) { - result = make_string( ( wint_t ) string[i - 1], result ); + for ( int i = wcslen( string ); i > 0; i-- ) { + result = make_string( string[i - 1], result ); } return result; } /** - * Return a lisp symbol representation of this old skool ASCII string. + * Return a lisp symbol representation of this wide character string. */ -struct cons_pointer c_string_to_lisp_symbol( char *symbol ) { +struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) { struct cons_pointer result = NIL; - for ( int i = strlen( symbol ); i > 0; i-- ) { - result = make_symbol( ( wint_t ) symbol[i - 1], result ); + for ( int i = wcslen( symbol ); i > 0; i-- ) { + result = make_symbol( symbol[i - 1], result ); } return result; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 47bbed0..523fdaa 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -582,11 +582,11 @@ struct cons_pointer make_write_stream( FILE * output ); /** * Return a lisp string representation of this old skool ASCII string. */ -struct cons_pointer c_string_to_lisp_string( char *string ); +struct cons_pointer c_string_to_lisp_string( wchar_t *string ); /** * Return a lisp symbol representation of this old skool ASCII string. */ -struct cons_pointer c_string_to_lisp_symbol( char *symbol ); +struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ); #endif diff --git a/src/memory/dump.c b/src/memory/dump.c index e0c2bbc..3129761 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -55,11 +55,8 @@ void dump_string_cell( FILE * output, wchar_t *prefix, void dump_object( FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); fwprintf( output, - L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n", - cell.tag.bytes[0], - cell.tag.bytes[1], - cell.tag.bytes[2], - cell.tag.bytes[3], + L"\t%4.4s (%d) at page %d, offset %d count %u\n", + cell.tag.bytes, cell.tag.value, pointer.page, pointer.offset, cell.count ); switch ( cell.tag.value ) { @@ -91,6 +88,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); break; + case NILTV: + break; case RATIOTV: fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", @@ -101,6 +100,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { break; case READTV: fwprintf( output, L"\t\tInput stream\n" ); + break; case REALTV: fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", cell.payload.real.value, cell.count ); @@ -111,26 +111,28 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case SYMBOLTV: dump_string_cell( output, L"Symbol", pointer ); break; + case TRUETV: + break; case VECTORPOINTTV:{ fwprintf( output, L"\t\tPointer to vector-space object at %p\n", cell.payload.vectorp.address ); struct vector_space_object *vso = cell.payload.vectorp.address; fwprintf( output, - L"\t\tVector space object of type %4.4s, payload size %d bytes\n", - &vso->header.tag.bytes, vso->header.size ); + L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", + &vso->header.tag.bytes, vso->header.tag.value, vso->header.size ); + if (stackframep(vso)) { + dump_frame(output, pointer); + } switch ( vso->header.tag.value ) { case STACKFRAMETV: dump_frame( output, pointer ); break; - default: - fputws( L"(Unknown vector type)\n", output ); - break; } } break; - default: - fputws( L"(Unknown cons space type)\n", output ); + case WRITETV: + fwprintf( output, L"\t\tOutput stream\n" ); break; } } diff --git a/src/memory/stack.c b/src/memory/stack.c index 069b1ed..a167244 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -32,24 +32,15 @@ */ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { struct stack_frame *result = NULL; - debug_print - ( L"get_stack_frame: about to get a pointer to the vector space object\n", - DEBUG_ALLOC ); struct vector_space_object *vso = pointer2cell( pointer ).payload.vectorp.address; - debug_print( L"get_stack_frame: got a pointer, about to test it\n", - DEBUG_ALLOC ); if ( vectorpointp( pointer ) && stackframep( vso ) ) { - debug_print - ( L"get_stack_frame: pointer is good, about to set the result\n", - DEBUG_ALLOC ); - result = ( struct stack_frame * ) &( vso->payload ); - fwprintf( stderr, L"get_stack_frame: all good, returning %p\n", + debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n", result ); } else { - debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_ALLOC ); + debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK ); } return result; @@ -62,31 +53,31 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { * @return the new frame, or NULL if memory is exhausted. */ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { - debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC ); + debug_print( L"Entering make_empty_frame\n", DEBUG_STACK ); struct cons_pointer result = make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) ); - debug_dump_object( result, DEBUG_ALLOC ); + debug_dump_object( result, DEBUG_STACK ); - fwprintf( stderr, + debug_printf( DEBUG_STACK, L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n", pointer_to_vso( result )->header.size, &pointer_to_vso( result )->header.tag.bytes ); if ( !nilp( result ) ) { debug_print( L"make_empty_frame: about to call get_stack_frame\n", - DEBUG_ALLOC ); + DEBUG_STACK ); struct stack_frame *frame = get_stack_frame( result ); /* * TODO: later, pop a frame off a free-list of stack frames */ - fwprintf( stderr, + debug_printf( DEBUG_STACK, L"make_empty_frame: about to set previous to %4.4s\n", &pointer2cell( previous ).tag.bytes ); frame->previous = previous; debug_print( L"make_empty_frame: about to call inc_ref\n", - DEBUG_ALLOC ); + DEBUG_STACK ); inc_ref( previous ); /* @@ -98,12 +89,12 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { frame->args = 0; debug_print( L"make_empty_frame: about to initialise arg registers\n", - DEBUG_ALLOC ); + DEBUG_STACK ); for ( int i = 0; i < args_in_frame; i++ ) { set_reg( frame, i, NIL ); } } - debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); + debug_print( L"Leaving make_empty_frame\n", DEBUG_STACK ); return result; } @@ -119,13 +110,13 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_pointer args, struct cons_pointer env ) { - debug_print( L"Entering make_stack_frame\n", DEBUG_ALLOC ); + debug_print( L"Entering make_stack_frame\n", DEBUG_STACK ); struct cons_pointer result = make_empty_frame( previous ); if ( nilp( result ) ) { /* i.e. out of memory */ result = - make_exception( c_string_to_lisp_string( "Memory exhausted." ), + make_exception( c_string_to_lisp_string( L"Memory exhausted." ), previous ); } else { struct stack_frame *frame = get_stack_frame( result ); @@ -149,11 +140,13 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, if ( nilp( arg_frame_pointer ) ) { result = make_exception( c_string_to_lisp_string - ( "Memory exhausted." ), previous ); + ( L"Memory exhausted." ), previous ); break; } else { struct stack_frame *arg_frame = get_stack_frame( arg_frame_pointer ); + debug_print( L"Setting argument 0 of arg_frame to ", DEBUG_STACK); + debug_print_object(cell.payload.cons.car, DEBUG_STACK); set_reg( arg_frame, 0, cell.payload.cons.car ); struct cons_pointer val = @@ -162,6 +155,8 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, result = val; break; } else { + debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args); + debug_print_object(cell.payload.cons.car, DEBUG_STACK); set_reg( frame, frame->args, val ); } @@ -180,10 +175,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, inc_ref( more ); } - debug_dump_object( result, DEBUG_ALLOC ); + debug_dump_object( result, DEBUG_STACK ); } } - debug_print( L"Leaving make_stack_frame\n", DEBUG_ALLOC ); + debug_print( L"Leaving make_stack_frame\n", DEBUG_STACK ); return result; } @@ -199,14 +194,14 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_pointer make_special_frame( struct cons_pointer previous, struct cons_pointer args, struct cons_pointer env ) { - debug_print( L"Entering make_special_frame\n", DEBUG_ALLOC ); + debug_print( L"Entering make_special_frame\n", DEBUG_STACK ); struct cons_pointer result = make_empty_frame( previous ); if ( nilp( result ) ) { /* i.e. out of memory */ result = - make_exception( c_string_to_lisp_string( "Memory exhausted." ), + make_exception( c_string_to_lisp_string( L"Memory exhausted." ), previous ); } else { struct stack_frame *frame = get_stack_frame( result ); @@ -228,10 +223,10 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, inc_ref( args ); } - debug_dump_object( result, DEBUG_ALLOC ); + debug_dump_object( result, DEBUG_STACK ); } } - debug_print( L"Leaving make_special_frame\n", DEBUG_ALLOC ); + debug_print( L"Leaving make_special_frame\n", DEBUG_STACK ); return result; } @@ -263,6 +258,7 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { struct stack_frame *frame = get_stack_frame( frame_pointer ); if ( frame != NULL ) { + fwprintf( output, L"Stack frame with %d arguments:\n", frame->args); for ( int arg = 0; arg < frame->args; arg++ ) { struct cons_space_object cell = pointer2cell( frame->arg[arg] ); @@ -274,16 +270,19 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { print( output, frame->arg[arg] ); fputws( L"\n", output ); } + if (!nilp(frame->more)) + { fputws( L"More: \t", output ); print( output, frame->more ); fputws( L"\n", output ); + } } } void dump_stack_trace( FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { print( output, pointer2cell( pointer ).payload.exception.message ); - fwprintf( output, L"\n" ); + fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); } else { diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 7dbe682..c30f120 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -21,7 +21,7 @@ #include "conspage.h" #include "consspaceobject.h" -#include "dump.h" +#include "debug.h" #include "vectorspace.h" @@ -32,17 +32,17 @@ * vector-space object, NOT `VECTORPOINTTAG`. */ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { - fputws( L"Entered make_vec_pointer\n", stderr ); + debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"make_vec_pointer: tag written, about to set pointer address to %p\n", address ); cell->payload.vectorp.address = address; - fwprintf( stderr, L"make_vec_pointer: all good, returning pointer to %p\n", + debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", cell->payload.vectorp.address ); - dump_object( stderr, pointer ); + debug_dump_object( pointer, DEBUG_ALLOC ); return pointer; } @@ -55,41 +55,41 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { * Returns NIL if the vector could not be allocated due to memory exhaustion. */ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { - fputws( L"Entered make_vso\n", stderr ); + debug_print( L"Entered make_vso\n", DEBUG_ALLOC ); struct cons_pointer result = NIL; int64_t total_size = sizeof( struct vector_space_header ) + payload_size; /* Pad size to 64 bit words. This is intended to promote access efficiancy * on 64 bit machines but may just be voodoo coding */ uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 ); - fputws( L"make_vso: about to malloc\n", stderr ); + debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC ); struct vector_space_object *vso = malloc( padded ); if ( vso != NULL ) { - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"make_vso: about to write tag '%s' into vso at %p\n", tag, vso ); strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); result = make_vec_pointer( vso ); - dump_object( stderr, result ); + debug_dump_object( result, DEBUG_ALLOC ); vso->header.vecp = result; // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); vso->header.size = payload_size; #ifdef DEBUG - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n", &vso->header.tag.bytes, total_size, vso->header.size, vso, &vso->payload ); if ( padded != total_size ) { - fwprintf( stderr, L"\t\tPadded from %d to %d\n", + debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n", total_size, padded ); } #endif } #ifdef DEBUG - fwprintf( stderr, L"make_vso: all good, returning pointer to %p\n", + debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n", pointer2cell( result ).payload.vectorp.address ); #endif diff --git a/src/ops/lispops.c b/src/ops/lispops.c index da3bc82..43665e9 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -193,7 +193,7 @@ struct cons_pointer eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - fwprintf( stderr, L"eval_lambda called\n" ); + debug_print( L"eval_lambda called\n", DEBUG_EVAL ); struct cons_pointer new_env = env; struct cons_pointer names = cell.payload.lambda.args; @@ -355,13 +355,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, break; default: { - char *buffer = malloc( 1024 ); - memset( buffer, '\0', 1024 ); - sprintf( buffer, - "Unexpected cell with tag %d (%c%c%c%c) in function position", - fn_cell.tag.value, fn_cell.tag.bytes[0], - fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], - fn_cell.tag.bytes[3] ); + int bs = sizeof(wchar_t) * 1024; + wchar_t *buffer = malloc( bs ); + memset( buffer, '\0', bs ); + swprintf( buffer, bs, + L"Unexpected cell with tag %d (%4.4s) in function position", + fn_cell.tag.value, &fn_cell.tag.bytes[0] ); struct cons_pointer message = c_string_to_lisp_string( buffer ); free( buffer ); @@ -380,13 +379,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, * @return As a Lisp string, the tag of the object which is at that pointer. */ struct cons_pointer c_type( struct cons_pointer pointer ) { - char *buffer = malloc( TAGLENGTH + 1 ); - memset( buffer, 0, TAGLENGTH + 1 ); + struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( pointer ); - strncpy( buffer, cell.tag.bytes, TAGLENGTH ); - struct cons_pointer result = c_string_to_lisp_string( buffer ); - free( buffer ); + for (int i = TAGLENGTH; i >= 0; i--) + { + result = make_string((wchar_t)cell.tag.bytes[i], result); + } return result; } @@ -408,14 +407,12 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { + debug_print( L"Eval: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + struct cons_pointer result = frame->arg[0]; struct cons_space_object cell = pointer2cell( frame->arg[0] ); - debug_print( L"Eval: ", DEBUG_EVAL ); -#ifdef DEBUG - dump_frame( stderr, frame_pointer ); -#endif - switch ( cell.tag.value ) { case CONSTV: { @@ -430,7 +427,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( canonical ) ) { struct cons_pointer message = make_cons( c_string_to_lisp_string - ( "Attempt to take value of unbound symbol." ), + ( L"Attempt to take value of unbound symbol." ), frame->arg[0] ); result = throw_exception( message, frame_pointer ); } else { @@ -522,7 +519,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, result = make_exception( make_cons ( c_string_to_lisp_string - ( "The first argument to `set!` is not a symbol: " ), + ( L"The first argument to `set` is not a symbol: " ), make_cons( frame->arg[0], NIL ) ), frame_pointer ); } @@ -556,7 +553,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, result = make_exception( make_cons ( c_string_to_lisp_string - ( "The first argument to `set!` is not a symbol: " ), + ( L"The first argument to `set!` is not a symbol: " ), make_cons( frame->arg[0], NIL ) ), frame_pointer ); } @@ -610,7 +607,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, result = make_string( cell.payload.string.character, NIL ); } else { struct cons_pointer message = - c_string_to_lisp_string( "Attempt to take CAR of non sequence" ); + c_string_to_lisp_string( L"Attempt to take CAR of non sequence" ); result = throw_exception( message, frame_pointer ); } @@ -635,7 +632,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, result = cell.payload.string.cdr; } else { struct cons_pointer message = - c_string_to_lisp_string( "Attempt to take CDR of non sequence" ); + c_string_to_lisp_string( L"Attempt to take CDR of non sequence" ); result = throw_exception( message, frame_pointer ); } @@ -850,7 +847,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, done = true; } else { result = throw_exception( c_string_to_lisp_string - ( "Arguments to `cond` must be lists" ), + ( L"Arguments to `cond` must be lists" ), frame_pointer ); } } diff --git a/src/ops/print.c b/src/ops/print.c index 99cd7f3..49adca7 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -37,7 +37,7 @@ int print_use_colours = 0; void print_string_contents( FILE * output, struct cons_pointer pointer ) { while ( stringp( pointer ) || symbolp( pointer ) ) { struct cons_space_object *cell = &pointer2cell( pointer ); - wint_t c = cell->payload.string.character; + wchar_t c = cell->payload.string.character; if ( c != '\0' ) { fputwc( c, output ); @@ -131,7 +131,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"%ld%", cell.payload.integer.value ); break; case LAMBDATV: - print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), + print( output, make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( cell.payload.lambda.args, cell.payload.lambda. body ) ) ); @@ -140,7 +140,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"nil" ); break; case NLAMBDATV: - print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ), + print( output, make_cons( c_string_to_lisp_symbol( L"nlambda" ), make_cons( cell.payload.lambda.args, cell.payload.lambda. body ) ) ); @@ -190,6 +190,9 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case TRUETV: fwprintf( output, L"t" ); break; + case WRITETV: + fwprintf( output, L"(Output stream)" ); + break; default: fwprintf( stderr, L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", diff --git a/src/ops/read.c b/src/ops/read.c index e3cb480..a9b1ffe 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -49,7 +49,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ); * quote reader macro in C (!) */ struct cons_pointer c_quote( struct cons_pointer arg ) { - return make_cons( c_string_to_lisp_symbol( "quote" ), + return make_cons( c_string_to_lisp_symbol( L"quote" ), make_cons( arg, NIL ) ); } @@ -71,8 +71,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, if ( feof( input ) ) { result = - make_exception( c_string_to_lisp_string - ( "End of file while reading" ), frame_pointer ); + throw_exception( c_string_to_lisp_string + ( L"End of file while reading" ), frame_pointer ); } else { switch ( c ) { case ';': @@ -81,7 +81,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, break; case EOF: result = throw_exception( c_string_to_lisp_string - ( "End of input while reading" ), + ( L"End of input while reading" ), frame_pointer ); break; case '\'': @@ -136,8 +136,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, result = read_symbol( input, c ); } else { result = - make_exception( make_cons( c_string_to_lisp_string - ( "Unrecognised start of input character" ), + throw_exception( make_cons( c_string_to_lisp_string + ( L"Unrecognised start of input character" ), make_string( c, NIL ) ), frame_pointer ); } @@ -170,23 +170,23 @@ struct cons_pointer read_number( struct stack_frame *frame, if ( negative ) { initial = fgetwc( input ); } -#ifdef DEBUG - fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); -#endif + + debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial ); + for ( c = initial; iswdigit( c ) || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { if ( seen_period || dividend != 0 ) { - return make_exception( c_string_to_lisp_string - ( "Malformed number: too many periods" ), + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: too many periods" ), frame_pointer ); } else { seen_period = true; } } else if ( c == btowc( '/' ) ) { if ( seen_period || dividend > 0 ) { - return make_exception( c_string_to_lisp_string - ( "Malformed number: dividend of rational must be integer" ), + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: dividend of rational must be integer" ), frame_pointer ); } else { dividend = negative ? 0 - accumulator : accumulator; @@ -195,11 +195,11 @@ struct cons_pointer read_number( struct stack_frame *frame, } } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); -#ifdef DEBUG - fwprintf( stderr, + + debug_printf( DEBUG_IO, L"Added character %c, accumulator now %ld\n", c, accumulator ); -#endif + if ( seen_period ) { places_of_decimals++; } @@ -243,10 +243,8 @@ struct cons_pointer read_list( struct stack_frame *frame, FILE * input, wint_t initial ) { struct cons_pointer result = NIL; if ( initial != ')' ) { -#ifdef DEBUG - fwprintf( stderr, + debug_printf( DEBUG_IO, L"read_list starting '%C' (%d)\n", initial, initial ); -#endif struct cons_pointer car = read_continuation( frame, frame_pointer, input, initial ); diff --git a/src/repl.c b/src/repl.c index f0dcbfa..04cf33c 100644 --- a/src/repl.c +++ b/src/repl.c @@ -13,7 +13,7 @@ #include "conspage.h" #include "consspaceobject.h" -#include "dump.h" +#include "debug.h" #include "intern.h" #include "lispops.h" #include "read.h" @@ -33,25 +33,17 @@ */ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { struct cons_pointer result = NIL; - fputws( L"Entered repl_read\n", stderr ); - struct cons_pointer frame_pointer = make_empty_frame( NIL ); - fputws( L"repl_read: got stack_frame pointer\n", stderr ); - dump_object( stderr, frame_pointer ); + debug_print( L"Entered repl_read\n", DEBUG_REPL ); + struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist ); + debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL ); + debug_dump_object( frame_pointer, DEBUG_REPL ); if ( !nilp( frame_pointer ) ) { inc_ref( frame_pointer ); - struct stack_frame *frame = get_stack_frame( frame_pointer ); - - if ( frame != NULL ) { - fputws( L"repl_read: about to set register\n", stderr ); - set_reg( frame, 0, stream_pointer ); - fputws( L"repl_read: about to read\n", stderr ); - struct cons_pointer result = - lisp_read( frame, frame_pointer, oblist ); - } + result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist ); dec_ref( frame_pointer ); } - fputws( L"repl_read: returning\n", stderr ); - dump_object( stderr, result ); + debug_print( L"repl_read: returning\n", DEBUG_REPL ); + debug_dump_object( result, DEBUG_REPL ); return result; } @@ -60,22 +52,18 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { * Dummy up a Lisp eval call with its own stack frame. */ struct cons_pointer repl_eval( struct cons_pointer input ) { - fputws( L"Entered repl_eval\n", stderr ); + debug_print( L"Entered repl_eval\n", DEBUG_REPL ); struct cons_pointer result = NIL; - struct cons_pointer frame_pointer = make_empty_frame( NIL ); - if ( !nilp( frame_pointer ) ) { - inc_ref( frame_pointer ); - struct stack_frame *frame = get_stack_frame( frame_pointer ); + struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( input, NIL ), oblist); - if ( frame != NULL ) { - set_reg( frame, 0, input ); - result = lisp_eval( frame, frame_pointer, oblist ); - } + if ( !nilp( frame_pointer ) ) { + inc_ref(frame_pointer); + result = lisp_eval( get_stack_frame( frame_pointer ), frame_pointer, oblist ); dec_ref( frame_pointer ); } - fputws( L"repl_eval: returning\n", stderr ); - dump_object( stderr, result ); + debug_print( L"repl_eval: returning\n", DEBUG_REPL ); + debug_dump_object( result, DEBUG_REPL ); return result; } @@ -85,20 +73,17 @@ struct cons_pointer repl_eval( struct cons_pointer input ) { */ struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer value ) { - + debug_print( L"Entered repl_print\n", DEBUG_REPL ); + debug_dump_object( value, DEBUG_REPL ); struct cons_pointer result = NIL; - struct cons_pointer frame_pointer = make_empty_frame( NIL ); + struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( value, NIL ), oblist); if ( !nilp( frame_pointer ) ) { - struct stack_frame *frame = get_stack_frame( frame_pointer ); - - if ( frame != NULL ) { - set_reg( frame, 0, value ); - set_reg( frame, 1, stream_pointer ); - result = lisp_print( frame, frame_pointer, oblist ); - free_stack_frame( frame ); - } + inc_ref(frame_pointer); + result = lisp_print( get_stack_frame( frame_pointer ), frame_pointer, oblist ); dec_ref( frame_pointer ); } + debug_print( L"repl_print: returning\n", DEBUG_REPL ); + debug_dump_object( result, DEBUG_REPL ); return result; } @@ -113,7 +98,7 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer, void repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, bool show_prompt ) { - fputws( L"Entered repl\n", stderr ); + debug_print( L"Entered repl\n", DEBUG_REPL ); struct cons_pointer input_stream = make_read_stream( in_stream ); inc_ref( input_stream ); @@ -138,4 +123,5 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, } dec_ref( input ); } + debug_print( L"Leaving repl\n", DEBUG_REPL ); } diff --git a/utils_src/debugflags/debugflags b/utils_src/debugflags/debugflags new file mode 100755 index 0000000000000000000000000000000000000000..49b2a0854c3ae04e0551caba08f8019ff3a2cd8c GIT binary patch literal 8520 zcmeHN-)kII6u#56HHm4nc`(FSb^2qa?L(raw8dK3NiuXow#}MsM8$H+{%Etf*@WF0 zZ5|dDqTnzM?33V&{tJcTi%1D1m^>8hLmz_V!G|ali5Nj-k&yK}Gk22NP4vwN;T|}1 z&pF?nGv|JH2JYUw-~aXN?sJSOEsRx;FvdEei$@vzl&P>7dl70tIZtRe_4oC$QHnN- z(&!%QQJyt)&c1$Ss;M~mKH_7s)IbZAq1_S7kD2jXxXJ3x8 z%DzMSN~V=6?S-22{c+OI*CBcYesDvp$ah=>{Cs>Wo1e`V5o^vz1XF3}f&}o1_dPjK zU%F%#bA@}NLvy}!BHsgnlOL9b+yFSY3LobR8J;WLo$>s}`FJSu(VUZz-<-oo{433? z3*~%BOKKqm^XE-LFt1H5%`4uyz1*A^^1L)Rotnw>S+n?$`GPd`e$f4a5dYyiInPi2 zTfPYHr}~0?TjQ=tl!oox4%Y>&&1FO-Y0 z1CFW7d5oX(RPkMgg`Rs2N*Im#*y;x8SN3Z`J>zpFGdtZk(1*HmDRhFo2BrKJ)#vkq z@QE)ek^#wpWI!??8ITM}2L1~MCJg&0V}47u%R9DJGwg}&6@7~y-^+Z zxW>YbudyyN9BbQ|s6AwE86LXQTFKU3N8d8$m(@EU9FFW#v2D+HkB54E;1B zw!R3u<`)%P-`ZS4PeQX3oz;$y=} zL)iK|T3ncM?bg7MCY*uM(d2k?OiKuVcvKi;dLqu+qM6{q?cO^36x9d`w=|>lTlX?r zQu>`rLN=|%J8);jU!_wRLq1$0;`d*#XbQ*fRar6872}iUOpfdx*t0l{Ht)g{qHvtg zxA5sHp1q$ +#include +#include +#include +#include + + +#define DEBUG_ALLOC 1 +#define DEBUG_STACK 2 +#define DEBUG_ARITH 4 +#define DEBUG_EVAL 8 +#define DEBUG_LAMBDA 16 +#define DEBUG_BOOTSTRAP 32 +#define DEBUG_IO 64 +#define DEBUG_REPL 128 + +int check_level( int v, int level, char * name) { + int result = 0; + if (v & level) { + printf("\t\t%s (%d) matches;\n", name, level); + result = 1; + } + + return result; +} + +int main( int argc, char *argv[] ) { + + for (int i = 1; i < argc; i++) { + int v = atoi(argv[i]); + + printf("Level %d:\n", v); + int matches = check_level(v, DEBUG_ALLOC, "DEBUG_ALLOC") + + check_level(v, DEBUG_STACK, "DEBUG_STACK") + + check_level(v, DEBUG_ARITH, "DEBUG_ARITH") + + check_level(v, DEBUG_EVAL, "DEBUG_EVAL") + + check_level(v, DEBUG_LAMBDA, "DEBUG_LAMBDA") + + check_level(v, DEBUG_BOOTSTRAP, "DEBUG_BOOTSTRAP") + + check_level(v, DEBUG_IO, "DEBUG_IO") + + check_level(v, DEBUG_REPL, "DEBUG_REPL"); + printf("\t%d matches\n", matches); + } +} From 96dad29f91480736011f9f5ff31174f3c5e4d698 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 28 Dec 2018 21:21:11 +0000 Subject: [PATCH 20/22] Good news: only one test failing. Bad news: it's nlambda. --- src/debug.c | 15 +++++++++ src/debug.h | 1 + src/memory/dump.c | 4 ++- src/memory/stack.c | 76 ++++++++++++++++++---------------------------- src/memory/stack.h | 4 ++- src/ops/intern.c | 6 ++++ src/ops/lispops.c | 42 +++++++++++-------------- src/repl.c | 22 ++++---------- 8 files changed, 80 insertions(+), 90 deletions(-) diff --git a/src/debug.c b/src/debug.c index 657998f..b21f4af 100644 --- a/src/debug.c +++ b/src/debug.c @@ -42,6 +42,21 @@ void debug_print( wchar_t *message, int level ) { #endif } +/** + * 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 ) { +#ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + fputws( L"\n", stderr ); + } +#endif +} + + /** * `wprintf` adapted for the debug logging system. Print to stderr only * `verbosity` matches `level`. All other arguments as for `wprintf`. diff --git a/src/debug.h b/src/debug.h index 10d07c3..22f5591 100644 --- a/src/debug.h +++ b/src/debug.h @@ -25,6 +25,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_print_object( struct cons_pointer pointer, int level ); void debug_dump_object( struct cons_pointer pointer, int level ); diff --git a/src/memory/dump.c b/src/memory/dump.c index 3129761..e88332a 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -62,11 +62,13 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { 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\n", + 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); break; case EXCEPTIONTV: fwprintf( output, L"\t\tException cell: " ); diff --git a/src/memory/stack.c b/src/memory/stack.c index a167244..f91d896 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -26,6 +26,18 @@ #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; + } +} + + /** * get the actual stackframe object from this `pointer`, or NULL if * `pointer` is not a stackframe pointer. @@ -53,32 +65,24 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { * @return the new frame, or NULL if memory is exhausted. */ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { - debug_print( L"Entering make_empty_frame\n", DEBUG_STACK ); + debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC ); struct cons_pointer result = make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) ); - debug_dump_object( result, DEBUG_STACK ); + 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 ); +// debug_printf( DEBUG_STACK, +// L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n", +// pointer_to_vso( result )->header.size, +// &pointer_to_vso( result )->header.tag.bytes ); if ( !nilp( result ) ) { - debug_print( L"make_empty_frame: about to call get_stack_frame\n", - DEBUG_STACK ); struct stack_frame *frame = get_stack_frame( result ); /* * TODO: later, pop a frame off a free-list of stack frames */ - debug_printf( DEBUG_STACK, - L"make_empty_frame: about to set previous to %4.4s\n", - &pointer2cell( previous ).tag.bytes ); frame->previous = previous; - debug_print( L"make_empty_frame: about to call inc_ref\n", - DEBUG_STACK ); - inc_ref( previous ); /* * clearing the frame with memset would probably be slightly quicker, but @@ -88,13 +92,12 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { frame->function = NIL; frame->args = 0; - debug_print( L"make_empty_frame: about to initialise arg registers\n", - DEBUG_STACK ); for ( int i = 0; i < args_in_frame; i++ ) { - set_reg( frame, i, NIL ); + frame->arg[i] = NIL; } } - debug_print( L"Leaving make_empty_frame\n", DEBUG_STACK ); + debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); + debug_dump_object( result, DEBUG_ALLOC); return result; } @@ -121,8 +124,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, } else { struct stack_frame *frame = get_stack_frame( result ); - for ( frame->args = 0; frame->args < args_in_frame && consp( args ); - frame->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 */ @@ -134,23 +136,7 @@ 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 arg_frame_pointer = make_empty_frame( result ); - inc_ref( arg_frame_pointer ); - - if ( nilp( arg_frame_pointer ) ) { - result = - make_exception( c_string_to_lisp_string - ( L"Memory exhausted." ), previous ); - break; - } else { - struct stack_frame *arg_frame = - get_stack_frame( arg_frame_pointer ); - debug_print( L"Setting argument 0 of arg_frame to ", DEBUG_STACK); - debug_print_object(cell.payload.cons.car, DEBUG_STACK); - set_reg( arg_frame, 0, cell.payload.cons.car ); - - struct cons_pointer val = - lisp_eval( arg_frame, arg_frame_pointer, env ); + struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env); if ( exceptionp( val ) ) { result = val; break; @@ -160,11 +146,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, set_reg( frame, frame->args, val ); } - dec_ref( arg_frame_pointer ); - args = cell.payload.cons.cdr; } - } + if ( !exceptionp( result ) ) { if ( consp( args ) ) { /* if we still have args, eval them and stick the values on `more` */ @@ -175,10 +159,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, inc_ref( more ); } - debug_dump_object( result, DEBUG_STACK ); } } - debug_print( L"Leaving make_stack_frame\n", DEBUG_STACK ); + debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); + debug_dump_object( result, DEBUG_STACK ); return result; } @@ -206,8 +190,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, } else { struct stack_frame *frame = get_stack_frame( result ); - for ( frame->args = 0; frame->args < args_in_frame && !nilp( args ); - frame->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 */ @@ -222,11 +205,10 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, frame->more = args; inc_ref( args ); } - - debug_dump_object( result, DEBUG_STACK ); } } - debug_print( L"Leaving make_special_frame\n", DEBUG_STACK ); + debug_print( L"make_special_frame: returning\n", DEBUG_STACK ); + debug_dump_object( result, DEBUG_STACK ); return result; } diff --git a/src/memory/stack.h b/src/memory/stack.h index b56f432..79cd1e2 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -39,7 +39,9 @@ * 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);} +//#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 ); diff --git a/src/ops/intern.c b/src/ops/intern.c index 8dea7c8..27c745d 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -111,6 +111,12 @@ 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); + return make_cons( make_cons( key, value ), store ); } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 43665e9..79195e4 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -94,6 +94,7 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct stack_frame *next = get_stack_frame( next_pointer ); set_reg( next, 0, form ); + next->args = 1; result = lisp_eval( next, next_pointer, env ); @@ -253,25 +254,15 @@ 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 ) { - struct cons_pointer result = NIL; + debug_print(L"Entering c_apply\n", DEBUG_EVAL); + struct cons_pointer result = NIL; - /* construct a child frame and within it evaluate the first argument - the - * argument in the function position. */ - struct cons_pointer fn_frame_pointer = make_empty_frame( frame_pointer ); - inc_ref( fn_frame_pointer ); - struct stack_frame *fn_frame = get_stack_frame( fn_frame_pointer ); - - set_reg( fn_frame, 0, c_car( frame->arg[0] ) ); struct cons_pointer fn_pointer = - lisp_eval( fn_frame, fn_frame_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( fn_frame_pointer ); - } + eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env ); + 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] ); @@ -327,9 +318,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct stack_frame *next = get_stack_frame( frame_pointer ); result = eval_lambda( fn_cell, next, next_pointer, env ); - if ( !exceptionp( result ) ) { dec_ref( next_pointer ); - } } } break; @@ -341,15 +330,14 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( exceptionp( next_pointer ) ) { result = next_pointer; } else { - struct stack_frame *next = - get_stack_frame( frame_pointer ); result = - ( *fn_cell.payload.special.executable ) ( next, + ( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ), next_pointer, env ); - if ( !exceptionp( result ) ) { - dec_ref( next_pointer ); - } + debug_print(L"Special form returning: ", DEBUG_EVAL); + debug_print_object(result, DEBUG_EVAL); + debug_println(DEBUG_EVAL); + dec_ref( next_pointer ); } } break; @@ -367,7 +355,11 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = throw_exception( message, frame_pointer ); } } - dec_ref( fn_frame_pointer ); + } + + debug_print(L"c_apply: returning: ", DEBUG_EVAL); + debug_print_object(result, DEBUG_EVAL); + debug_println(DEBUG_EVAL); return result; } diff --git a/src/repl.c b/src/repl.c index 04cf33c..e0170b6 100644 --- a/src/repl.c +++ b/src/repl.c @@ -52,16 +52,11 @@ 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; - struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( input, NIL ), oblist); - if ( !nilp( frame_pointer ) ) { - inc_ref(frame_pointer); - result = lisp_eval( get_stack_frame( frame_pointer ), frame_pointer, oblist ); + result = eval_form( NULL, NIL, input, oblist ); - dec_ref( frame_pointer ); - } debug_print( L"repl_eval: returning\n", DEBUG_REPL ); debug_dump_object( result, DEBUG_REPL ); @@ -73,15 +68,10 @@ 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 = NIL; - struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( value, NIL ), oblist); - if ( !nilp( frame_pointer ) ) { - inc_ref(frame_pointer); - result = lisp_print( get_stack_frame( frame_pointer ), frame_pointer, oblist ); - dec_ref( frame_pointer ); - } + 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 ); @@ -98,7 +88,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 ); From 570634bc4325f833624c2215a2303b013cb9cb3c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 28 Dec 2018 21:33:35 +0000 Subject: [PATCH 21/22] Success! All tests pass. --- src/ops/lispops.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 79195e4..82746e0 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -203,7 +203,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, if ( consp( names ) ) { /* if `names` is a list, bind successive items from that list * to values of arguments */ - for ( int i = 0; i < args_in_frame && consp( names ); i++ ) { + for ( int i = 0; i < frame->args && consp( names ); i++ ) { struct cons_pointer name = c_car( names ); struct cons_pointer val = frame->arg[i]; @@ -212,6 +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. */ } 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. */ @@ -316,7 +317,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { struct stack_frame *next = - get_stack_frame( frame_pointer ); + get_stack_frame( next_pointer ); result = eval_lambda( fn_cell, next, next_pointer, env ); dec_ref( next_pointer ); } From 2d5fc4a2029d33d1e32f434b9334a87cf705645c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 28 Dec 2018 22:36:26 +0000 Subject: [PATCH 22/22] Upversioned, README updated --- lisp/defun.lisp | 8 +++++--- src/version.h | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/lisp/defun.lisp b/lisp/defun.lisp index e86df35..cec893b 100644 --- a/lisp/defun.lisp +++ b/lisp/defun.lisp @@ -1,10 +1,12 @@ -;; Because I don't (yet) have syntax for varargs, the body must be passed -;; to defun as a list of sexprs. +(set! list (lambda l l)) + +(set! symbolp (lambda (x) (equal (type x) "SYMB"))) + (set! defun! (nlambda form (cond ((symbolp (car form)) - (set (car form) (apply lambda (cdr form)))) + (set (car form) (apply 'lambda (cdr form)))) (t nil)))) (defun! square (x) (* x x)) diff --git a/src/version.h b/src/version.h index eb9d34e..96fb98e 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.3" +#define VERSION "0.0.4"