diff --git a/include/licence-header.txt b/include/licence-header.txt new file mode 100644 index 0000000..f2b4107 --- /dev/null +++ b/include/licence-header.txt @@ -0,0 +1,2 @@ +(c) 2017 Simon Brooke +Licensed under GPL version 2.0, or, at your option, any later version. diff --git a/src/conspage.c b/src/conspage.c index efb9f91..7221ffc 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -164,11 +164,12 @@ struct cons_pointer allocate_cell( char *tag ) { cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; +#ifdef DEBUG fprintf( stderr, "Allocated cell of type '%s' at %d, %d \n", tag, result.page, result.offset ); - // dump_object( stderr, result ); - } else { +#endif + } else { fprintf( stderr, "WARNING: Allocating non-free cell!" ); } } @@ -188,7 +189,7 @@ void initialise_cons_pages( ) { make_cons_page( ); conspageinitihasbeencalled = true; } else { - fprintf( stderr, - "WARNING: conspageinit() called a second or subsequent time\n" ); + fwprintf( stderr, + L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); } } diff --git a/src/conspage.h b/src/conspage.h index 0dfff8f..3e8026e 100644 --- a/src/conspage.h +++ b/src/conspage.h @@ -4,23 +4,27 @@ #define __conspage_h /** - * the number of cons cells on a cons page. The maximum value this can be (and consequently, - * the size which, by version 1, it will default to) is the maximum value of an unsigned 32 - * bit integer, which is to say 4294967296. However, we'll start small. + * the number of cons cells on a cons page. The maximum value this can + * be (and consequently, the size which, by version 1, it will default + * to) is the maximum value of an unsigned 32 bit integer, which is to + * say 4294967296. However, we'll start small. */ #define CONSPAGESIZE 8 /** - * the number of cons pages we will initially allow for. For convenience we'll set up an array - * of cons pages this big; however, later we will want a mechanism for this to be able to grow - * dynamically to the maximum we can currently allow, which is 4294967296. + * the number of cons pages we will initially allow for. For + * convenience we'll set up an array of cons pages this big; however, + * later we will want a mechanism for this to be able to grow + * dynamically to the maximum we can currently allow, which is + * 4294967296. */ #define NCONSPAGES 8 /** - * a cons page is essentially just an array of cons space objects. It might later have a local - * free list (i.e. list of free cells on this page) and a pointer to the next cons page, but - * my current view is that that's probably unneccessary. + * a cons page is essentially just an array of cons space objects. It + * might later have a local free list (i.e. list of free cells on this + * page) and a pointer to the next cons page, but my current view is + * that that's probably unneccessary. */ struct cons_page { struct cons_space_object cell[CONSPAGESIZE]; diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 35b8e5f..c7889ed 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -19,6 +19,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "print.h" /** * Check that the tag on the cell at this pointer is this tag @@ -73,28 +74,47 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { cell.tag.bytes[3], cell.tag.value, pointer.page, pointer.offset, cell.count ); - if ( check_tag( pointer, CONSTAG ) ) { + switch ( cell.tag.value) { + case CONSTV: fwprintf( output, L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n", cell.payload.cons.car.page, cell.payload.cons.car.offset, cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset ); - } else if ( check_tag( pointer, INTEGERTAG ) ) { + break; + case INTEGERTV: fwprintf( output, L"\t\tInteger cell: value %ld\n", cell.payload.integer.value ); - } else if ( check_tag( pointer, FREETAG ) ) { + 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 ); - } else if ( check_tag( pointer, REALTAG ) ) { + break; + case REALTV: fwprintf( output, L"\t\tReal cell: value %Lf\n", cell.payload.real.value ); - } else if ( check_tag( pointer, STRINGTAG ) ) { + break; + case STRINGTV: fwprintf( output, L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d\n", cell.payload.string.character, cell.payload.string.cdr.page, cell.payload.string.cdr.offset ); + fwprintf( output, L"\t\t value:"); + print(output, pointer); + fwprintf( output, L"\n"); + break; + case SYMBOLTV: + fwprintf( output, + L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d\n", + cell.payload.string.character, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset ); + fwprintf( output, L"\t\t value:"); + print(output, pointer); + fwprintf( output, L"\n"); + break; } } @@ -150,7 +170,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { inc_ref( tail ); cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; - /* TODO: There's a problem here. Sometimes the offsets on + /* TODO: There's a problem here. Sometimes the offsets on * strings are quite massively off. */ cell->payload.string.cdr.offset = tail.offset; } else { diff --git a/src/consspaceobject.h b/src/consspaceobject.h index 3b8c9fa..4e4dc9c 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -156,7 +156,7 @@ #define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) /** - * true if conspointer points to a string cell, else false + * true if conspointer points to a symbol cell, else false */ #define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) @@ -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/equal.c b/src/equal.c index 2a20d5e..23de51c 100644 --- a/src/equal.c +++ b/src/equal.c @@ -22,6 +22,21 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) { return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); } +/** + * 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, + * else false. + */ +bool same_type( struct cons_pointer a, struct cons_pointer b ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); + + return cell_a->tag.value == cell_b->tag.value; + +} + /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. @@ -29,15 +44,18 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) { bool equal( struct cons_pointer a, struct cons_pointer b ) { bool result = eq( a, b ); - if ( !result ) { + if ( !result && same_type( a, b ) ) { struct cons_space_object *cell_a = &pointer2cell( a ); struct cons_space_object *cell_b = &pointer2cell( b ); - if ( consp( a ) && consp( b ) ) { + switch ( cell_a->tag.value ) { + case CONSTV: result = equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) && equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr ); - } else if ( stringp( a ) && stringp( b ) ) { + break; + case STRINGTV: + case SYMBOLTV: /* * 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 @@ -48,17 +66,27 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { cell_b->payload.string.character && equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr ); - } else if ( numberp( a ) && numberp( b ) ) { - double num_a = numeric_value( a ); - double num_b = numeric_value( b ); - double max = - fabs( num_a ) > fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); + break; + case INTEGERTV: + case REALTV: + { + double num_a = numeric_value( a ); + double num_b = numeric_value( b ); + double max = + fabs( num_a ) > + fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); - /* - * not more different than one part in a million - close enough - */ - result = fabs( num_a - num_b ) < ( max / 1000000.0 ); + /* + * not more different than one part in a million - close enough + */ + result = fabs( num_a - num_b ) < ( max / 1000000.0 ); + } + break; + default: + result = false; + break; } + /* * 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 diff --git a/src/init.c b/src/init.c index ff77551..a51e827 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[] ) { @@ -54,14 +56,14 @@ int main( int argc, char *argv[] ) { show_prompt = true; break; default: - fprintf( stderr, "Unexpected option %c\n", option ); + fwprintf( stderr, L"Unexpected option %c\n", option ); break; } } if ( show_prompt ) { - fprintf( stdout, - "Post scarcity software environment version %s\n\n", + fwprintf( stdout, + L"Post scarcity software environment version %s\n\n", VERSION ); } @@ -70,8 +72,9 @@ 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 ); + + deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); + deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); /* * primitive function operations @@ -84,6 +87,10 @@ int main( int argc, char *argv[] ) { bind_function( "equal", &lisp_equal ); bind_function( "read", &lisp_read ); bind_function( "print", &lisp_print ); + + bind_function( "add", &lisp_add); + bind_function( "multiply", &lisp_multiply); + bind_function( "subtract", &lisp_subtract); /* * primitive special forms @@ -91,7 +98,12 @@ int main( int argc, char *argv[] ) { bind_special( "apply", &lisp_apply ); bind_special( "eval", &lisp_eval ); bind_special( "quote", &lisp_quote ); - + + + /* 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 ); if ( dump_at_end ) { diff --git a/src/integer.c b/src/integer.c index ad128ee..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 ); @@ -41,7 +41,7 @@ struct cons_pointer make_integer( long int value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; - dump_object( stderr, result); + dump_object( stderr, result ); return result; } 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 31b7e2e..fae0b7a 100644 --- a/src/intern.c +++ b/src/intern.c @@ -91,7 +91,7 @@ struct cons_pointer c_assoc( struct cons_pointer key, * Return a new key/value store containing all the key/value pairs in this store * with this key/value pair added to the front. */ -struct cons_pointer +struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer store ) { return make_cons( make_cons( key, value ), store ); diff --git a/src/lispops.c b/src/lispops.c index 85ec7eb..073455f 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -102,10 +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; @@ -122,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; @@ -164,15 +164,9 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, struct cons_pointer result = s_expr; struct cons_space_object cell = pointer2cell( s_expr ); - fprintf( stderr, "In eval; about to make stack frame" ); - - struct stack_frame *frame = make_stack_frame( previous, s_expr, env ); - - fprintf( stderr, "In eval; stack frame made" ); - switch ( cell.tag.value ) { case CONSTV: - result = eval_cons( s_expr, env, frame ); + result = eval_cons( s_expr, env, previous); break; case SYMBOLTV: @@ -182,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 ); } @@ -197,8 +191,6 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, */ } - free_stack_frame( frame ); - return result; } @@ -212,7 +204,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env, struct stack_frame *frame ) { - return c_car( args ); + return frame->arg[0]; } /** @@ -360,10 +352,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) { */ struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { - fprintf( stderr, "\nERROR: " ); + fwprintf( stderr, L"\nERROR: " ); print( stderr, message ); - fprintf( stderr, - "\n\nAn exception was thrown and I've no idea what to do now\n" ); + fwprintf( stderr, + L"\n\nAn exception was thrown and I've no idea what to do now\n" ); exit( 1 ); } diff --git a/src/peano.c b/src/peano.c new file mode 100644 index 0000000..5f50280 --- /dev/null +++ b/src/peano.c @@ -0,0 +1,149 @@ +/** + * peano.c + * + * Basic peano arithmetic + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "equal.h" +#include "integer.h" +#include "intern.h" +#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_add(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; +} + +/** + * Multiply 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_multiply(struct stack_frame *frame, struct cons_pointer env) { + struct cons_pointer result = NIL; + long int i_accumulator = 1; + long double d_accumulator = 1; + 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 multiply: not a number"), + frame); + } + + if (! nilp(frame->more)) { + lisp_throw( + c_string_to_lisp_string("Cannot yet multiply more than 8 numbers"), + frame); + } + + if ( is_int) { + result = make_integer( i_accumulator); + } else { + result = make_real( d_accumulator); + } + } + + return result; +} + +/** + * Subtract one number from another. + * @param env the evaluation environment - ignored; + * @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 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[0])); + } // else we have an error! + + // and if not nilp[frame->arg[2]) we also have an error. + + return result; +} + + + diff --git a/src/peano.h b/src/peano.h new file mode 100644 index 0000000..36b64ea --- /dev/null +++ b/src/peano.h @@ -0,0 +1,51 @@ +/** + * 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_add(struct stack_frame *frame, struct cons_pointer env); + +/** + * Multiply 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_multiply(struct stack_frame *frame, struct cons_pointer env); + +/** + * Subtract one number from another. + * @param env the evaluation environment - ignored; + * @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); + +#ifdef __cplusplus +} +#endif + +#endif /* PEANO_H */ + diff --git a/src/print.c b/src/print.c index abe7dda..ca866cf 100644 --- a/src/print.c +++ b/src/print.c @@ -89,7 +89,7 @@ void print( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"nil" ); break; case REALTV: - fwprintf( output, L"%lf", cell.payload.real.value ); + fwprintf( output, L"%Lf", cell.payload.real.value ); break; case STRINGTV: print_string( output, pointer ); @@ -100,6 +100,12 @@ void print( FILE * output, struct cons_pointer pointer ) { case TRUETV: fwprintf( output, L"t" ); break; + case FUNCTIONTV: + fwprintf( output, L"(Function)"); + break; + case SPECIALTV: + fwprintf( output, L"(Special form)"); + break; default: fwprintf( stderr, L"Error: Unrecognised tag value %d (%c%c%c%c)\n", diff --git a/src/read.c b/src/read.c index 26e0b9d..abd76bb 100644 --- a/src/read.c +++ b/src/read.c @@ -82,6 +82,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { * read a number from this input stream, given this initial character. */ struct cons_pointer read_number( FILE * input, wint_t initial ) { + struct cons_pointer result = NIL; long int accumulator = 0; int places_of_decimals = 0; bool seen_period = false; @@ -96,7 +97,8 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); - fprintf( stderr, "Added character %c, accumulator now %ld\n", c, accumulator); + fwprintf( stderr, L"Added character %c, accumulator now %ld\n", c, + accumulator ); if ( seen_period ) { places_of_decimals++; @@ -110,10 +112,16 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { ungetwc( c, input ); if ( seen_period ) { - return make_real( accumulator / pow( 10, places_of_decimals ) ); + long double rv = (long double) + ( accumulator / pow(10, places_of_decimals) ); + + fwprintf( stderr, L"read_numer returning %Lf\n", rv); + result = make_real( rv); } else { - return make_integer( accumulator ); + result = make_integer( accumulator ); } + + return result; } /** @@ -146,8 +154,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 ); @@ -167,8 +173,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 ); @@ -190,16 +194,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 22c1571..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)); - print( out_stream, input ); + 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..83ecf3a 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,36 +51,74 @@ 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 - * 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 */ + for (int i = 0; i < args_in_frame && !nilp( args ); i++ ) { + /* 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 ) { /* * 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; - } 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; } + for (int i = 0; i < args_in_frame && !nilp( args ); i++ ) { + /* 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 ); + + result->arg[i] = cell.payload.cons.car; + inc_ref( result->arg[i] ); + + args = cell.payload.cons.cdr; + } + result->more = args; + inc_ref(args); + return result; } @@ -88,7 +127,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