From 0826dcfdda110a12b6711daf3e2700405931b230 Mon Sep 17 00:00:00 2001 From: simon Date: Wed, 13 Sep 2017 15:58:59 +0100 Subject: [PATCH] Huge progress. Now actually working. --- src/consspaceobject.h | 16 -------- src/init.c | 35 ++++++++-------- src/integer.c | 2 +- src/integer.h | 2 +- src/intern.c | 4 +- src/intern.h | 2 +- src/lispops.c | 17 +++----- src/peano.c | 50 ++++++++++++++++++++--- src/peano.h | 35 ++++++++++++++++ src/read.c | 16 +++----- src/real.h | 2 +- src/repl.c | 12 ++---- src/stack.c | 82 +++++++++++++++++++++++++++++++++----- src/stack.h | 12 ++++++ unit-tests/complex-list.sh | 2 +- unit-tests/quote.sh | 2 +- unit-tests/quoted-list.sh | 2 +- unit-tests/simple-list.sh | 2 +- 18 files changed, 205 insertions(+), 90 deletions(-) create mode 100644 src/peano.h diff --git a/src/consspaceobject.h b/src/consspaceobject.h index d52a241..4e4dc9c 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -418,14 +418,6 @@ struct cons_pointer make_cons( struct cons_pointer car, */ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) - - - - - - - - ( struct stack_frame *, struct cons_pointer ) ); @@ -434,14 +426,6 @@ struct cons_pointer make_function( struct cons_pointer src, */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - - - - - - - - ( struct cons_pointer s_expr, struct cons_pointer env, struct stack_frame * frame ) ); diff --git a/src/init.c b/src/init.c index 1a85c22..b85b656 100644 --- a/src/init.c +++ b/src/init.c @@ -19,19 +19,21 @@ #include "consspaceobject.h" #include "intern.h" #include "lispops.h" +#include "peano.h" +#include "print.h" #include "repl.h" void bind_function( char *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer ) ) { - deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ), - make_function( NIL, executable ) ); + deep_bind( c_string_to_lisp_symbol( name ), + make_function( NIL, executable )); } void bind_special( char *name, struct cons_pointer ( *executable ) ( struct cons_pointer s_expr, struct cons_pointer env, struct stack_frame * frame ) ) { - deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ), - make_special( NIL, executable ) ); + deep_bind( c_string_to_lisp_symbol( name ), + make_special( NIL, executable )); } int main( int argc, char *argv[] ) { @@ -70,17 +72,13 @@ int main( int argc, char *argv[] ) { /* * privileged variables (keywords) */ - /* - deep_bind( intern( c_string_to_lisp_string( "nil" ), oblist ), NIL ); - deep_bind( intern( c_string_to_lisp_string( "t" ), oblist ), TRUE ); - */ - struct cons_pointer lisp_symbol = c_string_to_lisp_symbol( "oblist"); - deep_bind( lisp_symbol, &oblist); + + deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); + deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); /* * primitive function operations */ - /* bind_function( "assoc", &lisp_assoc ); bind_function( "car", &lisp_car ); bind_function( "cdr", &lisp_cdr ); @@ -89,19 +87,20 @@ int main( int argc, char *argv[] ) { bind_function( "equal", &lisp_equal ); bind_function( "read", &lisp_read ); bind_function( "print", &lisp_print ); -*/ + + bind_function( "plus", &lisp_plus); + /* * primitive special forms */ - /* bind_special( "apply", &lisp_apply ); bind_special( "eval", &lisp_eval ); bind_special( "quote", &lisp_quote ); - */ - if ( show_prompt) { - fwprintf( stderr, L"Oblist: "); - print(stderr, *oblist); - } + + + /* bind the oblist last, at this stage. Something clever needs to be done + * here and I'm not sure what it is. */ + deep_bind( c_string_to_lisp_symbol( "oblist"), oblist); repl( stdin, stdout, stderr, show_prompt ); diff --git a/src/integer.c b/src/integer.c index fa1327f..390594c 100644 --- a/src/integer.c +++ b/src/integer.c @@ -20,7 +20,7 @@ * as a cons-space object. Cell may in principle be any kind of number, * but only integers and reals are so far implemented. */ -double numeric_value( struct cons_pointer pointer ) { +long double numeric_value( struct cons_pointer pointer ) { double result = NAN; struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/integer.h b/src/integer.h index e3e8c3b..d44f34d 100644 --- a/src/integer.h +++ b/src/integer.h @@ -11,7 +11,7 @@ #ifndef __integer_h #define __integer_h -double numeric_value( struct cons_pointer pointer ); +long double numeric_value( struct cons_pointer pointer ); /** * Allocate an integer cell representing this value and return a cons pointer to it. diff --git a/src/intern.c b/src/intern.c index 8843945..fae0b7a 100644 --- a/src/intern.c +++ b/src/intern.c @@ -32,7 +32,7 @@ * they're visible to all users/threads, but again I don't yet have any idea how * that will work. */ -struct cons_pointer oblist = & NIL; +struct cons_pointer oblist = NIL; /** * Implementation of interned? in C. The final implementation if interned? will @@ -104,7 +104,7 @@ bind( struct cons_pointer key, struct cons_pointer value, */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ) { - oblist = &bind( key, value, *oblist ); + oblist = bind( key, value, oblist ); return oblist; } diff --git a/src/intern.h b/src/intern.h index bd1656c..e940daa 100644 --- a/src/intern.h +++ b/src/intern.h @@ -20,7 +20,7 @@ #ifndef __intern_h #define __intern_h -extern struct cons_pointer * oblist; +extern struct cons_pointer oblist; /** * return the value associated with this key in this store. In the current diff --git a/src/lispops.c b/src/lispops.c index 3e20d52..073455f 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -102,9 +102,10 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env, switch ( fn_cell.tag.value ) { case SPECIALTV: { - struct cons_space_object special = pointer2cell( fn_pointer ); + struct stack_frame *frame = + make_special_frame( my_frame, args, env ); result = - ( *special.payload.special.executable ) ( args, env, my_frame ); + ( *fn_cell.payload.special.executable ) ( args, env, frame ); } break; @@ -121,7 +122,7 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env, * the trick: pass the remaining arguments and environment to the * executable code which is the payload of the function object. */ - result = ( *function.payload.function.executable ) ( frame, env ); + result = ( *fn_cell.payload.function.executable ) ( frame, env ); free_stack_frame( frame ); } break; @@ -165,13 +166,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, switch ( cell.tag.value ) { case CONSTV: - fwprintf( stderr, L"In eval; about to make stack frame" ); - struct stack_frame *frame = make_stack_frame( previous, s_expr, env ); - fwprintf( stderr, L"In eval; stack frame made" ); - - result = eval_cons( s_expr, env, frame ); - - free_stack_frame( frame ); + result = eval_cons( s_expr, env, previous); break; case SYMBOLTV: @@ -181,7 +176,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, struct cons_pointer message = c_string_to_lisp_string ( "Attempt to take value of unbound symbol." ); - result = lisp_throw( message, frame ); + result = lisp_throw( message, previous ); } else { result = c_assoc( canonical, env ); } diff --git a/src/peano.c b/src/peano.c index 67fc8c2..e39a58e 100644 --- a/src/peano.c +++ b/src/peano.c @@ -12,6 +12,7 @@ #include #include #include +#include #include "consspaceobject.h" #include "conspage.h" @@ -21,15 +22,52 @@ #include "lispops.h" #include "print.h" #include "read.h" +#include "real.h" #include "stack.h" -/* +/** + * Add an indefinite number of numbers together + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ struct cons_pointer -lisp_plus( struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame *frame ) { - struct cons_space_object cell = pointer2cell( s_expr ); - struct cons_space_object result = NIL; +lisp_plus(struct stack_frame *frame, struct cons_pointer env) { + struct cons_pointer result = NIL; + long int i_accumulator = 0; + long double d_accumulator = 0; + bool is_int = true; + for (int i = 0; i < args_in_frame && !nilp(frame->arg[i]); i++) { + struct cons_space_object arg = pointer2cell(frame->arg[i]); + + switch (arg.tag.value) { + case INTEGERTV: + i_accumulator += arg.payload.integer.value; + d_accumulator += numeric_value( frame->arg[i]); + break; + case REALTV: + d_accumulator += arg.payload.real.value; + is_int = false; + default: + 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); + } + + if ( is_int) { + result = make_integer( i_accumulator); + } else { + result = make_real( d_accumulator); + } + } + return result; } -*/ + diff --git a/src/peano.h b/src/peano.h new file mode 100644 index 0000000..b50f922 --- /dev/null +++ b/src/peano.h @@ -0,0 +1,35 @@ +/** + * peano.h + * + * Basic peano arithmetic + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "consspaceobject.h" + +#ifndef PEANO_H +#define PEANO_H + +#ifdef __cplusplus +extern "C" { +#endif + +/** + * Add an indefinite number of numbers together + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer +lisp_plus(struct stack_frame *frame, struct cons_pointer env); + + + +#ifdef __cplusplus +} +#endif + +#endif /* PEANO_H */ + diff --git a/src/read.c b/src/read.c index 85174ee..f2eeff5 100644 --- a/src/read.c +++ b/src/read.c @@ -147,8 +147,6 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; - fwprintf( stderr, L"read_string starting '%C' (%d)\n", initial, initial ); - switch ( initial ) { case '\0': result = make_string( initial, NIL ); @@ -168,8 +166,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; - fwprintf( stderr, L"read_symbol starting '%C' (%d)\n", initial, initial ); - switch ( initial ) { case '\0': result = make_symbol( initial, NIL ); @@ -191,16 +187,16 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { ungetwc( initial, input ); break; default: - if ( iswblank( initial ) || !iswprint( initial ) ) { - result = make_symbol( '\0', NIL ); + if ( iswalnum( initial ) ) { + result = + make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); + } else { + result = NIL; /* * push back the character read */ ungetwc( initial, input ); - } else { - result = - make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); - } + } break; } diff --git a/src/real.h b/src/real.h index 7e3601f..759a2bb 100644 --- a/src/real.h +++ b/src/real.h @@ -24,7 +24,7 @@ extern "C" { * @param value the value to wrap; * @return a real number cell wrapping this value. */ - struct cons_pointer make_real( double value ); +struct cons_pointer make_real( double value ); #ifdef __cplusplus } diff --git a/src/repl.c b/src/repl.c index acfb73c..2e9fb41 100644 --- a/src/repl.c +++ b/src/repl.c @@ -31,19 +31,13 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, struct cons_pointer input = read( in_stream ); fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page, input.offset ); - if ( show_prompt ) { - fwprintf( out_stream, L"\n-> " ); - } + print( error_stream, input); - /* OK, I think what's going wrong here is we're passing by - * value and I think we should be passing by reference. - * I'm not certain about that, and as it will be a really - * major change I'm going to think some more before making - * in */ - print( out_stream, lisp_eval( input, oblist, NULL ) ); + struct cons_pointer value = lisp_eval( input, oblist, NULL ); // print( out_stream, input ); fwprintf( out_stream, L"\n" ); fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page, input.offset ); + print( out_stream, value); } } diff --git a/src/stack.c b/src/stack.c index 6581b02..25e9795 100644 --- a/src/stack.c +++ b/src/stack.c @@ -4,13 +4,13 @@ * The Lisp evaluation stack. * * Stack frames could be implemented in cons space; indeed, the stack - * could simply be an assoc list consed onto the front of the environment. - * But such a stack would be costly to search. The design sketched here, - * with stack frames as special objects, SHOULD be substantially more + * could simply be an assoc list consed onto the front of the environment. + * But such a stack would be costly to search. The design sketched here, + * with stack frames as special objects, SHOULD be substantially more * efficient, but does imply we need to generalise the idea of cons pages * 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. * @@ -23,6 +23,7 @@ #include "consspaceobject.h" #include "conspage.h" #include "lispops.h" +#include "print.h" #include "stack.h" /** @@ -33,7 +34,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, struct cons_pointer args, struct cons_pointer env ) { /* - * TODO: later, pop a frame off a free-list of stack frames + * TODO: later, pop a frame off a free-list of stack frames */ struct stack_frame *result = malloc( sizeof( struct stack_frame ) ); @@ -41,7 +42,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, /* * clearing the frame with memset would probably be slightly quicker, but - * this is clear. + * this is clear. */ result->more = NIL; result->function = NIL; @@ -50,7 +51,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, result->arg[i] = NIL; } - int i = 0; /* still an index into args, so same name will + int i = 0; /* still an index into args, so same name will * do */ while ( !nilp( args ) ) { /* iterate down the arg list filling in the @@ -60,18 +61,79 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, struct cons_space_object cell = pointer2cell( args ); if ( i < args_in_frame ) { + fwprintf(stderr, L"Making frame; arg %d: ", i); + print(stderr, cell.payload.cons.car); /* * 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 + * processor to be evaled in parallel */ result->arg[i] = lisp_eval( cell.payload.cons.car, env, result ); inc_ref( result->arg[i] ); args = cell.payload.cons.cdr; + i++; } else { /* - * TODO: this isn't right. These args should also each be evaled. + * TODO: this isn't right. These args should also each be evaled. + */ + result->more = args; + inc_ref( result->more ); + + args = NIL; + } + } + + return result; +} + +/** + * 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 args, + struct cons_pointer env ) { + /* + * TODO: later, pop a frame off a free-list of stack frames + */ + struct stack_frame *result = malloc( sizeof( struct stack_frame ) ); + + result->previous = previous; + + /* + * clearing the frame with memset would probably be slightly quicker, but + * this is clear. + */ + result->more = NIL; + result->function = NIL; + + for ( int i = 0; i < args_in_frame; i++ ) { + result->arg[i] = NIL; + } + + int i = 0; /* still an index into args, so same name will + * do */ + + while ( !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 */ + struct cons_space_object cell = pointer2cell( args ); + + if ( i < args_in_frame ) { + result->arg[i] = cell.payload.cons.car; + inc_ref( result->arg[i] ); + + args = cell.payload.cons.cdr; + i++; + } else { + /* + * TODO: this isn't right. These args should also each be evaled. */ result->more = args; inc_ref( result->more ); @@ -88,7 +150,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, */ void free_stack_frame( struct stack_frame *frame ) { /* - * TODO: later, push it back on the stack-frame freelist + * TODO: later, push it back on the stack-frame freelist */ for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->arg[i] ); diff --git a/src/stack.h b/src/stack.h index 47d97e9..4eaa9e1 100644 --- a/src/stack.h +++ b/src/stack.h @@ -30,6 +30,18 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, void free_stack_frame( struct stack_frame *frame ); 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 args, + struct cons_pointer env ); + /* * struct stack_frame is defined in consspaceobject.h to break circularity * TODO: refactor. diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index c4c8e94..70ab629 100644 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(1 2 3 ("Fred") nil 77354)' -actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null | head -1` +actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh index f7bf353..6785966 100644 --- a/unit-tests/quote.sh +++ b/unit-tests/quote.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(quote Fred)' +expected='Fred' actual=`echo "'Fred" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh index 1d18369..6ba50cc 100644 --- a/unit-tests/quoted-list.sh +++ b/unit-tests/quoted-list.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(quote (123 (4 (5 nil)) Fred))' +expected='(123 (4 (5 nil)) Fred)' actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh index 8d0c758..35ed153 100644 --- a/unit-tests/simple-list.sh +++ b/unit-tests/simple-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="(1 2 3)" -actual=`echo '(1 2 3)' | target/psse 2> /dev/null | head -1` +actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then