From 11409301da5cce61a818b3978875af04e71d03a1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 13 Dec 2018 19:23:44 +0000 Subject: [PATCH] Tactical commit before trying adventurous change in peano --- src/conspage.c | 2 +- src/consspaceobject.c | 5 +- src/consspaceobject.h | 2 +- src/equal.c | 22 +++++---- src/lispops.c | 109 +++++++++++++++++++++++++++++++++++------- src/lispops.h | 33 +++++++++++++ src/peano.c | 58 +++++++++++++++++----- src/print.c | 30 +++++------- src/read.c | 2 +- src/stack.c | 21 ++++---- 10 files changed, 215 insertions(+), 69 deletions(-) diff --git a/src/conspage.c b/src/conspage.c index 0b13baf..afa8bf4 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -129,7 +129,7 @@ void free_cell( struct cons_pointer pointer ) { if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { - fwprintf( stderr, L"Freeing cell\n" ); + fwprintf( stderr, L"Freeing cell " ); dump_object( stderr, pointer ); strncpy( &cell->tag.bytes[0], FREETAG, 4 ); cell->payload.free.car = NIL; diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 6d6a805..0e8f455 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -92,7 +92,7 @@ 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"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n", + 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], @@ -112,7 +112,6 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"\t\tException cell: " ); print( output, cell.payload.exception.message ); fwprintf( output, L"\n" ); - /* TODO: dump the stack trace */ for ( struct stack_frame * frame = cell.payload.exception.frame; frame != NULL; frame = frame->previous ) { dump_frame( output, frame ); @@ -220,7 +219,7 @@ struct cons_pointer make_lambda( struct cons_pointer args, * lambda as a special form is to a function. */ struct cons_pointer make_nlambda( struct cons_pointer args, - struct cons_pointer body ) { + struct cons_pointer body ) { struct cons_pointer pointer = allocate_cell( NLAMBDATAG ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( args ); diff --git a/src/consspaceobject.h b/src/consspaceobject.h index e6f6f83..ed5cbd1 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -494,7 +494,7 @@ struct cons_pointer make_lambda( struct cons_pointer args, * lambda as a special form is to a function. */ struct cons_pointer make_nlambda( struct cons_pointer args, - struct cons_pointer body ); + struct cons_pointer body ); /** * Construct a cell which points to an executable Lisp special form. diff --git a/src/equal.c b/src/equal.c index d06903f..0f0597c 100644 --- a/src/equal.c +++ b/src/equal.c @@ -15,7 +15,7 @@ #include "integer.h" /** - * Shallow, and thus cheap, equality: true if these two objects are + * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. */ bool eq( struct cons_pointer a, struct cons_pointer b ) { @@ -26,7 +26,7 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) { * True if the objects at these two cons pointers have the same tag, else false. * @param a a pointer to a cons-space object; * @param b another pointer to a cons-space object. - * @return true if the objects at these two cons pointers have the same tag, + * @return true if the objects at these two cons pointers have the same tag, * else false. */ bool same_type( struct cons_pointer a, struct cons_pointer b ) { @@ -60,6 +60,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { switch ( cell_a->tag.value ) { case CONSTV: + case LAMBDATV: + case NLAMBDATV: result = equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) && equal( cell_a->payload.cons.cdr, @@ -70,7 +72,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { /* * slightly complex because a string may or may not have a '\0' * cell at the end, but I'll ignore that for now. I think in - * practice only the empty string will. + * practice only the empty string will. */ result = cell_a->payload.string.character == @@ -78,10 +80,14 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload.string. - cdr ) ) ); + && end_of_string( cell_b->payload. + string.cdr ) ) ); break; case INTEGERTV: + result = + cell_a->payload.integer.value == + cell_b->payload.integer.value; + break; case REALTV: { double num_a = numeric_value( a ); @@ -91,7 +97,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); /* - * not more different than one part in a million - close enough + * not more different than one part in a million - close enough */ result = fabs( num_a - num_b ) < ( max / 1000000.0 ); } @@ -103,8 +109,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { /* * there's only supposed ever to be one T and one NIL cell, so each - * should be caught by eq; equality of vector-space objects is a whole - * other ball game so we won't deal with it now (and indeed may never). + * should be caught by eq; equality of vector-space objects is a whole + * other ball game so we won't deal with it now (and indeed may never). * I'm not certain what equality means for read and write streams, so * I'll ignore them, too, for now. */ diff --git a/src/lispops.c b/src/lispops.c index 09704aa..9a62e06 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -91,12 +91,35 @@ struct cons_pointer eval_form( struct stack_frame *parent, next->arg[0] = form; inc_ref( next->arg[0] ); result = lisp_eval( 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. */ free_stack_frame( next ); + } return result; } -struct cons_pointer compose_body( struct stack_frame *frame ) { +/** + * eval all the forms in this `list` in the context of this stack `frame` + * and this `env`, and return a list of their values. If the arg passed as + * `list` is not in fact a list, return nil. + */ +struct cons_pointer eval_forms( struct stack_frame *frame, + struct cons_pointer list, + struct cons_pointer env ) { + return consp( list ) ? + make_cons( eval_form( frame, c_car( list ), env ), eval_forms( frame, c_cdr( list), env)) : + NIL; +} + + +/** + * 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; @@ -106,7 +129,7 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { } } - return body; + return body; } /** @@ -131,7 +154,17 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) { return make_nlambda( frame->arg[0], compose_body( frame ) ); } +void log_binding( struct cons_pointer name, struct cons_pointer val ) { + print( stderr, c_string_to_lisp_string( "\n\tBinding " ) ); + print( stderr, name ); + print( stderr, c_string_to_lisp_string( " to " ) ); + print( stderr, val ); + fputws( L"\"\n", stderr ); +} +/** + * Evaluate a lambda or nlambda expression. + */ struct cons_pointer eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer env ) { @@ -139,20 +172,36 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, fwprintf( stderr, L"eval_lambda called" ); struct cons_pointer new_env = env; - struct cons_pointer args = cell.payload.lambda.args; + struct cons_pointer names = cell.payload.lambda.args; struct cons_pointer body = cell.payload.lambda.body; - for ( int i = 0; i < args_in_frame && consp( args ); i++ ) { - struct cons_pointer arg = c_car( args ); - struct cons_pointer val = frame->arg[i]; - print( stderr, c_string_to_lisp_string( "\n\tBinding " ) ); - print( stderr, arg ); - print( stderr, c_string_to_lisp_string( " to " ) ); - print( stderr, val ); - fputws( L"\"\n", stderr ); + 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++ ) { + struct cons_pointer name = c_car( names ); + struct cons_pointer val = frame->arg[i]; - new_env = make_cons( make_cons( arg, val ), new_env ); - args = c_cdr( args ); + new_env = bind( name, val, new_env ); + log_binding( name, val ); + + names = c_cdr( names ); + } + } 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. */ + 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 ); + + if ( nilp( val ) && nilp( vals ) ) { /* nothing */ + } else { + vals = make_cons( val, vals ); + } + } + + new_env = bind( names, vals, new_env ); } while ( !nilp( body ) ) { @@ -181,7 +230,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { fn_frame->arg[0] = c_car( frame->arg[0] ); inc_ref( fn_frame->arg[0] ); struct cons_pointer fn_pointer = lisp_eval( fn_frame, 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 ); + } struct cons_space_object fn_cell = pointer2cell( fn_pointer ); struct cons_pointer args = c_cdr( frame->arg[0] ); @@ -196,7 +251,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { struct stack_frame *next = make_stack_frame( frame, args, env ); result = ( *fn_cell.payload.special.executable ) ( next, env ); - free_stack_frame( next ); + 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 ); + } } break; case LAMBDATV: @@ -206,7 +266,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { fputws( L"Stack frame for lambda\n", stderr ); dump_frame( stderr, next ); result = eval_lambda( fn_cell, next, env ); - free_stack_frame( next ); + 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 ); + } } break; case NLAMBDATV: @@ -214,7 +279,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { struct stack_frame *next = make_special_frame( frame, args, env ); result = ( *fn_cell.payload.special.executable ) ( next, env ); - free_stack_frame( next ); + 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 ); + } } break; case SPECIALTV: @@ -222,7 +292,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { struct stack_frame *next = make_special_frame( frame, args, env ); result = ( *fn_cell.payload.special.executable ) ( next, env ); - free_stack_frame( next ); + 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 ); + } } break; default: diff --git a/src/lispops.h b/src/lispops.h index 6d49b9b..a0b82cf 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -30,6 +30,39 @@ */ struct cons_pointer c_type( struct cons_pointer pointer ); +/** + * Implementation of car in C. If arg is not a cons, does not error but returns nil. + */ +struct cons_pointer c_car( struct cons_pointer arg ); + +/** + * Implementation of cdr in C. If arg is not a cons, does not error but returns nil. + */ +struct cons_pointer c_cdr( struct cons_pointer arg ); + + +/** + * Useful building block; evaluate this single form in the context of this + * parent stack frame and this environment. + * @param parent the parent stack frame. + * @param form the form to be evaluated. + * @param env the evaluation environment. + * @return the result of evaluating the form. + */ +struct cons_pointer eval_form( struct stack_frame *parent, + struct cons_pointer form, + struct cons_pointer env ); + +/** + * eval all the forms in this `list` in the context of this stack `frame` + * and this `env`, and return a list of their values. If the arg passed as + * `list` is not in fact a list, return nil. + */ +struct cons_pointer eval_forms( struct stack_frame *frame, + struct cons_pointer list, + struct cons_pointer env ); + + /* * special forms */ diff --git a/src/peano.c b/src/peano.c index 047b7c8..eed1b05 100644 --- a/src/peano.c +++ b/src/peano.c @@ -54,19 +54,36 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) { lisp_throw( c_string_to_lisp_string ( "Cannot add: not a number" ), frame ); } + } - if ( !nilp( frame->more ) ) { - lisp_throw( c_string_to_lisp_string - ( "Cannot yet add more than 8 numbers" ), frame ); - } + struct cons_pointer more = frame->more; - if ( is_int ) { - result = make_integer( i_accumulator ); - } else { - result = make_real( d_accumulator ); + while ( consp( more ) ) { + struct cons_pointer pointer = c_car( more ); + more = c_cdr( more); + struct cons_space_object current = pointer2cell( pointer ); + + switch ( current.tag.value ) { + case INTEGERTV: + i_accumulator += current.payload.integer.value; + d_accumulator += numeric_value( pointer ); + break; + case REALTV: + d_accumulator += current.payload.real.value; + is_int = false; + break; + default: + lisp_throw( c_string_to_lisp_string + ( "Cannot add: not a number" ), frame ); } } + if ( is_int ) { + result = make_integer( i_accumulator ); + } else { + result = make_real( d_accumulator ); + } + return result; } @@ -99,18 +116,35 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) { lisp_throw( c_string_to_lisp_string ( "Cannot multiply: not a number" ), frame ); } + } - if ( !nilp( frame->more ) ) { - lisp_throw( c_string_to_lisp_string - ( "Cannot yet multiply more than 8 numbers" ), frame ); + struct cons_pointer more = frame->more; + + while ( consp( more ) ) { + struct cons_pointer pointer = c_car( more ); + more = c_cdr( more); + struct cons_space_object current = pointer2cell( pointer ); + + switch ( current.tag.value ) { + case INTEGERTV: + i_accumulator *= current.payload.integer.value; + d_accumulator *= numeric_value( pointer ); + break; + case REALTV: + d_accumulator *= current.payload.real.value; + is_int = false; + break; + default: + lisp_throw( c_string_to_lisp_string + ( "Cannot add: not a number" ), frame ); } + } if ( is_int ) { result = make_integer( i_accumulator ); } else { result = make_real( d_accumulator ); } - } return result; } diff --git a/src/print.c b/src/print.c index 7957e5e..b6973b1 100644 --- a/src/print.c +++ b/src/print.c @@ -119,29 +119,27 @@ void print( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"\n%sException: ", print_use_colours ? "\x1B[31m" : "" ); print_string_contents( output, cell.payload.exception.message ); - fputws( L"\x1B[39m", output ); break; case INTEGERTV: if ( print_use_colours ) { fputws( L"\x1B[34m", output ); } fwprintf( output, L"%ld%", cell.payload.integer.value ); - if ( print_use_colours ) { - fputws( L"\x1B[39m", output ); - } break; case LAMBDATV: - print( output, make_cons( c_string_to_lisp_symbol("lambda"), - make_cons( cell.payload.lambda.args, - cell.payload.lambda.body ) ) ); + print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda. + body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); break; case NLAMBDATV: - print( output, make_cons( c_string_to_lisp_symbol("nlambda"), - make_cons( cell.payload.lambda.args, - cell.payload.lambda.body ) ) ); + print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda. + body ) ) ); break; case REALTV: /* TODO: using the C heap is a bad plan because it will fragment. @@ -160,9 +158,6 @@ void print( FILE * output, struct cons_pointer pointer ) { fputws( L"\x1B[34m", output ); } fwprintf( output, L"%s", buffer ); - if ( print_use_colours ) { - fputws( L"\x1B[39m", output ); - } free( buffer ); break; case STRINGTV: @@ -170,16 +165,11 @@ void print( FILE * output, struct cons_pointer pointer ) { fputws( L"\x1B[36m", output ); } print_string( output, pointer ); - if ( print_use_colours ) { - fputws( L"\x1B[39m", output ); - } break; case SYMBOLTV: if ( print_use_colours ) fputws( L"\x1B[1;33m", output ); print_string_contents( output, pointer ); - if ( print_use_colours ) - fputws( L"\x1B[0;39m", output ); break; case TRUETV: fwprintf( output, L"t" ); @@ -198,4 +188,8 @@ void print( FILE * output, struct cons_pointer pointer ) { cell.tag.bytes[2], cell.tag.bytes[3], "\x1B[39m" ); break; } + + if ( print_use_colours ) { + fputws( L"\x1B[39m", output ); + } } diff --git a/src/read.c b/src/read.c index ef094d5..5d8b78b 100644 --- a/src/read.c +++ b/src/read.c @@ -61,7 +61,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, switch ( c ) { case ';': - for ( c= fgetwc( input ); c != '\n'; c= fgetwc( input )); + for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) ); /* skip all characters from semi-colon to the end of the line */ break; case EOF: diff --git a/src/stack.c b/src/stack.c index 2c3aa68..74df15f 100644 --- a/src/stack.c +++ b/src/stack.c @@ -98,14 +98,14 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, args = cell.payload.cons.cdr; } - if ( !nilp( args ) ) { - /* - * TODO: this isn't right. These args should also each be evaled. - */ - result->more = args; - inc_ref( result->more ); + 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; + inc_ref( more ); } + dump_frame( stderr, result ); return result; } @@ -133,8 +133,10 @@ struct stack_frame *make_special_frame( struct stack_frame *previous, args = cell.payload.cons.cdr; } - result->more = args; - inc_ref( args ); + if ( consp( args ) ) { + result->more = args; + inc_ref( args ); + } return result; } @@ -174,6 +176,9 @@ void dump_frame( FILE * output, struct stack_frame *frame ) { print( output, frame->arg[arg] ); fputws( L"\n", output ); } + fputws( L"More: \t", output); + print( output, frame->more); + fputws( L"\n", output ); }