From 93b84087ceecf4e7242a5c442be07b4d22f6c376 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 7 Dec 2018 20:09:33 +0000 Subject: [PATCH] There's an enormous lot of good stuff in this, but I've messed up print almost certainly by writing a non-wide character to a wide stream. --- Makefile | 2 +- src/conspage.c | 29 +++++-- src/consspaceobject.c | 86 ++++++++++++++++++--- src/consspaceobject.h | 130 ++++++++++++++++++++++++-------- src/init.c | 3 +- src/lispops.c | 20 +++-- src/peano.c | 40 +++++++++- src/print.c | 77 ++++++++++--------- src/read.c | 25 +++--- src/read.h | 2 +- src/repl.c | 80 +++++++++++++++----- src/stack.c | 12 ++- unit-tests/string-allocation.sh | 4 +- 13 files changed, 379 insertions(+), 131 deletions(-) diff --git a/Makefile b/Makefile index 207b162..1ba8422 100644 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ INC_DIRS := $(shell find $(SRC_DIRS) -type d) INC_FLAGS := $(addprefix -I,$(INC_DIRS)) INDENT_FLAGS := -kr -br -brf -brs -ce -cdw -npsl -nut -prs -l79 -ts2 -VERSION := "0.0.0" +VERSION := "0.0.2" CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g LDFLAGS := -lm diff --git a/src/conspage.c b/src/conspage.c index 6e8ee26..9b0d218 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -1,7 +1,7 @@ /* * conspage.c * - * Setup and tear down cons pages, and (FOR NOW) do primitive + * Setup and tear down cons pages, and (FOR NOW) do primitive * allocation/deallocation of cells. * NOTE THAT before we go multi-threaded, these functions must be * aggressively @@ -30,7 +30,7 @@ bool conspageinitihasbeencalled = false; int initialised_cons_pages = 0; /** - * 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. */ struct cons_pointer freelist = NIL; @@ -54,19 +54,21 @@ void make_cons_page( ) { for ( int i = 0; i < CONSPAGESIZE; i++ ) { struct cons_space_object *cell = &conspages[initialised_cons_pages]->cell[i]; - if ( initialised_cons_pages == 0 && i < 2 ) { - if ( i == 0 ) { + if ( initialised_cons_pages == 0 && i < 3 ) { + switch ( i) { + case 0: /* - * initialise cell as NIL + * initialise cell as NIL */ strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH ); cell->count = MAXREFERENCE; cell->payload.free.car = NIL; cell->payload.free.cdr = NIL; fwprintf( stderr, L"Allocated special cell NIL\n" ); - } else if ( i == 1 ) { + break; + case 1: /* - * initialise cell as T + * initialise cell as T */ strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH ); cell->count = MAXREFERENCE; @@ -75,10 +77,21 @@ void make_cons_page( ) { cell->payload.free.cdr = ( struct cons_pointer ) { 0, 1}; fwprintf( stderr, L"Allocated special cell T\n" ); + break; + case 2: + /* + * initialise cell as λ + */ + strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH ); + cell->count = MAXREFERENCE; + cell->payload.string.character = (wint_t)L'λ'; + cell->payload.free.cdr = NIL; + fwprintf( stderr, L"Allocated special cell LAMBDA\n" ); + break; } } else { /* - * otherwise, standard initialisation + * otherwise, standard initialisation */ strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); cell->payload.free.car = NIL; diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 3569f5d..8c3de50 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -11,8 +11,9 @@ #include #include #include +#include /* - * wide characters + * wide characters */ #include #include @@ -20,6 +21,7 @@ #include "conspage.h" #include "consspaceobject.h" #include "print.h" +#include "stack.h" /** * Check that the tag on the cell at this pointer is this tag @@ -83,33 +85,53 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { 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"); + /* TODO: dump the stack trace */ + 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 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 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: + if (cell.payload.string.character == 0) { fwprintf( output, - L"\t\tString cell: character '%c' (%d) next at page %d offset %d, count %u\n", + L"\t\tString cell: termination; next at page %d offset %d, count %u\n", + cell.payload.string.character, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset, cell.count ); + }else { + fwprintf( output, + L"\t\tString cell: character '%lc' (%d) next at page %d offset %d, count %u\n", 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" ); + fwprintf( output, L"\n" );} break; case SYMBOLTV: fwprintf( output, - L"\t\tSymbol cell: character '%c' (%d) next at page %d offset %d, count %u\n", + L"\t\tSymbol cell: character '%lc' (%d) next at page %d offset %d, count %u\n", cell.payload.string.character, cell.payload.string.character, cell.payload.string.cdr.page, @@ -141,6 +163,22 @@ struct cons_pointer make_cons( struct cons_pointer car, return pointer; } +/** + * 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 pointer = allocate_cell( EXCEPTIONTAG ); + struct cons_space_object *cell = &pointer2cell( pointer ); + + cell->payload.exception.message = message; + cell->payload.exception.frame = frame; + + return pointer; +} + + /** * Construct a cell which points to an executable Lisp special form. */ @@ -159,7 +197,7 @@ make_function( struct cons_pointer src, struct cons_pointer ( *executable ) /** * 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 - * has one character and a pointer to the next; in the last cell the + * has one character and a pointer to the next; in the last cell the * pointer to next is NIL. */ struct cons_pointer @@ -188,7 +226,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { /** * Construct a string from this character and * this tail. A string is implemented as a flat list of cells each of which - * has one character and a pointer to the next; in the last cell the + * has one character and a pointer to the next; in the last cell the * pointer to next is NIL. */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { @@ -196,7 +234,7 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { } /** - * Construct a symbol from this character and this tail. + * Construct a symbol from this character and this tail. */ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { return make_string_like_thing( c, tail, SYMBOLTAG ); @@ -217,6 +255,32 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable ) return pointer; } +/** + * Construct a cell which points to a stream open for reading. + * @param input the C stream to wrap. + */ +struct cons_pointer make_read_stream( FILE * input) { + struct cons_pointer pointer = allocate_cell( READTAG ); + struct cons_space_object *cell = &pointer2cell( pointer ); + + cell->payload.stream.stream = input; + + return pointer; +} + +/** + * Construct a cell which points to a stream open for writeing. + * @param output the C stream to wrap. + */ +struct cons_pointer make_write_stream( FILE * output) { + struct cons_pointer pointer = allocate_cell( WRITETAG ); + struct cons_space_object *cell = &pointer2cell( pointer ); + + cell->payload.stream.stream = output; + + return pointer; +} + /** * Return a lisp string representation of this old skool ASCII string. */ diff --git a/src/consspaceobject.h b/src/consspaceobject.h index 649ec4b..05939c2 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -12,7 +12,7 @@ #include #include /* - * wide characters + * wide characters */ #include #include @@ -53,6 +53,13 @@ #define INTEGERTAG "INTR" #define INTEGERTV 1381256777 +/** + * Lambda is very special, and, like NIL and TRUE, we need to identify it + * quickly and cheaply. So we will give it, too, a special cons cell at {0,2} + */ +#define LAMBDATAG "LMDA" +#define LAMBDATV 1094995276 + /** * The special cons cell at address {0,0} whose car and cdr both point to itself. * 541870414 @@ -64,6 +71,7 @@ * An open read stream. */ #define READTAG "READ" +#define READTV 1145128274 /** * A real number. @@ -85,7 +93,7 @@ #define STRINGTV 1196577875 /** - * A symbol is just like a string except not self-evaluating. 1112365395 + * A symbol is just like a string except not self-evaluating. 1112365395 */ #define SYMBOLTAG "SYMB" #define SYMBOLTV 1112365395 @@ -106,6 +114,15 @@ * An open write stream. */ #define WRITETAG "WRIT" +/* TODO: this is wrong */ +#define WRITETV 1414091351 + +/** + * An exception. + */ +#define EXCEPTIONTAG "EXEP" +/* TODO: this is wrong */ +#define EXCEPTIONTV 1346721861 /** * a cons pointer which points to the special NIL cell @@ -117,6 +134,11 @@ */ #define TRUE (struct cons_pointer){ 0, 1} +/** + * a cons pointer which points to the special λ cell + */ +#define LAMBDA (struct cons_pointer){ 0,2} + /** * the maximum possible value of a reference count */ @@ -130,53 +152,63 @@ #define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset])) /** - * true if conspointer points to the special cell NIL, else false + * true if conspointer points to the special cell NIL, else false * (there should only be one of these so it's slightly redundant). */ #define nilp(conspoint) (check_tag(conspoint,NILTAG)) /** - * true if conspointer points to a cons cell, else false + * true if conspointer points to a cons cell, else false */ #define consp(conspoint) (check_tag(conspoint,CONSTAG)) /** - * true if conspointer points to a function cell, else false + * true if conspointer points to an exception, else false + */ +#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG)) + +/** + * true if conspointer points to a function cell, else false */ #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) /** - * true if conspointer points to a special form cell, else false + * true if conspointer points to the special Lambda cell, else false + */ +#define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) + +/** + * true if conspointer points to a special form cell, else false */ #define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) /** - * true if conspointer points to a string cell, else false + * true if conspointer points to a string cell, else false */ #define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) /** - * true if conspointer points to a symbol cell, else false + * true if conspointer points to a symbol cell, else false */ #define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) /** - * true if conspointer points to an integer cell, else false + * true if conspointer points to an integer cell, else false */ #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) /** - * true if conspointer points to a read stream cell, else false + * true if conspointer points to a read stream cell, else false */ #define readp(conspoint) (check_tag(conspoint,READTAG)) /** - * true if conspointer points to a real number cell, else false + * true if conspointer points to a real number cell, else false */ #define realp(conspoint) (check_tag(conspoint,REALTAG)) /** - * true if conspointer points to some sort of a number cell, + * true if conspointer points to some sort of a number cell, * else false */ #define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG)) @@ -187,7 +219,7 @@ #define writep(conspoint) (check_tag(conspoint,WRITETAG)) /** - * true if conspointer points to a true cell, else false + * true if conspointer points to a true cell, else false * (there should only be one of these so it's slightly redundant). * Also note that anything that is not NIL is truthy. */ @@ -209,7 +241,7 @@ struct cons_pointer { }; /* - * number of arguments stored in a stack frame + * number of arguments stored in a stack frame */ #define args_in_frame 8 @@ -221,7 +253,7 @@ struct stack_frame { struct stack_frame *previous; /* the previous frame */ struct cons_pointer arg[args_in_frame]; /* - * first 8 arument bindings + * first 8 arument bindings */ struct cons_pointer more; /* list of any further argument bindings */ struct cons_pointer function; /* the function to be called */ @@ -236,11 +268,20 @@ struct cons_payload { }; /** - * Payload of a function cell. - * source points to the source from which the function was compiled, or NIL + * Payload of an exception. + * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. + */ +struct exception_payload { + struct cons_pointer message; + struct stack_frame * frame; +}; + +/** + * Payload of a function cell. + * source points to the source from which the function was compiled, or NIL * if it is a primitive. * executable points to a function which takes a pointer to a stack frame - * (representing its stack frame) and a cons pointer (representing its + * (representing its stack frame) and a cons pointer (representing its * environment) as arguments and returns a cons pointer (representing its * result). */ @@ -277,8 +318,8 @@ struct real_payload { }; /** - * Payload of a special form cell. - * source points to the source from which the function was compiled, or NIL + * Payload of a special form cell. + * source points to the source from which the function was compiled, or NIL * if it is a primitive. * executable points to a function which takes a cons pointer (representing * its argument list) and a cons pointer (representing its environment) and a @@ -318,7 +359,7 @@ struct vectorp_payload { char bytes[TAGLENGTH]; /* the tag (type) of the * vector-space object this cell * points to, considered as bytes. - * NOTE that the vector space object + * NOTE that the vector space object * should itself have the identical * tag. */ uint32_t value; /* the tag considered as a number */ @@ -343,47 +384,51 @@ struct cons_space_object { * this cell */ union { /* - * if tag == CONSTAG + * if tag == CONSTAG */ struct cons_payload cons; /* - * if tag == FREETAG + * if tag == EXCEPTIONTAG + */ + struct exception_payload exception; + /* + * if tag == FREETAG */ struct free_payload free; /* - * if tag == FUNCTIONTAG + * if tag == FUNCTIONTAG */ struct function_payload function; /* - * if tag == INTEGERTAG + * if tag == INTEGERTAG */ struct integer_payload integer; /* - * if tag == NILTAG; we'll treat the special cell NIL as just a cons + * if tag == NILTAG; we'll treat the special cell NIL as just a cons */ struct cons_payload nil; /* - * if tag == READTAG || tag == WRITETAG + * if tag == READTAG || tag == WRITETAG */ struct stream_payload stream; /* - * if tag == REALTAG + * if tag == REALTAG */ struct real_payload real; /* - * if tag == SPECIALTAG + * if tag == SPECIALTAG */ struct special_payload special; /* - * if tag == STRINGTAG || tag == SYMBOLTAG + * if tag == STRINGTAG || tag == SYMBOLTAG */ struct string_payload string; /* - * if tag == TRUETAG; we'll treat the special cell T as just a cons + * if tag == TRUETAG; we'll treat the special cell T as just a cons */ struct cons_payload t; /* - * if tag == VECTORPTAG + * if tag == VECTORPTAG */ struct vectorp_payload vectorp; } payload; @@ -411,6 +456,12 @@ 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); /** * Construct a cell which points to an executable Lisp special form. @@ -430,7 +481,7 @@ struct cons_pointer make_special( struct cons_pointer src, /** * Construct a string from this character and this tail. A string is - * implemented as a flat list of cells each of which has one character and a + * implemented as a flat list of cells each of which has one character and a * pointer to the next; in the last cell the pointer to next is NIL. */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); @@ -441,6 +492,19 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); */ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); +/** + * Construct a cell which points to a stream open for reading. + * @param input the C stream to wrap. + */ +struct cons_pointer make_read_stream( FILE * input); + +/** + * Construct a cell which points to a stream open for writeing. + * @param output the C stream to wrap. + */ +struct cons_pointer make_write_stream( FILE * output); + + /** * Return a lisp string representation of this old skool ASCII string. */ diff --git a/src/init.c b/src/init.c index 6e5f398..83baa73 100644 --- a/src/init.c +++ b/src/init.c @@ -71,9 +71,10 @@ int main( int argc, char *argv[] ) { /* * 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"λ"), LAMBDA ); */ + deep_bind( c_string_to_lisp_symbol( "lambda"), LAMBDA ); /* * primitive function operations diff --git a/src/lispops.c b/src/lispops.c index 047870c..8019744 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -127,9 +127,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { break; case FUNCTIONTV: - /* - * actually, this is apply - */ { struct stack_frame *next = make_stack_frame( frame, args, env ); result = ( *fn_cell.payload.special.executable ) ( next, env ); @@ -384,7 +381,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) { input = pointer2cell( frame->arg[0] ).payload.stream.stream; } - return read( input ); + return read( frame, input ); } @@ -477,7 +474,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { } else if ( nilp( clause_pointer ) ) { done = true; } else { - lisp_throw( c_string_to_lisp_string + result = lisp_throw( c_string_to_lisp_string ( "Arguments to `cond` must be lists" ), frame ); } } @@ -494,8 +491,15 @@ struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { fwprintf( stderr, L"\nERROR: " ); print( stderr, message ); - fwprintf( stderr, - L"\n\nAn exception was thrown and I've no idea what to do now\n" ); + struct cons_pointer result = NIL; - exit( 1 ); + struct cons_space_object cell = pointer2cell( message ); + + if ( cell.tag.value == EXCEPTIONTV) { + result = message; + } else { + result = make_exception( message, frame); + } + + return result; } diff --git a/src/peano.c b/src/peano.c index 8f978b2..43189ea 100644 --- a/src/peano.c +++ b/src/peano.c @@ -142,10 +142,46 @@ lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) { } 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! + numeric_value( frame->arg[1] ) ); + } else { + /* TODO: throw an exception */ + 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. return result; } + +/** + * Divide one number by another. + * @param env the evaluation environment - ignored; + * @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 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 ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) { + result = make_integer( arg0.payload.integer.value / + arg1.payload.integer.value ); + } else if ( numberp(frame->arg[0]) && numberp(frame->arg[1])) { + result = make_real( numeric_value(frame->arg[0]) / numeric_value(frame->arg[1])); + } else { + lisp_throw( c_string_to_lisp_string + ( "Cannot divide: not a number" ), frame ); + } + + return result; +} + + + diff --git a/src/print.c b/src/print.c index 78bc8aa..2eb943e 100644 --- a/src/print.c +++ b/src/print.c @@ -11,7 +11,7 @@ #include #include /* - * wide characters + * wide characters */ #include #include @@ -75,41 +75,48 @@ void print( FILE * output, struct cons_pointer pointer ) { /* * Because tags have values as well as bytes, this if ... else if - * statement can ultimately be replaced by a switch, which will be neater. + * statement can ultimately be replaced by a switch, which will be neater. */ switch ( cell.tag.value ) { - case CONSTV: - print_list( output, pointer ); - break; - case INTEGERTV: - fwprintf( output, L"%ld", cell.payload.integer.value ); - break; - case NILTV: - fwprintf( output, L"nil" ); - break; - case REALTV: - fwprintf( output, L"%Lf", cell.payload.real.value ); - break; - case STRINGTV: - print_string( output, pointer ); - break; - case SYMBOLTV: - print_string_contents( output, pointer ); - break; - 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", - cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], - cell.tag.bytes[2], cell.tag.bytes[3] ); - break; + case CONSTV: + print_list( output, pointer ); + break; + case EXCEPTIONTV: + fwprintf( output, L"\nException: "); + print_string_contents( output, cell.payload.exception.message); + break; + case INTEGERTV: + fwprintf( output, L"%ld", cell.payload.integer.value ); + break; + case LAMBDATV: + fwprintf( output, L"lambda" /* "λ" */); + break; + case NILTV: + fwprintf( output, L"nil" ); + break; + case REALTV: + fwprintf( output, L"%Lf", cell.payload.real.value ); + break; + case STRINGTV: + print_string( output, pointer ); + break; + case SYMBOLTV: + print_string_contents( output, pointer ); + break; + 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", + cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], + cell.tag.bytes[2], cell.tag.bytes[3] ); + break; } } diff --git a/src/read.c b/src/read.c index 43ff99e..eb82c1f 100644 --- a/src/read.c +++ b/src/read.c @@ -20,6 +20,7 @@ #include "consspaceobject.h" #include "integer.h" #include "intern.h" +#include "lispops.h" #include "print.h" #include "read.h" #include "real.h" @@ -31,7 +32,7 @@ */ struct cons_pointer read_number( FILE * input, wint_t initial ); -struct cons_pointer read_list( FILE * input, wint_t initial ); +struct cons_pointer read_list( struct stack_frame *frame, 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 ); @@ -48,7 +49,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( FILE * input, wint_t initial ) { +struct cons_pointer read_continuation(struct stack_frame *frame, FILE * input, wint_t initial ) { struct cons_pointer result = NIL; wint_t c; @@ -57,11 +58,15 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); switch ( c ) { + case EOF: + result = lisp_throw( c_string_to_lisp_string + ( "End of input while reading" ), frame ); + break; case '\'': - result = c_quote( read_continuation( input, fgetwc( input ) ) ); + result = c_quote( read_continuation( frame, input, fgetwc( input ) ) ); break; case '(': - result = read_list( input, fgetwc( input ) ); + result = read_list( frame, input, fgetwc( input ) ); break; case '"': result = read_string( input, fgetwc( input ) ); @@ -75,7 +80,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { } else if ( iswblank( next ) ) { /* dotted pair. TODO: this isn't right, we * really need to backtrack up a level. */ - result = read_continuation( input, fgetwc( input ) ); + result = read_continuation( frame, input, fgetwc( input ) ); } else { read_symbol( input, c ); } @@ -142,14 +147,14 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { * Read a list from this input stream, which no longer contains the opening * left parenthesis. */ -struct cons_pointer read_list( FILE * input, wint_t initial ) { +struct cons_pointer read_list( struct stack_frame *frame, FILE * input, wint_t initial ) { struct cons_pointer result = NIL; if ( initial != ')' ) { fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial ); - struct cons_pointer car = read_continuation( input, initial ); - result = make_cons( car, read_list( input, fgetwc( input ) ) ); + struct cons_pointer car = read_continuation( frame, input, initial ); + result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); } else { fwprintf( stderr, L"End of list detected\n" ); } @@ -231,6 +236,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { /** * Read the next object on this input stream and return a cons_pointer to it. */ -struct cons_pointer read( FILE * input ) { - return read_continuation( input, fgetwc( input ) ); +struct cons_pointer read(struct stack_frame *frame, FILE * input ) { + return read_continuation( frame, input, fgetwc( input ) ); } diff --git a/src/read.h b/src/read.h index 5ed365a..2577ba2 100644 --- a/src/read.h +++ b/src/read.h @@ -14,6 +14,6 @@ /** * read the next object on this input stream and return a cons_pointer to it. */ -struct cons_pointer read( FILE * input ); +struct cons_pointer read(struct stack_frame *frame, FILE * input ); #endif diff --git a/src/repl.c b/src/repl.c index 3891b4c..9df9234 100644 --- a/src/repl.c +++ b/src/repl.c @@ -19,6 +19,54 @@ #include "print.h" #include "stack.h" + +/* TODO: this is subtly wrong. If we were evaluating + * (print (eval (read))) + * then the stack frame for read would have the stack frame for + * eval as parent, and it in turn would have the stack frame for + * print as parent. + */ + +/** + * 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 ); + + frame->arg[0] = stream_pointer; + struct cons_pointer result = lisp_read( frame, oblist); + free_stack_frame( frame ); + + 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 ); + + frame->arg[0] = NIL /* input */; + struct cons_pointer result = lisp_eval( frame, oblist); + free_stack_frame( frame ); + + 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 ); + + frame->arg[0] = value; + frame->arg[1] = NIL /* stream_pointer */; + struct cons_pointer result = lisp_print( frame, oblist); + free_stack_frame( frame ); + + return result; +} + /** * The read/eval/print loop * @param in_stream the stream to read from; @@ -29,23 +77,21 @@ void repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, bool show_prompt ) { - while ( !feof( in_stream ) ) { - if ( show_prompt ) { - fwprintf( out_stream, L"\n:: " ); - } - struct cons_pointer input = read( in_stream ); - fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page, - input.offset ); - print( error_stream, input ); + struct cons_pointer input_stream = make_read_stream(in_stream); + struct cons_pointer output_stream = make_write_stream(out_stream); - struct stack_frame *frame = make_empty_frame( NULL, oblist ); - frame->arg[0] = input; - struct cons_pointer value = lisp_eval( frame, oblist ); - free_stack_frame( frame ); - // print( out_stream, input ); - fwprintf( out_stream, L"\n" ); - fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page, - input.offset ); - print( out_stream, value ); + while ( !feof( pointer2cell(input_stream).payload.stream.stream ) ) { + if ( show_prompt ) { + fwprintf( out_stream, L"\n:: " ); + } + + struct cons_pointer val = repl_eval( repl_read( input_stream)); + + /* suppress the 'end of stream' exception */ + if ( exceptionp(val) && + !feof( pointer2cell( input_stream).payload.stream.stream ) ) + { + repl_print( output_stream, val); + } } } diff --git a/src/stack.c b/src/stack.c index 8c7e64f..90a763a 100644 --- a/src/stack.c +++ b/src/stack.c @@ -84,17 +84,25 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, struct stack_frame *arg_frame = make_empty_frame( previous, env ); arg_frame->arg[0] = cell.payload.cons.car; inc_ref( arg_frame->arg[0] ); - result->arg[i] = lisp_eval( arg_frame, env ); - inc_ref( result->arg[i] ); + struct cons_pointer val = lisp_eval( arg_frame, env ); + if (pointer2cell(val).tag.value == EXCEPTIONTV) { + result->arg[0] = val; + break; + } else { + result->arg[i] = val; + } + inc_ref(val); free_stack_frame( arg_frame ); 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 ); + } return result; } diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh index 3039897..e377c42 100644 --- a/unit-tests/string-allocation.sh +++ b/unit-tests/string-allocation.sh @@ -1,8 +1,8 @@ #!/bin/bash value='"Fred"' -expected="String cell: character 'F'" -echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null +expected="String cell: character 'F' (70)" +echo ${value} | target/psse -d 2>/dev/null | grep "${expected}" > /dev/null if [ $? -eq 0 ] then