diff --git a/.gitignore b/.gitignore index 15477a1..6840d19 100644 --- a/.gitignore +++ b/.gitignore @@ -18,3 +18,13 @@ src/\.#* post-scarcity\.iml doc/ + +log* + +\.cproject + +\.gdb_history + +\.project + +\.settings/language\.settings\.xml diff --git a/Makefile b/Makefile index 207b162..4797c75 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,3 @@ - TARGET ?= target/psse SRC_DIRS ?= ./src @@ -11,9 +10,12 @@ TESTS := $(shell find unit-tests -name *.sh) 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" +INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ +-d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \ +-npsl -nsc -nsob -nss -nut -prs -l79 -ts2 + +VERSION := "0.0.2" CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g LDFLAGS := -lm @@ -25,14 +27,18 @@ doc: $(SRCS) Makefile doxygen format: $(SRCS) $(HDRS) Makefile +ifeq ($(shell uname -s), Darwin) + gindent $(INDENT_FLAGS) $(SRCS) $(HDRS) +else indent $(INDENT_FLAGS) $(SRCS) $(HDRS) +endif test: $(OBJS) $(TESTS) Makefile bash ./unit-tests.sh .PHONY: clean clean: - $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ + $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~ repl: $(TARGET) -p 2> psse.log diff --git a/lisp/defun.lisp b/lisp/defun.lisp new file mode 100644 index 0000000..e86df35 --- /dev/null +++ b/lisp/defun.lisp @@ -0,0 +1,28 @@ +;; Because I don't (yet) have syntax for varargs, the body must be passed +;; to defun as a list of sexprs. +(set! defun! + (nlambda + form + (cond ((symbolp (car form)) + (set (car form) (apply lambda (cdr form)))) + (t nil)))) + +(defun! square (x) (* x x)) + +(set! defsp! + (nlambda + form + (cond (symbolp (car form)) + (set! (car form) (apply nlambda (cdr form)))))) + +(defsp! cube (x) ((* x x x))) + +(set! p 5) + +(square 5) ;; should work + +(square p) ;; should work + +(cube 5) ;; should work + +(cube p) ;; should fail: unbound symbol diff --git a/lisp/fact.lisp b/lisp/fact.lisp new file mode 100644 index 0000000..2f578a6 --- /dev/null +++ b/lisp/fact.lisp @@ -0,0 +1,4 @@ +(set! fact + (lambda (n) + (cond ((= n 1) 1) + (t (* n (fact (- n 1))))))) diff --git a/src/conspage.c b/src/conspage.c index 6e8ee26..ad83680 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; @@ -55,30 +55,35 @@ void make_cons_page( ) { struct cons_space_object *cell = &conspages[initialised_cons_pages]->cell[i]; if ( initialised_cons_pages == 0 && i < 2 ) { - if ( i == 0 ) { - /* - * 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 ) { - /* - * initialise cell as T - */ - strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH ); - cell->count = MAXREFERENCE; - cell->payload.free.car = ( struct cons_pointer ) { - 0, 1}; - cell->payload.free.cdr = ( struct cons_pointer ) { - 0, 1}; - fwprintf( stderr, L"Allocated special cell T\n" ); + switch ( i ) { + case 0: + /* + * 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" ); + break; + case 1: + /* + * initialise cell as T + */ + strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH ); + cell->count = MAXREFERENCE; + cell->payload.free.car = ( struct cons_pointer ) { + 0, 1 + }; + cell->payload.free.cdr = ( struct cons_pointer ) { + 0, 1 + }; + fwprintf( stderr, L"Allocated special cell T\n" ); + break; } } else { /* - * otherwise, standard initialisation + * otherwise, standard initialisation */ strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); cell->payload.free.car = NIL; @@ -107,7 +112,8 @@ void dump_pages( FILE * output ) { for ( int j = 0; j < CONSPAGESIZE; j++ ) { dump_object( output, ( struct cons_pointer ) { - i, j} ); + i, j + } ); } } } @@ -121,9 +127,36 @@ void dump_pages( FILE * output ) { void free_cell( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); + switch ( cell->tag.value ) { + /* for all the types of cons-space object which point to other + * cons-space objects, cascade the decrement. */ + case CONSTV: + dec_ref( cell->payload.cons.car ); + dec_ref( cell->payload.cons.cdr ); + break; + case EXCEPTIONTV: + dec_ref( cell->payload.exception.message ); + break; + case FUNCTIONTV: + dec_ref( cell->payload.function.source ); + break; + case LAMBDATV: + case NLAMBDATV: + dec_ref( cell->payload.lambda.args ); + dec_ref( cell->payload.lambda.body ); + break; + case SPECIALTV: + dec_ref( cell->payload.special.source ); + break; + case STRINGTV: + case SYMBOLTV: + dec_ref( cell->payload.string.cdr ); + break; + } + 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 3569f5d..0fe28e3 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 @@ -61,13 +63,36 @@ void dec_ref( struct cons_pointer pointer ) { } } +void dump_string_cell( FILE * output, wchar_t *prefix, + struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + if ( cell.payload.string.character == 0 ) { + fwprintf( output, + L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", + prefix, + cell.payload.string.cdr.page, cell.payload.string.cdr.offset, + cell.count ); + } else { + fwprintf( output, + L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", + prefix, + ( wint_t ) cell.payload.string.character, + cell.payload.string.character, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset, cell.count ); + fwprintf( output, L"\t\t value: " ); + print( output, pointer ); + fwprintf( output, L"\n" ); + } +} + /** * dump the object at this cons_pointer to this output stream. */ void dump_object( FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); fwprintf( output, - L"\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], @@ -75,49 +100,51 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { cell.tag.value, pointer.page, pointer.offset, cell.count ); switch ( cell.tag.value ) { - case CONSTV: - fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n", - cell.payload.cons.car.page, - cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset, cell.count ); - break; - case 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 REALTV: - fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", - cell.payload.real.value, cell.count ); - break; - case STRINGTV: - fwprintf( output, - L"\t\tString cell: character '%c' (%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" ); - break; - case SYMBOLTV: - fwprintf( output, - L"\t\tSymbol cell: character '%c' (%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" ); - break; + case CONSTV: + fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n", + cell.payload.cons.car.page, + cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); + break; + case EXCEPTIONTV: + fwprintf( output, L"\t\tException cell: " ); + print( output, cell.payload.exception.message ); + fwprintf( output, L"\n" ); + for ( struct stack_frame * frame = cell.payload.exception.frame; + frame != NULL; frame = frame->previous ) { + dump_frame( output, frame ); + } + break; + case FREETV: + fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset ); + break; + case INTEGERTV: + fwprintf( output, + L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); + break; + case LAMBDATV: + fwprintf( output, L"\t\tLambda cell; args: " ); + print( output, cell.payload.lambda.args ); + fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + break; + case READTV: + fwprintf( output, L"\t\tInput stream\n" ); + case REALTV: + fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); + break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; } } @@ -130,8 +157,7 @@ struct cons_pointer make_cons( struct cons_pointer car, pointer = allocate_cell( CONSTAG ); - struct cons_space_object *cell = - &conspages[pointer.page]->cell[pointer.offset]; + struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( car ); inc_ref( cdr ); @@ -141,6 +167,26 @@ 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 ); + + inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ + + inc_ref( message ); + cell->payload.exception.message = message; + cell->payload.exception.frame = frame; + + return pointer; +} + + /** * Construct a cell which points to an executable Lisp special form. */ @@ -156,10 +202,47 @@ make_function( struct cons_pointer src, struct cons_pointer ( *executable ) return pointer; } +/** + * Construct a lambda (interpretable source) cell + */ +struct cons_pointer make_lambda( struct cons_pointer args, + struct cons_pointer body ) { + struct cons_pointer pointer = allocate_cell( LAMBDATAG ); + struct cons_space_object *cell = &pointer2cell( pointer ); + + inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ + + inc_ref( args ); + inc_ref( body ); + cell->payload.lambda.args = args; + cell->payload.lambda.body = body; + + return pointer; +} + +/** + * Construct an nlambda (interpretable source) cell; to a + * 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 pointer = allocate_cell( NLAMBDATAG ); + + inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ + + struct cons_space_object *cell = &pointer2cell( pointer ); + inc_ref( args ); + inc_ref( body ); + cell->payload.lambda.args = args; + cell->payload.lambda.body = body; + + return pointer; +} + /** * 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 +271,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 +279,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 +300,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..ed5cbd1 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -12,7 +12,7 @@ #include #include /* - * wide characters + * wide characters */ #include #include @@ -34,6 +34,13 @@ #define CONSTAG "CONS" #define CONSTV 1397641027 +/** + * An exception. + */ +#define EXCEPTIONTAG "EXEP" +/* TODO: this is wrong */ +#define EXCEPTIONTV 1346721861 + /** * An unallocated cell on the free list - should never be encountered by a Lisp * function. 1162170950 @@ -53,6 +60,12 @@ #define INTEGERTAG "INTR" #define INTEGERTV 1381256777 +/** + * A lambda cell. + */ +#define LAMBDATAG "LMDA" +#define LAMBDATV 1094995276 + /** * The special cons cell at address {0,0} whose car and cdr both point to itself. * 541870414 @@ -60,10 +73,17 @@ #define NILTAG "NIL " #define NILTV 541870414 +/** + * An nlambda cell. + */ +#define NLAMBDATAG "NLMD" +#define NLAMBDATV 1145916494 + /** * An open read stream. */ #define READTAG "READ" +#define READTV 1145128274 /** * A real number. @@ -85,7 +105,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 +126,8 @@ * An open write stream. */ #define WRITETAG "WRIT" +/* TODO: this is wrong */ +#define WRITETV 1414091351 /** * a cons pointer which points to the special NIL cell @@ -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 a 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). */ @@ -268,17 +309,24 @@ struct integer_payload { long int value; }; +/** + * payload for lambda and nlambda cells + */ +struct lambda_payload { + struct cons_pointer args; + struct cons_pointer body; +}; + /** * payload for a real number cell. Internals of this liable to change to give 128 bits * precision, but I'm not sure of the detail. - */ -struct real_payload { + */ struct real_payload { long double value; }; /** - * 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 +366,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 +391,55 @@ 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 == LAMBDATAG or NLAMBDATAG + */ + struct lambda_payload lambda; + /* + * 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 +467,13 @@ 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. @@ -421,6 +484,19 @@ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ) ); /** + * Construct a lambda (interpretable source) cell + */ +struct cons_pointer make_lambda( struct cons_pointer args, + struct cons_pointer body ); + +/** + * Construct an nlambda (interpretable source) cell; to a + * lambda as a special form is to a function. + */ +struct cons_pointer make_nlambda( struct cons_pointer args, + struct cons_pointer body ); + + /** * Construct a cell which points to an executable Lisp special form. */ struct cons_pointer make_special( struct cons_pointer src, @@ -430,7 +506,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 +517,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/equal.c b/src/equal.c index 43e9424..ebb085e 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 ) { @@ -59,50 +59,58 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { struct cons_space_object *cell_b = &pointer2cell( 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 ); - 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 - * practice only the empty string will. - */ - result = - cell_a->payload.string.character == - cell_b->payload.string.character - && ( 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 ) ) ); - 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 ); - + case CONSTV: + case LAMBDATV: + case NLAMBDATV: + result = + equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) + && equal( cell_a->payload.cons.cdr, + cell_b->payload.cons.cdr ); + break; + case STRINGTV: + case SYMBOLTV: /* - * not more different than one part in a million - close enough + * 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. */ - result = fabs( num_a - num_b ) < ( max / 1000000.0 ); - } - break; - default: - result = false; - break; + result = + cell_a->payload.string.character == + cell_b->payload.string.character + && ( 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 ) ) ); + break; + case INTEGERTV: + result = + cell_a->payload.integer.value == + cell_b->payload.integer.value; + break; + 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 ); + } + 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 - * 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/init.c b/src/init.c index 6e5f398..876bdad 100644 --- a/src/init.c +++ b/src/init.c @@ -46,17 +46,20 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; - while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) { + while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) { switch ( option ) { - case 'd': - dump_at_end = true; - break; - case 'p': - show_prompt = true; - break; - default: - fwprintf( stderr, L"Unexpected option %c\n", option ); - break; + case 'c': + print_use_colours = true; + break; + case 'd': + dump_at_end = true; + break; + case 'p': + show_prompt = true; + break; + default: + fwprintf( stderr, L"Unexpected option %c\n", option ); + break; } } @@ -71,7 +74,6 @@ 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 ); @@ -84,30 +86,34 @@ int main( int argc, char *argv[] ) { bind_function( "car", &lisp_car ); bind_function( "cdr", &lisp_cdr ); bind_function( "cons", &lisp_cons ); + bind_function( "divide", &lisp_divide ); bind_function( "eq", &lisp_eq ); bind_function( "equal", &lisp_equal ); bind_function( "eval", &lisp_eval ); bind_function( "multiply", &lisp_multiply ); bind_function( "read", &lisp_read ); + bind_function( "oblist", &lisp_oblist ); bind_function( "print", &lisp_print ); bind_function( "progn", &lisp_progn ); + bind_function( "set", &lisp_set ); bind_function( "subtract", &lisp_subtract ); bind_function( "type", &lisp_type ); bind_function( "+", &lisp_add ); bind_function( "*", &lisp_multiply ); bind_function( "-", &lisp_subtract ); + bind_function( "/", &lisp_divide ); + bind_function( "=", &lisp_equal ); /* * primitive special forms */ bind_special( "cond", &lisp_cond ); + bind_special( "lambda", &lisp_lambda ); + bind_special( "nlambda", &lisp_nlambda ); + bind_special( "progn", &lisp_progn ); 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 ); + bind_special( "set!", &lisp_set_shriek ); repl( stdin, stdout, stderr, show_prompt ); diff --git a/src/integer.c b/src/integer.c index 6352b34..999c803 100644 --- a/src/integer.c +++ b/src/integer.c @@ -21,7 +21,7 @@ * but only integers and reals are so far implemented. */ long double numeric_value( struct cons_pointer pointer ) { - double result = NAN; + long double result = NAN; struct cons_space_object *cell = &pointer2cell( pointer ); if ( integerp( pointer ) ) { diff --git a/src/intern.c b/src/intern.c index 12f9da3..100589a 100644 --- a/src/intern.c +++ b/src/intern.c @@ -4,11 +4,11 @@ * For now this implements an oblist and shallow binding; local environments can * be consed onto the front of the oblist. Later, this won't do; bindings will happen * in namespaces, which will probably be implemented as hash tables. - * + * * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; * so when a symbol is rebound in the master oblist, what in fact we do is construct * a new oblist without the previous binding but with the new binding. Anything which, - * prior to this action, held a pointer to the old oblist (as all current threads' + * prior to this action, held a pointer to the old oblist (as all current threads' * environments must do) continues to hold a pointer to the old oblist, and consequently * doesn't see the change. This is probably good but does mean you cannot use bindings * on the oblist to signal between threads. @@ -26,12 +26,12 @@ #include "print.h" /** - * The object list. What is added to this during system setup is 'global', that is, + * The object list. What is added to this during system setup is 'global', that is, * visible to all sessions/threads. What is added during a session/thread is local to * that session/thread (because shallow binding). There must be some way for a user to * make the contents of their own environment persistent between threads but I don't * know what it is yet. At some stage there must be a way to rebind deep values so - * they're visible to all users/threads, but again I don't yet have any idea how + * 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; @@ -114,8 +114,8 @@ bind( struct cons_pointer key, struct cons_pointer value, } /** - * Binds this key to this value in the global oblist, but doesn't affect the - * current environment. May not be useful except in bootstrapping (and even + * Binds this key to this value in the global oblist, but doesn't affect the + * current environment. May not be useful except in bootstrapping (and even * there it may not be especially useful). */ struct cons_pointer @@ -133,10 +133,9 @@ struct cons_pointer intern( struct cons_pointer key, struct cons_pointer environment ) { struct cons_pointer result = environment; struct cons_pointer canonical = internedp( key, environment ); - if ( nilp( canonical ) ) { /* - * not currently bound + * not currently bound */ result = bind( key, NIL, environment ); } diff --git a/src/lispops.c b/src/lispops.c index 047870c..62338b1 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -63,7 +63,7 @@ struct cons_pointer c_car( struct cons_pointer arg ) { struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer result = NIL; - if ( consp( arg ) ) { + if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) { result = pointer2cell( arg ).payload.cons.cdr; } @@ -91,7 +91,141 @@ struct cons_pointer eval_form( struct stack_frame *parent, next->arg[0] = form; inc_ref( next->arg[0] ); result = lisp_eval( 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 ); + } + + return result; +} + +/** + * 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; +} + +/** + * Return the object list (root namespace). + * + * (oblist) + */ +struct cons_pointer +lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) { + return oblist; +} + + +/** + * 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; + + for ( int i = args_in_frame - 1; i > 0; i-- ) { + if ( !nilp( body ) ) { + body = make_cons( frame->arg[i], body ); + } else if ( !nilp( frame->arg[i] ) ) { + body = make_cons( frame->arg[i], body ); + } + } + + fputws( L"compose_body returning ", stderr ); + print( stderr, body ); + fputws( L"\n", stderr ); + + return body; +} + +/** + * Construct an interpretable function. + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param env the environment in which it is to be intepreted. + */ +struct cons_pointer +lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) { + return make_lambda( frame->arg[0], compose_body( frame ) ); +} + +/** + * Construct an interpretable special form. + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param env the environment in which it is to be intepreted. + */ +struct cons_pointer +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 ) { + struct cons_pointer result = NIL; + fwprintf( stderr, L"eval_lambda called\n" ); + + struct cons_pointer new_env = env; + struct cons_pointer names = cell.payload.lambda.args; + struct cons_pointer body = cell.payload.lambda.body; + + 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 = 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 ) ) { + struct cons_pointer sexpr = c_car( body ); + body = c_cdr( body ); + fputws( L"In lambda: ", stderr ); + result = eval_form( frame, sexpr, new_env ); + } return result; } @@ -107,49 +241,102 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer c_apply( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct stack_frame *fn_frame = make_empty_frame( frame, env ); fn_frame->arg[0] = c_car( frame->arg[0] ); inc_ref( fn_frame->arg[0] ); struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); - free_stack_frame( fn_frame ); + + 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] ); switch ( fn_cell.tag.value ) { - case SPECIALTV: - { - struct stack_frame *next = make_special_frame( frame, args, env ); - result = ( *fn_cell.payload.special.executable ) ( next, env ); - free_stack_frame( next ); - } - 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 ); - free_stack_frame( next ); - } - break; - - default: - { - char *buffer = malloc( 1024 ); - memset( buffer, '\0', 1024 ); - sprintf( buffer, - "Unexpected cell with tag %d (%c%c%c%c) in function position", - fn_cell.tag.value, fn_cell.tag.bytes[0], - fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], - fn_cell.tag.bytes[3] ); - struct cons_pointer message = c_string_to_lisp_string( buffer ); - free( buffer ); - result = lisp_throw( message, frame ); - } + case EXCEPTIONTV: + /* just pass exceptions straight back */ + result = fn_pointer; + break; + case FUNCTIONTV: + { + struct cons_pointer exep = NIL; + struct stack_frame *next = + make_stack_frame( frame, args, env, &exep ); + result = ( *fn_cell.payload.special.executable ) ( next, env ); + if ( exceptionp( exep ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + result = exep; + } else { + free_stack_frame( next ); + } + } + break; + case LAMBDATV: + { + struct cons_pointer exep = NIL; + struct stack_frame *next = + make_stack_frame( frame, args, env, &exep ); + fputws( L"Stack frame for lambda\n", stderr ); + dump_frame( stderr, next ); + result = eval_lambda( fn_cell, next, env ); + if ( exceptionp( result ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + result = exep; + } else { + free_stack_frame( next ); + } + } + break; + case NLAMBDATV: + { + struct stack_frame *next = + make_special_frame( frame, args, env ); + fputws( L"Stack frame for nlambda\n", stderr ); + dump_frame( stderr, next ); + result = eval_lambda( fn_cell, next, env ); + if ( !exceptionp( result ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + free_stack_frame( next ); + } + } + break; + case SPECIALTV: + { + struct stack_frame *next = + make_special_frame( frame, args, env ); + result = ( *fn_cell.payload.special.executable ) ( 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 ); + } + } + break; + default: + { + char *buffer = malloc( 1024 ); + memset( buffer, '\0', 1024 ); + sprintf( buffer, + "Unexpected cell with tag %d (%c%c%c%c) in function position", + fn_cell.tag.value, fn_cell.tag.bytes[0], + fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], + fn_cell.tag.bytes[3] ); + struct cons_pointer message = + c_string_to_lisp_string( buffer ); + free( buffer ); + result = lisp_throw( message, frame ); + } } return result; @@ -196,30 +383,39 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { dump_frame( stderr, frame ); switch ( cell.tag.value ) { - case CONSTV: - result = c_apply( frame, env ); - break; - - case SYMBOLTV: - { - struct cons_pointer canonical = internedp( frame->arg[0], env ); - if ( nilp( canonical ) ) { - struct cons_pointer message = - c_string_to_lisp_string - ( "Attempt to take value of unbound symbol." ); - result = lisp_throw( message, frame ); - } else { - result = c_assoc( canonical, env ); + case CONSTV: + { + result = c_apply( frame, env ); } - } - break; - /* - * the Clojure practice of having a map serve in the function place of - * an s-expression is a good one and I should adopt it; also if the - * object is a consp it could be interpretable source code but in the - * long run I don't want an interpreter, and if I can get away without - * so much the better. - */ + break; + + case SYMBOLTV: + { + struct cons_pointer canonical = + internedp( frame->arg[0], env ); + if ( nilp( canonical ) ) { + struct cons_pointer message = + make_cons( c_string_to_lisp_string + ( "Attempt to take value of unbound symbol." ), + frame->arg[0] ); + result = lisp_throw( message, frame ); + } else { + result = c_assoc( canonical, env ); + inc_ref( result ); + } + } + break; + /* + * TODO: + * the Clojure practice of having a map serve in the function place of + * an s-expression is a good one and I should adopt it; also if the + * object is a consp it could be interpretable source code but in the + * long run I don't want an interpreter, and if I can get away without + * so much the better. + */ + default: + result = frame->arg[0]; + break; } fputws( L"Eval returning ", stderr ); @@ -268,6 +464,67 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) { return frame->arg[0]; } + +/** + * (set name value) + * (set name value namespace) + * + * Function. + * `namespace` defaults to the oblist. + * Binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. `namespace` defaults to the value of `oblist`. + */ +struct cons_pointer +lisp_set( struct stack_frame *frame, struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer namespace = + nilp( frame->arg[2] ) ? oblist : frame->arg[2]; + + if ( symbolp( frame->arg[0] ) ) { + deep_bind( frame->arg[0], frame->arg[1] ); + result = frame->arg[1]; + } else { + result = + make_exception( make_cons + ( c_string_to_lisp_string + ( "The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), frame ); + } + + return result; +} + + +/** + * (set! symbol value) + * (set! symbol value namespace) + * + * Special form. + * `namespace` defaults to the oblist. + * Binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing. `namespace` defaults to the value of `oblist`. + */ +struct cons_pointer +lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer namespace = + nilp( frame->arg[2] ) ? oblist : frame->arg[2]; + + if ( symbolp( frame->arg[0] ) ) { + struct cons_pointer val = eval_form( frame, frame->arg[1], env ); + deep_bind( frame->arg[0], val ); + result = val; + } else { + result = + make_exception( make_cons + ( c_string_to_lisp_string + ( "The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), frame ); + } + + return result; +} + /** * (cons a b) * @@ -384,7 +641,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 ); } @@ -421,7 +678,9 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) { /** - * Function; evaluate the forms which are listed in my single argument + * (progn forms...) + * + * Special form; evaluate the forms which are listed in my arguments * sequentially and return the value of the last. This function is called 'do' * in some dialects of Lisp. * @@ -432,14 +691,17 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) { */ struct cons_pointer lisp_progn( struct stack_frame *frame, struct cons_pointer env ) { - struct cons_pointer remaining = frame->arg[0]; + struct cons_pointer remaining = frame->more; struct cons_pointer result = NIL; - while ( consp( remaining ) ) { - struct cons_space_object cell = pointer2cell( remaining ); - result = eval_form( frame, cell.payload.cons.car, env ); + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { + result = eval_form( frame, frame->arg[i], env ); + } - remaining = cell.payload.cons.cdr; + while ( consp( remaining ) ) { + result = eval_form( frame, c_car( remaining ), env ); + + remaining = c_cdr( remaining ); } return result; @@ -466,19 +728,25 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { if ( consp( clause_pointer ) ) { struct cons_space_object cell = pointer2cell( clause_pointer ); + result = eval_form( frame, c_car( clause_pointer ), env ); + + if ( !nilp( result ) ) { + struct cons_pointer vals = + eval_forms( frame, c_cdr( clause_pointer ), env ); + + while ( consp( vals ) ) { + result = c_car( vals ); + vals = c_cdr( vals ); + } - if ( !nilp( eval_form( frame, cell.payload.cons.car, env ) ) ) { - struct stack_frame *next = make_empty_frame( frame, env ); - next->arg[0] = cell.payload.cons.cdr; - inc_ref( next->arg[0] ); - result = lisp_progn( next, env ); done = true; } } else if ( nilp( clause_pointer ) ) { done = true; } else { - lisp_throw( c_string_to_lisp_string - ( "Arguments to `cond` must be lists" ), frame ); + result = lisp_throw( c_string_to_lisp_string + ( "Arguments to `cond` must be lists" ), + frame ); } } /* TODO: if there are more than 8 clauses we need to continue into the @@ -489,13 +757,25 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { /** * TODO: make this do something sensible somehow. + * This requires that a frame be a heap-space object with a cons-space + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->arg[0] is the message, and frame->arg[1] is the cons-space + * pointer to the frame in which the exception occurred. */ struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { 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/lispops.h b/src/lispops.h index 6fd6e6b..122e149 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -30,18 +30,80 @@ */ 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 + * special forms */ struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer env ); struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer env ); + +struct cons_pointer +lisp_oblist( struct stack_frame *frame, struct cons_pointer env ); + +struct cons_pointer +lisp_set( struct stack_frame *frame, struct cons_pointer env ); + +struct cons_pointer +lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ); + +/** + * Construct an interpretable function. + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param lexpr the lambda expression to be interpreted; + * @param env the environment in which it is to be intepreted. + */ +struct cons_pointer lisp_lambda( struct stack_frame *frame, + struct cons_pointer env ); + +/** + * Construct an interpretable special form. + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param env the environment in which it is to be intepreted. + */ +struct cons_pointer +lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ); + struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer env ); /* - * functions + * functions */ struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer env ); @@ -70,22 +132,22 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ); /** - * Function; evaluate the forms which are listed in my single argument + * Function; evaluate the forms which are listed in my single argument * sequentially and return the value of the last. This function is called 'do' * in some dialects of Lisp. - * + * * @param frame My stack frame. * @param env My environment (ignored). - * @return the value of the last form on the sequence which is my single + * @return the value of the last form on the sequence which is my single * argument. */ struct cons_pointer lisp_progn( struct stack_frame *frame, struct cons_pointer env ); /** - * Special form: conditional. Each arg is expected to be a list; if the first - * item in such a list evaluates to non-NIL, the remaining items in that list - * are evaluated in turn and the value of the last returned. If no arg (clause) + * Special form: conditional. Each arg is expected to be a list; if the first + * item in such a list evaluates to non-NIL, the remaining items in that list + * are evaluated in turn and the value of the last returned. If no arg (clause) * has a first element which evaluates to non NIL, then NIL is returned. * @param frame My stack frame. * @param env My environment (ignored). @@ -95,7 +157,7 @@ struct cons_pointer lisp_cond( struct stack_frame *frame, struct cons_pointer env ); /* - * neither, at this stage, really + * neither, at this stage, really */ struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame *frame ); diff --git a/src/peano.c b/src/peano.c index 8f978b2..691c95f 100644 --- a/src/peano.c +++ b/src/peano.c @@ -25,6 +25,36 @@ #include "real.h" #include "stack.h" +/** + * Internal guts of add. Dark and mysterious. + */ +struct cons_pointer add_accumulate( struct cons_pointer arg, + struct stack_frame *frame, + long int *i_accumulator, + long double *d_accumulator, int *is_int ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case INTEGERTV: + ( *i_accumulator ) += cell.payload.integer.value; + ( *d_accumulator ) += numeric_value( arg ); + break; + case REALTV: + ( *d_accumulator ) += cell.payload.real.value; + ( *is_int ) &= false; + break; + case EXCEPTIONTV: + result = arg; + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), frame ); + } + return result; +} + + /** * Add an indefinite number of numbers together * @param env the evaluation environment - ignored; @@ -36,37 +66,59 @@ 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; + int is_int = true; for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { - struct cons_space_object current = pointer2cell( frame->arg[i] ); - - switch ( current.tag.value ) { - case INTEGERTV: - i_accumulator += current.payload.integer.value; - d_accumulator += numeric_value( frame->arg[i] ); - 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 ( !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 ); - } + result = + add_accumulate( frame->arg[i], frame, &i_accumulator, + &d_accumulator, &is_int ); } + struct cons_pointer more = frame->more; + + while ( consp( more ) ) { + result = + add_accumulate( c_car( more ), frame, &i_accumulator, + &d_accumulator, &is_int ); + more = c_cdr( more ); + } + + if ( is_int ) { + result = make_integer( i_accumulator ); + } else { + result = make_real( d_accumulator ); + } + + return result; +} + +/** + * Internal guts of multiply. Dark and mysterious. + */ +struct cons_pointer multiply_accumulate( struct cons_pointer arg, + struct stack_frame *frame, + long int *i_accumulator, + long double *d_accumulator, + int *is_int ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case INTEGERTV: + ( *i_accumulator ) *= cell.payload.integer.value; + ( *d_accumulator ) *= numeric_value( arg ); + break; + case REALTV: + ( *d_accumulator ) *= cell.payload.real.value; + ( *is_int ) &= false; + break; + case EXCEPTIONTV: + result = arg; + break; + default: + result = lisp_throw( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), frame ); + } return result; } @@ -81,30 +133,26 @@ 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; + int 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] ); + for ( int i = 0; + i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); + i++ ) { + result = + multiply_accumulate( frame->arg[i], frame, &i_accumulator, + &d_accumulator, &is_int ); + } - 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; - break; - default: - lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), frame ); - } + struct cons_pointer more = frame->more; - if ( !nilp( frame->more ) ) { - lisp_throw( c_string_to_lisp_string - ( "Cannot yet multiply more than 8 numbers" ), frame ); - } + while ( consp( more ) && !exceptionp( result ) ) { + result = + multiply_accumulate( c_car( more ), frame, &i_accumulator, + &d_accumulator, &is_int ); + more = c_cdr( more ); + } + if ( !exceptionp( result ) ) { if ( is_int ) { result = make_integer( i_accumulator ); } else { @@ -142,10 +190,48 @@ 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 ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) { + long int i = ( long int ) numeric_value( frame->arg[0] ) / + numeric_value( frame->arg[1] ); + long double r = ( long double ) numeric_value( frame->arg[0] ) / + numeric_value( frame->arg[1] ); + if ( fabsl( ( long double ) i - r ) < 0.0000000001 ) { + result = make_integer( i ); + } else { + result = make_real( r ); + } + } else { + lisp_throw( c_string_to_lisp_string + ( "Cannot divide: not a number" ), frame ); + } + + return result; +} diff --git a/src/peano.h b/src/peano.h index 4650fe0..79735c0 100644 --- a/src/peano.h +++ b/src/peano.h @@ -43,6 +43,15 @@ extern "C" { struct cons_pointer lisp_subtract( struct stack_frame *frame, struct cons_pointer env ); +/** + * 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 ); + #ifdef __cplusplus } #endif diff --git a/src/print.c b/src/print.c index 78bc8aa..42bf8b4 100644 --- a/src/print.c +++ b/src/print.c @@ -9,9 +9,10 @@ #include #include +#include #include /* - * wide characters + * wide characters */ #include #include @@ -21,18 +22,34 @@ #include "integer.h" #include "print.h" +/** + * Whether or not we colorise output. + * TODO: this should be a Lisp symbol binding, not a C variable. + */ +int print_use_colours = 0; + +/** + * print all the characters in the symbol or string indicated by `pointer` + * onto this `output`; if `pointer` does not indicate a string or symbol, + * don't print anything but just return. + */ void print_string_contents( FILE * output, struct cons_pointer pointer ) { - if ( stringp( pointer ) || symbolp( pointer ) ) { + while ( stringp( pointer ) || symbolp( pointer ) ) { struct cons_space_object *cell = &pointer2cell( pointer ); wint_t c = cell->payload.string.character; if ( c != '\0' ) { fputwc( c, output ); } - print_string_contents( output, cell->payload.string.cdr ); + pointer = cell->payload.string.cdr; } } +/** + * print all the characters in the string indicated by `pointer` onto + * the stream at this `output`, prepending and appending double quote + * characters. + */ void print_string( FILE * output, struct cons_pointer pointer ) { fputwc( btowc( '"' ), output ); print_string_contents( output, pointer ); @@ -40,7 +57,9 @@ void print_string( FILE * output, struct cons_pointer pointer ) { } /** - * Print a single list cell (cons cell). + * Print a single list cell (cons cell) indicated by `pointer` to the + * stream indicated by `output`. if `initial_space` is `true`, prepend + * a space character. */ void print_list_contents( FILE * output, struct cons_pointer pointer, @@ -48,68 +67,133 @@ print_list_contents( FILE * output, struct cons_pointer pointer, struct cons_space_object *cell = &pointer2cell( pointer ); switch ( cell->tag.value ) { - case CONSTV: - if ( initial_space ) { - fputwc( btowc( ' ' ), output ); - } - print( output, cell->payload.cons.car ); + case CONSTV: + if ( initial_space ) { + fputwc( btowc( ' ' ), output ); + } + print( output, cell->payload.cons.car ); - print_list_contents( output, cell->payload.cons.cdr, true ); - break; - case NILTV: - break; - default: - fwprintf( output, L" . " ); - print( output, pointer ); + print_list_contents( output, cell->payload.cons.cdr, true ); + break; + case NILTV: + break; + default: + fwprintf( output, L" . " ); + print( output, pointer ); } } void print_list( FILE * output, struct cons_pointer pointer ) { - fputwc( btowc( '(' ), output ); + if ( print_use_colours ) { + fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); + } else { + fputws( L"(", output ); + }; + print_list_contents( output, pointer, false ); - fputwc( btowc( ')' ), output ); + if ( print_use_colours ) { + fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); + } else { + fputws( L")", output ); + } + } +/** + * Print the cons-space object indicated by `pointer` to the stream indicated + * by `output`. + */ void print( FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); + char *buffer; /* * 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"\n%sException: ", + print_use_colours ? "\x1B[31m" : "" ); + print_string_contents( output, cell.payload.exception.message ); + break; + case FUNCTIONTV: + fwprintf( output, L"(Function)" ); + break; + case INTEGERTV: + if ( print_use_colours ) { + fputws( L"\x1B[34m", output ); + } + fwprintf( output, L"%ld%", cell.payload.integer.value ); + break; + case LAMBDATV: + 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 ) ) ); + break; + case READTV: + fwprintf( output, L"(Input stream)" ); + break; + case REALTV: + /* TODO: using the C heap is a bad plan because it will fragment. + * As soon as I have working vector space I'll use a special purpose + * vector space object */ + buffer = ( char * ) malloc( 24 ); + memset( buffer, 0, 24 ); + /* format it really long, then clear the trailing zeros */ + sprintf( buffer, "%-.23Lg", cell.payload.real.value ); + if ( strchr( buffer, '.' ) != NULL ) { + for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) { + buffer[i] = '\0'; + } + } + if ( print_use_colours ) { + fputws( L"\x1B[34m", output ); + } + fwprintf( output, L"%s", buffer ); + free( buffer ); + break; + case STRINGTV: + if ( print_use_colours ) { + fputws( L"\x1B[36m", output ); + } + print_string( output, pointer ); + break; + case SYMBOLTV: + if ( print_use_colours ) { + fputws( L"\x1B[1;33m", output ); + } + print_string_contents( output, pointer ); + break; + case SPECIALTV: + fwprintf( output, L"(Special form)" ); + break; + case TRUETV: + fwprintf( output, L"t" ); + break; + default: + fwprintf( stderr, + L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", + print_use_colours ? "\x1B[31m" : "", + cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], + cell.tag.bytes[2], cell.tag.bytes[3] ); + break; + } + + if ( print_use_colours ) { + fputws( L"\x1B[39m", output ); } } diff --git a/src/print.h b/src/print.h index a3fb4ab..7ee9c80 100644 --- a/src/print.h +++ b/src/print.h @@ -15,5 +15,6 @@ #define __print_h void print( FILE * output, struct cons_pointer pointer ); +extern int print_use_colours; #endif diff --git a/src/read.c b/src/read.c index 43ff99e..3bee19f 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,8 @@ */ 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 +50,8 @@ 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; @@ -56,36 +59,58 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { for ( c = initial; c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); - switch ( c ) { - case '\'': - result = c_quote( read_continuation( input, fgetwc( input ) ) ); - break; - case '(': - result = read_list( input, fgetwc( input ) ); - break; - case '"': - result = read_string( input, fgetwc( input ) ); - break; - default: - if ( c == '.' ) { - wint_t next = fgetwc( input ); - if ( iswdigit( next ) ) { - ungetwc( next, input ); - result = read_number( input, c ); - } 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 ) ); - } else { - read_symbol( input, c ); - } - } else if ( iswdigit( c ) ) { - result = read_number( input, c ); - } else if ( iswprint( c ) ) { - result = read_symbol( input, c ); - } else { - fwprintf( stderr, L"Unrecognised start of input character %c\n", - c ); + if ( feof( input ) ) { + result = + make_exception( c_string_to_lisp_string + ( "End of file while reading" ), frame ); + } else { + switch ( c ) { + case ';': + for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) ); + /* skip all characters from semi-colon to the end of the line */ + break; + case EOF: + result = lisp_throw( c_string_to_lisp_string + ( "End of input while reading" ), frame ); + break; + case '\'': + result = + c_quote( read_continuation + ( frame, input, fgetwc( input ) ) ); + break; + case '(': + result = read_list( frame, input, fgetwc( input ) ); + break; + case '"': + result = read_string( input, fgetwc( input ) ); + break; + case '.': + { + wint_t next = fgetwc( input ); + if ( iswdigit( next ) ) { + ungetwc( next, input ); + result = read_number( input, c ); + } else if ( iswblank( next ) ) { + /* dotted pair. TODO: this isn't right, we + * really need to backtrack up a level. */ + result = + read_continuation( frame, input, fgetwc( input ) ); + } else { + read_symbol( input, c ); + } + } + break; + default: + if ( iswdigit( c ) ) { + result = read_number( input, c ); + } else if ( iswprint( c ) ) { + result = read_symbol( input, c ); + } else { + result = + make_exception( c_string_to_lisp_string + ( "Unrecognised start of input character" ), + frame ); + } } } @@ -101,19 +126,16 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { int places_of_decimals = 0; bool seen_period = false; wint_t c; - fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); - - for ( c = initial; iswdigit( c ) || c == btowc( '.' ); - c = fgetwc( input ) ) { + for ( c = initial; iswdigit( c ) + || c == btowc( '.' ); c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { seen_period = true; } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); - - fwprintf( stderr, L"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++; } @@ -124,11 +146,9 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { * push back the character read which was not a digit */ ungetwc( c, input ); - if ( seen_period ) { 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 { @@ -142,14 +162,16 @@ 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 ) ) ); + fwprintf( stderr, + L"read_list starting '%C' (%d)\n", initial, initial ); + 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" ); } @@ -167,17 +189,17 @@ struct cons_pointer read_list( FILE * input, wint_t initial ) { struct cons_pointer read_string( FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; - switch ( initial ) { - case '\0': - result = make_string( initial, NIL ); - break; - case '"': - result = make_string( '\0', NIL ); - break; - default: - result = make_string( initial, read_string( input, fgetwc( input ) ) ); - break; + case '\0': + result = make_string( initial, NIL ); + break; + case '"': + result = make_string( '\0', NIL ); + break; + default: + result = + make_string( initial, read_string( input, fgetwc( input ) ) ); + break; } return result; @@ -186,51 +208,54 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { struct cons_pointer read_symbol( FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; - switch ( initial ) { - case '\0': - result = make_symbol( initial, NIL ); - break; - case '"': - /* - * THIS IS NOT A GOOD IDEA, but is legal - */ - result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); - break; - case ')': - /* - * unquoted strings may not include right-parenthesis - */ - result = make_symbol( '\0', NIL ); - /* - * push back the character read - */ - ungetwc( initial, input ); - break; - default: - if ( iswprint( initial ) && !iswblank( initial ) ) { + case '\0': + result = make_symbol( initial, NIL ); + break; + case '"': + /* + * THIS IS NOT A GOOD IDEA, but is legal + */ result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); - } else { - result = NIL; + break; + case ')': + /* + * unquoted strings may not include right-parenthesis + */ + result = make_symbol( '\0', NIL ); /* * push back the character read */ ungetwc( initial, input ); - } - break; + break; + default: + if ( iswprint( initial ) + && !iswblank( initial ) ) { + result = + make_symbol( initial, + read_symbol( input, fgetwc( input ) ) ); + } else { + result = NIL; + /* + * push back the character read + */ + ungetwc( initial, input ); + } + break; } fputws( L"Read symbol '", stderr ); print( stderr, result ); fputws( L"'\n", stderr ); - return result; } /** * 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..af7574b 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..40f6300 100644 --- a/src/repl.c +++ b/src/repl.c @@ -19,6 +19,58 @@ #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] = input; + struct cons_pointer result = lisp_eval( frame, oblist ); + + if ( !exceptionp( result ) ) { + 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 +81,30 @@ void repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, bool show_prompt ) { - while ( !feof( in_stream ) ) { + struct cons_pointer input_stream = make_read_stream( in_stream ); + struct cons_pointer output_stream = make_write_stream( out_stream ); + + while ( !feof( pointer2cell( input_stream ).payload.stream.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 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 ); + struct cons_pointer input = repl_read( input_stream ); + + if ( exceptionp( input ) ) { + break; + } else { + + struct cons_pointer val = repl_eval( input ); + + if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) { + /* suppress the 'end of stream' exception */ + if ( !exceptionp( val ) ) { + repl_print( output_stream, val ); + } + } else { + repl_print( output_stream, val ); + } + } } } diff --git a/src/stack.c b/src/stack.c index 8c7e64f..3554f22 100644 --- a/src/stack.c +++ b/src/stack.c @@ -66,10 +66,11 @@ struct stack_frame *make_empty_frame( struct stack_frame *previous, */ struct stack_frame *make_stack_frame( struct stack_frame *previous, struct cons_pointer args, - struct cons_pointer env ) { + struct cons_pointer env, + struct cons_pointer *exception ) { struct stack_frame *result = make_empty_frame( previous, env ); - for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) { + for ( int i = 0; i < args_in_frame && consp( 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 */ @@ -81,21 +82,31 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, * processor to be evaled in parallel; but see notes here: * https://github.com/simon-brooke/post-scarcity/wiki/parallelism */ - struct stack_frame *arg_frame = make_empty_frame( previous, env ); + struct stack_frame *arg_frame = make_empty_frame( result, 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 ( exceptionp( val ) ) { + exception = &val; + break; + } else { + result->arg[i] = val; + } + inc_ref( val ); + free_stack_frame( arg_frame ); args = cell.payload.cons.cdr; } - /* - * 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; } @@ -123,8 +134,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; } @@ -139,7 +152,9 @@ void free_stack_frame( struct stack_frame *frame ) { for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->arg[i] ); } - dec_ref( frame->more ); + if ( !nilp( frame->more ) ) { + dec_ref( frame->more ); + } free( frame ); } @@ -155,13 +170,17 @@ void dump_frame( FILE * output, struct stack_frame *frame ) { for ( int arg = 0; arg < args_in_frame; arg++ ) { struct cons_space_object cell = pointer2cell( frame->arg[arg] ); - fwprintf( output, L"Arg %d:\t%c%c%c%c\t", arg, + fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg, cell.tag.bytes[0], - cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3] ); + cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3], + cell.count ); print( output, frame->arg[arg] ); fputws( L"\n", output ); } + fputws( L"More: \t", output ); + print( output, frame->more ); + fputws( L"\n", output ); } diff --git a/src/stack.h b/src/stack.h index 3a7f0ad..ebb1aa1 100644 --- a/src/stack.h +++ b/src/stack.h @@ -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. * @@ -35,7 +35,8 @@ struct stack_frame *make_empty_frame( struct stack_frame *previous, struct stack_frame *make_stack_frame( struct stack_frame *previous, struct cons_pointer args, - struct cons_pointer env ); + struct cons_pointer env, + struct cons_pointer *exception ); void free_stack_frame( struct stack_frame *frame ); /** @@ -48,7 +49,7 @@ void dump_frame( FILE * output, 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 + * 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; @@ -61,7 +62,7 @@ struct stack_frame *make_special_frame( struct stack_frame *previous, /* * struct stack_frame is defined in consspaceobject.h to break circularity - * TODO: refactor. + * TODO: refactor. */ #endif diff --git a/src/version.h b/src/version.h index d827a52..eb9d34e 100644 --- a/src/version.h +++ b/src/version.h @@ -8,4 +8,4 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#define VERSION "0.0.2" +#define VERSION "0.0.3" diff --git a/unit-tests/add.sh b/unit-tests/add.sh index ba8e635..7bb29c7 100644 --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -11,7 +11,7 @@ else exit 1 fi -expected='5.500000' +expected='5.5' actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/eval-real.sh b/unit-tests/eval-real.sh index 39de72f..8832719 100644 --- a/unit-tests/eval-real.sh +++ b/unit-tests/eval-real.sh @@ -8,10 +8,15 @@ actual=`echo "(eval 5.05)" |\ head -2 |\ tail -1` -if [ "${expected}" = "${actual}" ] +outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc` + + +if [ "${outcome}" = "1" ] then echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" exit 1 fi + + diff --git a/unit-tests/intepreter.sh b/unit-tests/intepreter.sh new file mode 100644 index 0000000..9eb2a06 --- /dev/null +++ b/unit-tests/intepreter.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +expected='6' +actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh new file mode 100644 index 0000000..c1197e0 --- /dev/null +++ b/unit-tests/lambda.sh @@ -0,0 +1,16 @@ +#!/bin/bash + +expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)' +actual=`target/psse 2>/dev/null < /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/multiply.sh b/unit-tests/multiply.sh index b9fd5b1..0675a6f 100644 --- a/unit-tests/multiply.sh +++ b/unit-tests/multiply.sh @@ -11,7 +11,7 @@ else exit 1 fi -expected='7.500000' +expected='7.5' actual=`echo "(multiply 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh index 94c7f40..017646b 100644 --- a/unit-tests/progn.sh +++ b/unit-tests/progn.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(progn '((add 2 3)))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='"foo"' -actual=`echo "(progn '((add 2.5 3) \"foo\"))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh new file mode 100644 index 0000000..a49154b --- /dev/null +++ b/unit-tests/recursion.sh @@ -0,0 +1,21 @@ +#!/bin/bash + +expected='nil3628800' +actual=`target/psse 2>/dev/null <&1 | grep "${expected}" > /dev/null +expected="String cell: character 'F' (70)" +echo ${value} | target/psse -d > ${log} 2>/dev/null +grep "${expected}" ${log} > /dev/null if [ $? -eq 0 ] then echo "OK" + rm ${log} exit 0 else - echo "Expected '${expected}', not found" + echo "Expected '${expected}', not found in ${log}" exit 1 fi diff --git a/unit-tests/varargs.sh b/unit-tests/varargs.sh new file mode 100644 index 0000000..6c31163 --- /dev/null +++ b/unit-tests/varargs.sh @@ -0,0 +1,16 @@ +#!/bin/bash + +expected='(lambda l l)(1 2 3 4 5 6 7 8 9 10)' +actual=`target/psse 2>/dev/null <