diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 0ef8ab1..f9420d6 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -11,6 +11,9 @@ #include #include #include +/* wide characters */ +#include +#include #include "conspage.h" #include "consspaceobject.h" @@ -87,7 +90,7 @@ void dump_object( FILE* output, struct cons_pointer pointer) { } else if ( check_tag(pointer, REALTAG)) { fprintf( output, "\t\tReal cell: value %Lf\n", cell.payload.real.value); } else if ( check_tag( pointer, STRINGTAG)) { - fprintf( output, "\t\tString cell: character '%c' next at page %d offset %d\n", + fwprintf( output, L"\t\tString cell: character '%C' next at page %d offset %d\n", cell.payload.string.character, cell.payload.string.cdr.page, cell.payload.string.cdr.offset); }; @@ -98,7 +101,9 @@ void dump_object( FILE* output, struct cons_pointer pointer) { * Construct a cons cell from this pair of pointers. */ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr) { - struct cons_pointer pointer = allocate_cell( CONSTAG); + struct cons_pointer pointer = NIL; + + pointer = allocate_cell( CONSTAG); struct cons_space_object* cell = &conspages[pointer.page]->cell[pointer.offset]; @@ -109,6 +114,21 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr) return pointer; } + +/** + * Construct a cell which points to an executable Lisp special form. + */ +struct cons_pointer make_function( struct cons_pointer src, + struct cons_pointer (*executable) + (struct stack_frame*, struct cons_pointer)) { + struct cons_pointer pointer = allocate_cell( FUNCTIONTAG); + struct cons_space_object* cell = &pointer2cell(pointer); + + cell->payload.function.source = src; + cell->payload.function.executable = executable; + + return pointer; +} /** * Construct a string from this character (which later will be UTF) and @@ -116,20 +136,83 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr) * has one character and a pointer to the next; in the last cell the * pointer to next is NIL. */ -struct cons_pointer make_string( char c, struct cons_pointer tail) { +struct cons_pointer make_string_like_thing( wint_t c, + struct cons_pointer tail, + char* tag) { struct cons_pointer pointer = NIL; - if ( check_tag( tail, STRINGTAG) || check_tag( tail, NILTAG)) { - pointer = allocate_cell( STRINGTAG); + if ( check_tag( tail, tag) || check_tag( tail, NILTAG)) { + pointer = allocate_cell( tag); struct cons_space_object* cell = &pointer2cell(pointer); inc_ref(tail); - cell->payload.string.character = (uint32_t) c; + cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.offset = tail.offset; } else { - fprintf( stderr, "Warning: only NIL and STRING can be appended to STRING\n"); + fprintf( stderr, "Warning: only NIL and %s can be appended to %s\n", + tag, tag); } return pointer; } + +/** + * 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 + * pointer to next is NIL. + */ +struct cons_pointer make_string( wint_t c, struct cons_pointer tail) { + return make_string_like_thing( c, tail, STRINGTAG); +} + +/** + * 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); +} + +/** + * Construct a cell which points to an executable Lisp special form. + */ +struct cons_pointer make_special( struct cons_pointer src, + struct cons_pointer (*executable) + (struct cons_pointer s_expr, + struct cons_pointer env, + struct stack_frame* frame)) { + struct cons_pointer pointer = allocate_cell( SPECIALTAG); + struct cons_space_object* cell = &pointer2cell(pointer); + + cell->payload.special.source = src; + cell->payload.special.executable = executable; + + return pointer; +} + +/** + * Return a lisp string representation of this old skool ASCII string. + */ +struct cons_pointer c_string_to_lisp_string( char* string) { + struct cons_pointer result = NIL; + + for ( int i = strlen( string); i > 0; i--) { + result = make_string( (wint_t)string[ i - 1], result); + } + + return result; +} + +/** + * Return a lisp symbol representation of this old skool ASCII string. + */ +struct cons_pointer c_string_to_lisp_symbol( char* symbol) { + struct cons_pointer result = NIL; + + for ( int i = strlen( symbol); i > 0; i--) { + result = make_symbol( (wint_t)symbol[ i - 1], result); + } + + return result; +} diff --git a/src/consspaceobject.h b/src/consspaceobject.h index 5526e8c..4729061 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -8,8 +8,12 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include +/* wide characters */ +#include +#include #ifndef __consspaceobject_h #define __consspaceobject_h @@ -22,22 +26,94 @@ /** * tag values, all of which must be 4 bytes. Must not collide with vector space tag values */ -#define CONSTAG "CONS" -#define FREETAG "FREE" +/** + * An ordinary cons cell: 1397641027 + */ +#define CONSTAG "CONS" +#define CONSTV 1397641027 + +/** + * An unallocated cell on the free list - should never be encountered by a Lisp + * function. 1162170950 + */ +#define FREETAG "FREE" +#define FREETV 1162170950 + +/** + * An ordinary Lisp function - one whose arguments are pre-evaluated and passed as + * a stack frame. 1129207110 + */ +#define FUNCTIONTAG "FUNC" +#define FUNCTIONTV 1129207110 +/** + * An integer number. 1381256777 + */ #define INTEGERTAG "INTR" -#define NILTAG "NIL " -#define READTAG "READ" -#define REALTAG "REAL" -#define STRINGTAG "STRG" -#define TRUETAG "TRUE" +#define INTEGERTV 1381256777 + +/** + * The special cons cell at address {0,0} whose car and cdr both point to itself. + * 541870414 + */ +#define NILTAG "NIL " +#define NILTV 541870414 + +/** + * An open read stream. + */ +#define READTAG "READ" + +/** + * A real number. + */ +#define REALTAG "REAL" + +/** + * A special form - one whose arguments are not pre-evaluated but passed as a + * s-expression. 1296453715 + */ +#define SPECIALTAG "SPFM" +#define SPECIALTV 1296453715 + +/** + * A string of characters, organised as a linked list. 1196577875 + */ +#define STRINGTAG "STRG" +#define STRINGTV 1196577875 + +/** + * A symbol is just like a string except not self-evaluating. 1112365395 + */ +#define SYMBOLTAG "SYMB" +#define SYMBOLTV 1112365395 + +/** + * The special cons cell at address {0,1} which is canonically different from NIL. + * 1163219540 + */ +#define TRUETAG "TRUE" +#define TRUETV 1163219540 + +/** + * A pointer to an object in vector space. + */ #define VECTORPOINTTAG "VECP" -#define WRITETAG "WRIT" + +/** + * An open write stream. + */ +#define WRITETAG "WRIT" /** * a cons pointer which points to the special NIL cell */ #define NIL (struct cons_pointer){ 0, 0} +/** + * a cons pointer which points to the special T cell + */ +#define TRUE (struct cons_pointer){ 0, 1} + /** * the maximum possible value of a reference count */ @@ -52,6 +128,7 @@ /** * 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)) @@ -60,11 +137,65 @@ */ #define consp(conspoint) (check_tag(conspoint,CONSTAG)) +/** + * 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 + */ +#define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) + /** * true if conspointer points to a string cell, else false */ #define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) +/** + * true if conspointer points to a string cell, else false + */ +#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) + +/** + * 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 + */ +#define readp(conspoint) (check_tag(conspoint,READTAG)) + +/** + * 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, + * else false + */ +#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG)) + +/** + * true if conspointer points to a write stream cell, else false. + */ +#define writep(conspoint) (check_tag(conspoint,WRITETAG)) + +/** + * 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. + */ +#define tp(conspoint) (checktag(conspoint,TRUETAG)) + +/** + * true if conspoint points to something that is truthy, i.e. + * anything but NIL. + */ +#define truep(conspoint) (!checktag(conspoint,NILTAG)) + /** * An indirect pointer to a cons cell */ @@ -73,6 +204,21 @@ struct cons_pointer { uint32_t offset; /* the index of the cell within the page */ }; +/* number of arguments stored in a stack frame */ +#define args_in_frame 8 + +/** + * A stack frame. Yes, I know it isn't a cons-space object, but it's defined + * here to avoid circularity. TODO: refactor. + */ +struct stack_frame { + struct stack_frame* previous; /* the previous frame */ + struct cons_pointer arg[args_in_frame]; + /* first 8 arument bindings */ + struct cons_pointer more; /* list of any further argument + * bindings */ + struct cons_pointer function; /* the function to be called */ +}; /** * payload of a cons cell. @@ -82,6 +228,20 @@ struct cons_payload { struct cons_pointer cdr; }; +/** + * 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 + * environment) as arguments and returns a cons pointer (representing its + * result). + */ +struct function_payload { + struct cons_pointer source; + struct cons_pointer (*executable)(struct stack_frame*, struct cons_pointer); +}; + /** * payload of a free cell. For the time being identical to a cons cell, * but it may not be so in future. @@ -100,7 +260,6 @@ struct integer_payload { long int value; }; - /** * 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. @@ -110,14 +269,57 @@ struct real_payload { }; /** - * payload of a string cell. At least at first, only one UTF character will be stored in each cell. + * 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 + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). + * + * NOTE that this means that special forms do not appear on the lisp stack, + * which may be confusing. TODO: think about this. + */ +struct special_payload { + struct cons_pointer source; + struct cons_pointer (*executable)(struct cons_pointer s_expr, + struct cons_pointer env, + struct stack_frame* frame); +}; + +/** + * payload of a read or write stream cell. + */ +struct stream_payload { + FILE * stream; +}; + +/** + * payload of a string cell. At least at first, only one UTF character will + * be stored in each cell. The doctrine that 'a symbol is just a string' + * didn't work; however, the payload of a symbol cell is identical to the + * payload of a string cell. */ struct string_payload { - uint32_t character; /* the actual character stored in this cell */ + wint_t character; /* the actual character stored in this cell */ uint32_t padding; /* unused padding to word-align the cdr */ struct cons_pointer cdr; }; +struct vectorp_payload { + union { + char bytes[TAGLENGTH]; /* the tag (type) of the vector-space + * object this cell points to, considered + * as bytes. NOTE that the vector space + * object should itself have the identical tag. */ + uint32_t value; /* the tag considered as a number */ + } tag; + uint64_t address; /* the address of the actual vector space + * object (TODO: will change when I actually + * implement vector space) */ +}; + + /** * an object in cons space. */ @@ -133,16 +335,24 @@ struct cons_space_object { struct cons_payload cons; /* if tag == FREETAG */ struct free_payload free; + /* if tag == FUNCTIONTAG */ + struct function_payload function; /* if tag == INTEGERTAG */ struct integer_payload integer; /* if tag == NILTAG; we'll treat the special cell NIL as just a cons */ struct cons_payload nil; + /* if tag == READTAG || tag == WRITETAG */ + struct stream_payload stream; /* if tag == REALTAG */ struct real_payload real; - /* if tag == STRINGTAG */ + /* if tag == SPECIALTAG */ + struct special_payload special; + /* if tag == STRINGTAG || tag == SYMBOLTAG */ struct string_payload string; /* if tag == TRUETAG; we'll treat the special cell T as just a cons */ struct cons_payload t; + /* if tag == VECTORPTAG */ + struct vectorp_payload vectorp; } payload; }; @@ -173,11 +383,42 @@ void dump_object( FILE* output, struct cons_pointer pointer); struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr); /** - * 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 - * pointer to next is NIL. + * Construct a cell which points to an executable Lisp special form. */ -struct cons_pointer make_string( char c, struct cons_pointer tail); +struct cons_pointer make_function( struct cons_pointer src, + struct cons_pointer (*executable) + (struct stack_frame*, struct cons_pointer)); + +/** + * Construct a cell which points to an executable Lisp special form. + */ +struct cons_pointer make_special( struct cons_pointer src, + struct cons_pointer (*executable) + (struct cons_pointer s_expr, + struct cons_pointer env, + struct stack_frame* frame)); + +/** + * 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 pointer to next is NIL. + */ +struct cons_pointer make_string( wint_t c, struct cons_pointer tail); + +/** + * Construct a symbol from this character and this tail. A symbol is identical + * to a string except for having a different tag. + */ +struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail); + +/** + * Return a lisp string representation of this old skool ASCII string. + */ +struct cons_pointer c_string_to_lisp_string( char* string); + +/** + * Return a lisp symbol representation of this old skool ASCII string. + */ +struct cons_pointer c_string_to_lisp_symbol( char* symbol); #endif diff --git a/src/equal.c b/src/equal.c new file mode 100644 index 0000000..3b5cc6b --- /dev/null +++ b/src/equal.c @@ -0,0 +1,62 @@ +/** + * equal.c + * + * Checks for shallow and deep equality + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "integer.h" + +/** + * 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) { + return ((a.page == b.page) && (a.offset == b.offset)); +} + + +/** + * Deep, and thus expensive, equality: true if these two objects have + * identical structure, else false. + */ +bool equal( struct cons_pointer a, struct cons_pointer b) { + bool result = eq( a, b); + + if ( ! result) { + struct cons_space_object* cell_a = &pointer2cell( a); + struct cons_space_object* cell_b = &pointer2cell( b); + + if ( consp( a) && consp( b)) { + result = equal( cell_a->payload.cons.car, cell_b->payload.cons.car) && + equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr); + } else if ( stringp( a) && stringp( b)) { + /* 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); + } else if ( numberp( a) && numberp( b)) { + double num_a = numeric_value( a); + double num_b = numeric_value( b); + double max = fabs( num_a) > fabs( num_b) ? fabs( num_a) : fabs( num_b); + + /* not more different than one part in a million - close enough */ + result = fabs( num_a - num_b) < (max / 1000000.0); + } + /* 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 indeedmay never). I'm not certain + * what equality means for read and write streams, so I'll ignore them, too, + * for now.*/ + } + + return result; +} diff --git a/src/equal.h b/src/equal.h new file mode 100644 index 0000000..2c4a86d --- /dev/null +++ b/src/equal.h @@ -0,0 +1,30 @@ +/** + * equal.h + * + * Checks for shallow and deep equality + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include + +#include "consspaceobject.h" + +#ifndef __equal_h +#define __equal_h + +/** + * 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); + +/** + * Deep, and thus expensive, equality: true if these two objects have + * identical structure, else false. + */ +bool equal( struct cons_pointer a, struct cons_pointer b); + +#endif diff --git a/src/init.c b/src/init.c index 63b8558..1cee833 100644 --- a/src/init.c +++ b/src/init.c @@ -1,8 +1,8 @@ /** * init.c * - * Start up and initialise the environement - just enough to get working and (ultimately) - * hand off to the executive. + * Start up and initialise the environement - just enough to get working + * and (ultimately) hand off to the executive. * * * (c) 2017 Simon Brooke @@ -14,17 +14,53 @@ #include "version.h" #include "conspage.h" #include "consspaceobject.h" +#include "intern.h" +#include "lispops.h" #include "print.h" #include "read.h" +void bind_function( char* name, struct cons_pointer (*executable) + (struct stack_frame*, struct cons_pointer)) { + deep_bind( intern( c_string_to_lisp_symbol( name), oblist ), + make_function( NIL, executable)); +} + +void bind_special( char* name, struct cons_pointer (*executable) + (struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame* frame)) { + deep_bind( intern( c_string_to_lisp_symbol( name), oblist ), + make_special( NIL, executable)); +} + int main (int argc, char *argv[]) { fprintf( stderr, "Post scarcity software environment version %s\n", VERSION); initialise_cons_pages(); + /* privileged variables (keywords) */ + deep_bind( intern( c_string_to_lisp_string( "nil"), oblist), NIL); + deep_bind( intern( c_string_to_lisp_string( "t"), oblist), TRUE); + + /* primitive function operations */ + bind_function( "assoc", &lisp_assoc); + bind_function( "car", &lisp_car); + bind_function( "cdr", &lisp_cdr); + bind_function( "cons", &lisp_cons); + bind_function( "eq", &lisp_eq); + bind_function( "equal", &lisp_equal); + bind_function( "read", &lisp_read); + bind_function( "print", &lisp_print); + + /* primitive special forms */ + bind_special( "apply", &lisp_apply); + bind_special( "eval", &lisp_eval); + bind_special( "quote", &lisp_quote); + fprintf( stderr, "\n:: "); struct cons_pointer input = read( stdin); - fprintf( stderr, "\n{%d,%d}=> ", input.page, input.offset); + fprintf( stderr, "\nread {%d,%d}=> ", input.page, input.offset); print( stdout, input); + fprintf( stderr, "\neval {%d,%d}=> ", input.page, input.offset); + // print( stdout, lisp_eval( input, oblist, NULL)); dump_pages(stderr); diff --git a/src/integer.c b/src/integer.c index 1493c9d..8f7b044 100644 --- a/src/integer.c +++ b/src/integer.c @@ -7,10 +7,32 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#define _GNU_SOURCE +#include + #include "conspage.h" #include "consspaceobject.h" #include "read.h" +/** + * return the numeric value of this cell, as a C primitive double, not + * as a cons-space object. Cell may in principle be any kind of number, + * but only integers and reals are so far implemented. + */ +double numeric_value( struct cons_pointer pointer) { + double result = NAN; + struct cons_space_object* cell = &pointer2cell(pointer); + + if ( integerp( pointer)) { + result = (double) cell->payload.integer.value; + } else if ( realp( pointer)) { + result = cell->payload.real.value; + } + + return result; +} + + /** * Allocate an integer cell representing this value and return a cons pointer to it. */ diff --git a/src/integer.h b/src/integer.h index 83f4f57..5d1df67 100644 --- a/src/integer.h +++ b/src/integer.h @@ -11,6 +11,8 @@ #ifndef __integer_h #define __integer_h +double numeric_value( struct cons_pointer pointer); + /** * Allocate an integer cell representing this value and return a cons pointer to it. */ diff --git a/src/intern.c b/src/intern.c new file mode 100644 index 0000000..3cc9379 --- /dev/null +++ b/src/intern.c @@ -0,0 +1,127 @@ +/** + * intern.c + * + * 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' + * 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. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "equal.h" +#include "conspage.h" +#include "consspaceobject.h" + +/** + * 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 + * that will work. + */ +struct cons_pointer oblist = NIL; + +/** + * Implementation of interned? in C. The final implementation if interned? will + * deal with stores which can be association lists or hashtables or hybrids of + * the two, but that will almost certainly be implemented in lisp. + * + * If this key is lexically identical to a key in this store, return the key + * from the store (so that later when we want to retrieve a value, an eq test + * will work); otherwise return NIL. + */ +struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer store) { + struct cons_pointer result = NIL; + + for ( struct cons_pointer next = store; + nilp( result) && consp( next); + next = pointer2cell( next).payload.cons.cdr) { + struct cons_space_object entry = + pointer2cell( pointer2cell( next).payload.cons.car); + + if ( equal( key, entry.payload.cons.car)) { + result = entry.payload.cons.car; + } + } + + return result; +} + +/** + * Implementation of assoc in C. Like interned?, the final implementation will + * deal with stores which can be association lists or hashtables or hybrids of + * the two, but that will almost certainly be implemented in lisp. + * + * If this key is lexically identical to a key in this store, return the value + * of that key from the store; otherwise return NIL. + */ +struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store) { + struct cons_pointer result = NIL; + + for ( struct cons_pointer next = store; + consp( next); + next = pointer2cell( next).payload.cons.cdr) { + struct cons_space_object entry = + pointer2cell( pointer2cell( next).payload.cons.car); + + if ( equal( key, entry.payload.cons.car)) { + result = entry.payload.cons.cdr; + break; + } + } + + return result; +} + + +/** + * Return a new key/value store containing all the key/value pairs in this store + * with this key/value pair added to the front. + */ +struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store) { + return make_cons( make_cons( key, value), store); +} + + +/** + * 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 deep_bind( struct cons_pointer key, struct cons_pointer value) { + oblist = bind( key, value, oblist); + return oblist; +} + + +/** + * Ensure that a canonical copy of this key is bound in this environment, and + * return that canonical copy. If there is currently no such binding, create one + * with the value NIL. + */ +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 */ + result = bind( key, NIL, environment); + } + + return result; +} diff --git a/src/intern.h b/src/intern.h new file mode 100644 index 0000000..56adb33 --- /dev/null +++ b/src/intern.h @@ -0,0 +1,62 @@ +/** + * intern.h + * + * 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' + * 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. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + + +#ifndef __intern_h +#define __intern_h + +extern struct cons_pointer oblist; + +/** + * return the value associated with this key in this store. In the current + * implementation a store is just an assoc list, but in future it might be a + * namespace, a regularity or a homogeneity. + */ +struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store); + +/** + * Return true if this key is present as a key in this enviroment, defaulting to + * the oblist if no environment is passed. + */ +struct cons_pointer internedp( struct cons_pointer key, + struct cons_pointer environment); + +/** + * Return a new key/value store containing all the key/value pairs in this store + * with this key/value pair added to the front. + */ +struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store); + +/** + * 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 deep_bind( struct cons_pointer key, struct cons_pointer value); + +/** + * Ensure that a canonical copy of this key is bound in this environment, and + * return that canonical copy. If there is currently no such binding, create one + * with the value NIL. + */ +struct cons_pointer intern( struct cons_pointer key, + struct cons_pointer environment); + +#endif diff --git a/src/lispops.c b/src/lispops.c new file mode 100644 index 0000000..d85d9ac --- /dev/null +++ b/src/lispops.c @@ -0,0 +1,340 @@ +/** + * lispops.c + * + * List processing operations. + * + * The general idea here is that a list processing operation is a + * function which takes two arguments, both cons_pointers: + * + * 1. args, the argument list to this function; + * 2. env, the environment in which this function should be evaluated; + * + * and returns a cons_pointer, the result. + * + * They must all have the same signature so that I can call them as + * function pointers. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "equal.h" +#include "integer.h" +#include "intern.h" +#include "lispops.h" +#include "print.h" +#include "read.h" +#include "stack.h" + +/* + * also to create in this section: + * struct cons_pointer lisp_cond( struct cons_pointer args, struct cons_pointer env, + struct stack_frame* frame); + * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, + struct stack_frame* frame); + * struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env, + struct stack_frame* frame); + * + * and others I haven't thought of yet. + */ + +/** + * 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) { + struct cons_pointer result = NIL; + + if ( consp(arg)) { + result = pointer2cell( arg).payload.cons.car; + } + + return result; +} + +/** + * 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) { + struct cons_pointer result = NIL; + + if ( consp(arg)) { + result = pointer2cell( arg).payload.cons.cdr; + } + + return result; +} + +/** + * (apply fn args...) + * + * I'm now confused about whether at this stage I actually need an apply special form, + * and if so how it differs from eval. + */ +struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env, + struct stack_frame* frame) { + struct cons_pointer result = args; + + if ( consp( args)) { + lisp_eval( args, env, frame); + } + + return result; +} + +struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame* my_frame) { + struct cons_pointer result = NIL; + struct cons_pointer fn_pointer = lisp_eval( c_car( s_expr), env, my_frame); + struct cons_space_object fn_cell = pointer2cell( fn_pointer); + struct cons_pointer args = c_cdr( s_expr); + + switch ( fn_cell.tag.value) { + case SPECIALTV : + { + struct cons_space_object special = pointer2cell( fn_pointer); + result = (*special.payload.special.executable)( args, env, my_frame); + } + break; + + case FUNCTIONTV : + /* actually, this is apply */ + { + struct cons_space_object function = pointer2cell( fn_pointer); + struct stack_frame* frame = make_stack_frame( my_frame, args, env); + + /* the trick: pass the remaining arguments and environment to + the executable code which is the payload of the function + object. */ + result = (*function.payload.function.executable)( frame, env); + free_stack_frame( frame); + } + 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, my_frame); + } + } + + return result; +} + +/** + * (eval s_expr) + * + * Special form. + * If s_expr is a number, NIL, or T, returns s_expr. + * If s_expr is an unprotected string, returns the value that s_expr is bound + * to in the evaluation environment (env). + * If s_expr is a list, expects the car to be something that evaluates to a + * function or special form. + * If a function, evaluates all the other top level elements in s_expr and + * passes them in a stack frame as arguments to the function. + * If a special form, passes the cdr of s_expr to the special form as argument. + */ +struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame* previous) { + struct cons_pointer result = s_expr; + struct cons_space_object cell = pointer2cell( s_expr); + struct stack_frame* my_frame = + make_stack_frame( previous, make_cons( s_expr, NIL), env); + + switch ( cell.tag.value) { + case CONSTV : + result = eval_cons( s_expr, env, my_frame); + break; + + case SYMBOLTV : + { + struct cons_pointer canonical = internedp( s_expr, env); + if ( nilp( canonical)) { + struct cons_pointer message = + c_string_to_lisp_string( "Attempt to take value of unbound symbol."); + result = lisp_throw( message, my_frame); + } else { + result = c_assoc( canonical, 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. */ + } + + free_stack_frame( my_frame); + + return result; +} + +/** + * (quote a) + * + * Special form + * Returns its argument (strictly first argument - only one is expected but + * this isn't at this stage checked) unevaluated. + */ +struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env, + struct stack_frame* frame) { + return c_car( args); +} + +/** + * (cons a b) + * + * Function. + * Returns a cell constructed from a and b. If a is of type string but its + * cdr is nill, and b is of type string, then returns a new string cell; + * otherwise returns a new cons cell. + */ +struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env) { + struct cons_pointer car = frame->arg[0]; + struct cons_pointer cdr = frame->arg[1]; + struct cons_pointer result; + + if ( nilp( car) && nilp( cdr)) { + return NIL; + } else if ( stringp( car) && stringp( cdr) && + nilp( pointer2cell( car).payload.string.cdr)) { + result = make_string( pointer2cell( car).payload.string.character, cdr); + } else { + result = make_cons( car, cdr); + } + + return result; +} + +/** + * (car s_expr) + * Returns the first item (head) of a sequence. Valid for cons cells, + * strings, and TODO read streams and other things which can be considered as sequences. + */ +struct cons_pointer lisp_car(struct stack_frame* frame, struct cons_pointer env) { + struct cons_pointer result = NIL; + + if ( consp( frame->arg[ 0])) { + struct cons_space_object cell = pointer2cell( frame->arg[ 0]); + result = cell.payload.cons.car; + } else if ( stringp( frame->arg[ 0])) { + struct cons_space_object cell = pointer2cell( frame->arg[ 0]); + result = make_string( cell.payload.string.character, NIL); + } else { + struct cons_pointer message = + c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence"); + result = lisp_throw( message, frame); + } + + return result; +} + + +/** + * (cdr s_expr) + * Returns the remainder of a sequence when the head is removed. Valid for cons cells, + * strings, and TODO read streams and other things which can be considered as sequences. + */ +struct cons_pointer lisp_cdr(struct stack_frame* frame, struct cons_pointer env) { + struct cons_pointer result = NIL; + + if ( consp( frame->arg[ 0])) { + struct cons_space_object cell = pointer2cell( frame->arg[ 0]); + result = cell.payload.cons.car; + } else if ( stringp( frame->arg[ 0])) { + struct cons_space_object cell = pointer2cell( frame->arg[ 0]); + result = cell.payload.string.cdr; + } else { + struct cons_pointer message = + c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence"); + result = lisp_throw( message, frame); + } + + return result; +} + +/** + * (assoc key store) + * Returns the value associated with key in store, or NIL if not found. + */ +struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env) { + return c_assoc( frame->arg[ 0], frame->arg[ 1]); +} + +/** + * (eq a b) + * Returns T if a and b are pointers to the same object, else NIL + */ +struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env) { + return eq( frame->arg[ 0], frame->arg[ 1]) ? TRUE : NIL; +} + +/** + * (eq a b) + * Returns T if a and b are pointers to structurally identical objects, else NIL + */ +struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env) { + return equal( frame->arg[ 0], frame->arg[ 1]) ? TRUE : NIL; +} + +/** + * (read) + * (read read-stream) + * Read one complete lisp form and return it. If read-stream is specified and + * is a read stream, then read from that stream, else stdin. + */ +struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env) { + FILE* input = stdin; + + if ( readp( frame->arg[0])) { + input = pointer2cell( frame->arg[0]).payload.stream.stream; + } + + return read( input); +} + +/** + * (print expr) + * (print expr write-stream) + * Print one complete lisp form and return NIL. If write-stream is specified and + * is a write stream, then print to that stream, else stdout. + */ +struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env) { + FILE* output = stdout; + + if ( writep( frame->arg[1])) { + output = pointer2cell( frame->arg[1]).payload.stream.stream; + } + + print( output, frame->arg[0]); + + return NIL; +} + + +/** + * TODO: make this do something sensible somehow. + */ +struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame) { + fprintf( stderr, "\nERROR: "); + print( stderr, message); + fprintf( stderr, "\n\nAn exception was thrown and I've no idea what to do now\n"); + + exit( 1); +} + diff --git a/src/lispops.h b/src/lispops.h new file mode 100644 index 0000000..597d67f --- /dev/null +++ b/src/lispops.h @@ -0,0 +1,41 @@ +/** + * lispops.h + * + * List processing operations. + * + * The general idea here is that a list processing operation is a + * function which takes two arguments, both cons_pointers: + * + * 1. args, the argument list to this function; + * 2. env, the environment in which this function should be evaluated; + * + * and returns a cons_pointer, the result. + * + * They must all have the same signature so that I can call them as + * function pointers. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +/* special forms */ +struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env, + struct stack_frame* frame); +struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env, + struct stack_frame* frame); +struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env, + struct stack_frame* frame); + +/* functions */ +struct cons_pointer lisp_cons( struct stack_frame* frame, struct cons_pointer env); +struct cons_pointer lisp_car( struct stack_frame* frame, struct cons_pointer env); +struct cons_pointer lisp_cdr( struct stack_frame* frame, struct cons_pointer env); +struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env); +struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env); +struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env); +struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env); +struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env); + +/* neither, at this stage, really */ +struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame); diff --git a/src/print.c b/src/print.c index be6cac8..36e0fa9 100644 --- a/src/print.c +++ b/src/print.c @@ -11,6 +11,9 @@ #include #include #include +/* wide characters */ +#include +#include #include "conspage.h" #include "consspaceobject.h" @@ -18,12 +21,12 @@ #include "print.h" void print_string_contents( FILE* output, struct cons_pointer pointer) { - if ( check_tag( pointer, STRINGTAG)) { + if ( stringp( pointer) || symbolp( pointer)) { struct cons_space_object* cell = &pointer2cell(pointer); - char c = cell->payload.string.character; + wint_t c = cell->payload.string.character; if ( c != '\0') { - fputc( c, output); + fputwc( c, output); } print_string_contents( output, cell->payload.string.cdr); } @@ -36,41 +39,65 @@ void print_string( FILE* output, struct cons_pointer pointer) { fputc( '"', output); } +/** + * Print a single list cell (cons cell). TODO: does not handle dotted pairs. + */ +void print_list_contents( FILE* output, struct cons_pointer pointer, + bool initial_space) { + struct cons_space_object* cell = &pointer2cell(pointer); -void print_list_contents( FILE* output, struct cons_pointer pointer) { - if ( check_tag( pointer, CONSTAG)) { - struct cons_space_object* cell = &pointer2cell(pointer); - + switch ( cell->tag.value) { + case CONSTV : + if (initial_space) { + fputc( ' ', output); + } print( output, cell->payload.cons.car); - if ( !nilp( cell->payload.cons.cdr)) { - fputc( ' ', output); - } - print_list_contents( output, cell->payload.cons.cdr); + print_list_contents( output, cell->payload.cons.cdr, true); + break; + case NILTV: + break; + default: + fprintf( output, " . "); + print( output, pointer); } } void print_list( FILE* output, struct cons_pointer pointer) { fputc( '(', output); - print_list_contents( output, pointer); + print_list_contents( output, pointer, false); fputc( ')', output); } void print( FILE* output, struct cons_pointer pointer) { struct cons_space_object cell = pointer2cell( pointer); - if ( check_tag( pointer, CONSTAG)) { + /* Because tags have values as well as bytes, this if ... else if + * statement can ultimately be replaced by a switch, which will + * be neater. */ + switch ( cell.tag.value) { + case CONSTV : print_list( output, pointer); - } else if ( check_tag( pointer, INTEGERTAG)) { + break; + case INTEGERTV : fprintf( output, "%ld", cell.payload.integer.value); - } else if ( check_tag( pointer, NILTAG)) { - fprintf( output, "NIL"); - } else if ( check_tag( pointer, REALTAG)) { - fprintf( output, "%Lf", cell.payload.real.value); - } else if ( check_tag( pointer, STRINGTAG)) { + break; + case NILTV : + fprintf( output, "nil"); + break; + case STRINGTV : print_string( output, pointer); - } else if ( check_tag( pointer, TRUETAG)) { - fprintf( output, "T"); + break; + case SYMBOLTV : + print_string_contents( output, pointer); + break; + case TRUETV : + fprintf( output, "t"); + break; + default : + fprintf( stderr, "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]); } } diff --git a/src/read.c b/src/read.c index 2354420..d45b628 100644 --- a/src/read.c +++ b/src/read.c @@ -8,12 +8,15 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include #include #include +/* wide characters */ +#include +#include #include "consspaceobject.h" #include "integer.h" +#include "intern.h" #include "read.h" /* for the time being things which may be read are: @@ -22,45 +25,51 @@ lists Can't read atoms because I don't yet know what an atom is or how it's stored. */ -struct cons_pointer read_number( FILE* input, char initial); -struct cons_pointer read_list( FILE* input, char initial); -struct cons_pointer read_string( FILE* input, char initial); +struct cons_pointer read_number( FILE* input, wint_t initial); +struct cons_pointer read_list( 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); +/** + * quote reader macro in C (!) + */ +struct cons_pointer c_quote( struct cons_pointer arg) { + return make_cons( c_string_to_lisp_symbol( "quote"), + make_cons( arg, NIL)); +} /** * Read the next object on this input stream and return a cons_pointer to it, * treating this initial character as the first character of the object * representation. */ -struct cons_pointer read_continuation( FILE* input, char initial) { +struct cons_pointer read_continuation( FILE* input, wint_t initial) { struct cons_pointer result = NIL; - char c; + wint_t c; - for (c = initial; c == '\0' || isblank( c); c = fgetc( input)); + 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 '(' : - case ')': - result = read_list(input, fgetc( input)); + result = read_list(input, fgetwc( input)); break; - case '"': result = read_string(input, fgetc( input)); - break; - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - // case '.': - result = read_number( input, c); + case '"': + result = read_string(input, fgetwc( input)); break; default: - fprintf( stderr, "Unrecognised start of input character %c\n", c); + if ( iswdigit( c)) { + result = read_number( input, c); + } else if (iswprint( c)) { + result = read_symbol( input, c); + } else { + fprintf( stderr, "Unrecognised start of input character %c\n", c); + } } return result; @@ -70,15 +79,15 @@ struct cons_pointer read_continuation( FILE* input, char initial) { /** * read a number from this input stream, given this initial character. */ -struct cons_pointer read_number( FILE* input, char initial) { +struct cons_pointer read_number( FILE* input, wint_t initial) { int accumulator = 0; int places_of_decimals = 0; bool seen_period = false; - char c; + wint_t c; fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial); - for (c = initial; isdigit( c); c = fgetc( input)) { + for (c = initial; iswdigit( c); c = fgetwc( input)) { if ( c == '.') { seen_period = true; } else { @@ -91,7 +100,7 @@ struct cons_pointer read_number( FILE* input, char initial) { } /* push back the character read which was not a digit */ - fputc( c, input); + ungetwc( c, input); return make_integer( accumulator); } @@ -101,16 +110,15 @@ struct cons_pointer read_number( FILE* input, char initial) { * Read a list from this input stream, which no longer contains the opening * left parenthesis. */ -struct cons_pointer read_list( FILE* input, char initial) { - struct cons_pointer cdr = NIL; +struct cons_pointer read_list( FILE* input, wint_t initial) { struct cons_pointer result= NIL; - fprintf( stderr, "read_list starting '%c' (%d)\n", initial, initial); - if ( initial != ')' ) { + fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial); struct cons_pointer car = read_continuation( input, initial); - cdr = read_list( input, fgetc( input)); - result = make_cons( car, cdr); + result = make_cons( car, read_list( input, fgetwc( input))); + } else { + fprintf( stderr, "End of list detected\n"); } return result; @@ -118,16 +126,18 @@ struct cons_pointer read_list( FILE* input, char initial) { /** - * Read a string from this input stream, which no longer contains the opening - * double quote. Note that there is (for now) a problem with the list - * representation of a string, which is that there's no obvious representation of - * an empty string. + * Read a string. This means either a string delimited by double quotes + * (is_quoted == true), in which case it may contain whitespace but may + * not contain a double quote character (unless escaped), or one not + * so delimited in which case it may not contain whitespace (unless escaped) + * but may contain a double quote character (probably not a good idea!) */ -struct cons_pointer read_string( FILE* input, char initial) { +struct cons_pointer read_string( FILE* input, wint_t initial) { struct cons_pointer cdr = NIL; struct cons_pointer result; - fprintf( stderr, "read_string starting '%c' (%d)\n", initial, initial); + fwprintf( stderr, L"read_string starting '%C' (%d)\n", + initial, initial); switch ( initial) { case '\0': @@ -137,7 +147,43 @@ struct cons_pointer read_string( FILE* input, char initial) { result = make_string( '\0', NIL); break; default: - result = make_string( initial, read_string( input, fgetc( input))); + result = make_string( initial, read_string( input, fgetwc( input))); + break; + } + + return result; +} + + +struct cons_pointer read_symbol( FILE* input, wint_t initial) { + struct cons_pointer cdr = NIL; + struct cons_pointer result; + + fwprintf( stderr, L"read_symbol starting '%C' (%d)\n", + initial, initial); + + switch ( initial) { + case '\0': + result = make_symbol( initial, NIL); + 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 ( iswblank( initial) || !iswprint( initial)) { + result = make_symbol( '\0', NIL); + /* push back the character read */ + ungetwc( initial, input); + } else { + result = make_symbol( initial, read_symbol( input, fgetwc( input))); + } break; } @@ -149,8 +195,9 @@ struct cons_pointer read_string( FILE* input, char 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, '\0'); + return read_continuation( input, fgetwc( input)); } + diff --git a/src/stack.c b/src/stack.c new file mode 100644 index 0000000..8894ff3 --- /dev/null +++ b/src/stack.c @@ -0,0 +1,110 @@ +/** + * stack.c + * + * 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 + * 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. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "lispops.h" +#include "stack.h" + +/** + * Allocate a new stack frame with its previous pointer set to this value, + * its arguments set up from these args, evaluated in this env. + */ +struct stack_frame* make_stack_frame( struct stack_frame* previous, + struct cons_pointer args, + struct cons_pointer env) { + /* TODO: later, pop a frame off a free-list of stack frames */ + struct stack_frame* result = malloc( sizeof( struct stack_frame)); + + result->previous = previous; + + /* clearing the frame with memset would probably be slightly quicker, but + * this is clear. */ + result->more = NIL; + result->function = NIL; + + for ( int i = 0; i < args_in_frame; i++) { + result->arg[i] = NIL; + } + + int i = 0; /* still an index into args, so same + * name will do */ + + while ( ! nilp( args)) { /* iterate down the arg list filling in + * the arg slots in the frame. When there + * are no more slots, if there are still + * args, stash them on more */ + struct cons_space_object cell = pointer2cell( args); + + if ( i < args_in_frame) { + /* TODO: if we were running on real massively parallel hardware, each + * arg except the first should be handed off to another processor to + * be evaled in parallel */ + result->arg[i] = lisp_eval( cell.payload.cons.car, env, result); + inc_ref( result->arg[i]); + + args = cell.payload.cons.cdr; + } else { + /* TODO: this isn't right. These args should also each be evaled. */ + result->more = args; + inc_ref( result->more); + + args = NIL; + } + } + + return result; +} + +/** + * Free this stack frame. + */ +void free_stack_frame( struct stack_frame* frame) { + /* TODO: later, push it back on the stack-frame freelist */ + for ( int i = 0; i < args_in_frame; i++) { + dec_ref( frame->arg[ i]); + } + dec_ref( frame->more); + + free( frame); +} + +/** + * Fetch a pointer to the value of the local variable at this index. + */ +struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int index) { + struct cons_pointer result = NIL; + + if ( index < args_in_frame) { + result = frame->arg[ index]; + } else { + struct cons_pointer p = frame->more; + + for ( int i = args_in_frame; i < index; i++) { + p = pointer2cell( p).payload.cons.cdr; + } + + result = pointer2cell( p).payload.cons.car; + } + + return result; +} diff --git a/src/stack.h b/src/stack.h new file mode 100644 index 0000000..9cb95a1 --- /dev/null +++ b/src/stack.h @@ -0,0 +1,36 @@ +/** + * stack.h + * + * 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 + * 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. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "consspaceobject.h" +#include "conspage.h" + +#ifndef __stack_h +#define __stack_h + +struct stack_frame* make_stack_frame( struct stack_frame* previous, + struct cons_pointer args, + struct cons_pointer env); +void free_stack_frame( struct stack_frame* frame); +struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int n); + +/* struct stack_frame is defined in consspaceobject.h to break circularity + * TODO: refactor. */ + +#endif diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index dd9c7e1..6376fd6 100644 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected='(1 2 3 ("Fred") NIL 77354)' -actual=`echo '(1 2 3 ("Fred") () 77354 )' | target/psse 2> /dev/null` +expected='(1 2 3 ("Fred") nil 77354)' +actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh index 0ecd516..5449330 100644 --- a/unit-tests/nil.sh +++ b/unit-tests/nil.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected=NIL +expected=nil actual=`echo '()' | target/psse 2> /dev/null` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh new file mode 100644 index 0000000..624bdfb --- /dev/null +++ b/unit-tests/quote.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +expected='(quote Fred)' +actual=`echo "'Fred" | target/psse 2> /dev/null` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh new file mode 100644 index 0000000..eb4e7f3 --- /dev/null +++ b/unit-tests/quoted-list.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +expected='(quote (123 (4 (5 nil)) Fred))' +actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh index 9ea89a9..9ee9719 100644 --- a/unit-tests/simple-list.sh +++ b/unit-tests/simple-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="(1 2 3)" -actual=`echo '(1 2 3 )' | target/psse 2> /dev/null` +actual=`echo '(1 2 3)' | target/psse 2> /dev/null` if [ "${expected}" = "${actual}" ] then