From 1133a07752857c5dc217a39ddd06c9041eda2167 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 13 Jan 2017 17:40:49 +0000 Subject: [PATCH] Enough lisp operations implemented that it's now probably possible to try a read-eval-print loop. Read still isn't correctly reading UTF characters, but so long as I don't use UTF characters it's OK (bug needs fixing, but). --- src/consspaceobject.c | 17 ++- src/consspaceobject.h | 146 +++++++++++++++++++++++- src/intern.c | 139 +++++++++-------------- src/intern.h | 3 +- src/lispops.c | 252 +++++++++++++++++++++++++++++++++--------- src/lispops.h | 23 ++++ src/read.c | 4 - src/stack.c | 44 ++++++-- src/stack.h | 20 ++-- 9 files changed, 474 insertions(+), 174 deletions(-) create mode 100644 src/lispops.h diff --git a/src/consspaceobject.c b/src/consspaceobject.c index ae2721f..68b32b9 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -119,7 +119,7 @@ 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( wint_t c, struct cons_pointer tail) { struct cons_pointer pointer = NIL; if ( check_tag( tail, STRINGTAG) || check_tag( tail, NILTAG)) { @@ -127,7 +127,7 @@ struct cons_pointer make_string( char c, struct cons_pointer tail) { struct cons_space_object* cell = &pointer2cell(pointer); inc_ref(tail); - cell->payload.string.character = (wint_t) c; + cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.offset = tail.offset; } else { @@ -136,3 +136,16 @@ struct cons_pointer make_string( char c, struct cons_pointer tail) { 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; +} diff --git a/src/consspaceobject.h b/src/consspaceobject.h index fb696e6..fe055c2 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -26,16 +26,56 @@ /** * tag values, all of which must be 4 bytes. Must not collide with vector space tag values */ +/** + * An ordinary cons cell + */ #define CONSTAG "CONS" +/** + * An unallocated cell on the free list - should never be encountered by a Lisp + * function + */ #define FREETAG "FREE" +/** + * An ordinary Lisp function - one whose arguments are pre-evaluated and passed as + * a stack frame. + */ #define FUNCTIONTAG "FUNC" +/** + * An integer number. + */ #define INTEGERTAG "INTR" +/** + * The special cons cell at address {0,0} whose car and cdr both point to itself. + */ #define NILTAG "NIL " +/** + * 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. + */ +#define SPECIALTAG "SPFM" +/** + * A string of characters, organised as a linked list. + */ #define STRINGTAG "STRG" +/** + * The special cons cell at address {0,1} which is canonically different from NIL + */ #define TRUETAG "TRUE" +/** + * A pointer to an object in vector space. + */ #define VECTORPOINTTAG "VECP" +/** + * An open write stream. + */ #define WRITETAG "WRIT" /** @@ -43,6 +83,11 @@ */ #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 */ @@ -71,6 +116,11 @@ */ #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 */ @@ -81,6 +131,11 @@ */ #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 */ @@ -92,6 +147,12 @@ */ #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). @@ -113,6 +174,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. @@ -122,9 +198,18 @@ 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 cons_pointer, struct cons_pointer); + struct cons_pointer (*executable)(struct stack_frame*, struct cons_pointer); }; /** @@ -145,7 +230,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. @@ -155,14 +239,55 @@ 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. */ struct string_payload { - wint_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. */ @@ -184,12 +309,18 @@ struct cons_space_object { 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 == SPECIALTAG */ + struct special_payload special; /* if tag == STRINGTAG */ 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; }; @@ -225,6 +356,11 @@ 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( 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); #endif diff --git a/src/intern.c b/src/intern.c index bf5b9f4..862c43a 100644 --- a/src/intern.c +++ b/src/intern.c @@ -22,7 +22,58 @@ #include "equal.h" #include "conspage.h" #include "consspaceobject.h" -#include "equal.h" + +/** + * 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; +} /** * The object list. What is added to this during system setup is 'global', that is, @@ -35,92 +86,6 @@ */ struct cons_pointer oblist = NIL; -/** - * 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. - * TODO: This function ultimately belongs in lispops. - */ -struct cons_pointer assoc( struct cons_pointer key, struct cons_pointer store) { - struct cons_pointer result = NIL; - - if ( consp( store)) { - struct cons_space_object* cell_store = &pointer2cell( store); - - if ( consp( cell_store->payload.cons.car)) { - struct cons_space_object* binding = - &pointer2cell( cell_store->payload.cons.car); - - if ( eq( key, binding->payload.cons.car)) { - result = binding->payload.cons.cdr; - } - } - /* top-level objects on an assoc list ought to be conses (i.e. each - * successive car should be a cons), but there's no need to throw a - * wobbly if it isn't. */ - - if ( nilp( result)) { - result = assoc( key, cell_store->payload.cons.cdr); - } - } - - return result; -} - - -/** - * Internal workings of internedp, q.v. Not intended to be called from anywhere - * else. Note that this is VERY similar to assoc, but returns the car (key) of - * the binding rather than the cdr (value). - */ -struct cons_pointer __internedp( struct cons_pointer key, - struct cons_pointer store) { - struct cons_pointer result = NIL; - - if ( consp( store)) { - struct cons_space_object* cell_store = &pointer2cell( store); - - if ( consp( cell_store->payload.cons.car)) { - struct cons_space_object* binding = - &pointer2cell( cell_store->payload.cons.car); - - if ( equal( key, binding->payload.cons.car)) { - result = binding->payload.cons.car; - } - } - /* top-level objects on an assoc list ought to be conses (i.e. each - * successive car should be a cons), but there's no need to throw a - * wobbly if it isn't. */ - - if ( nilp( result)) { - result = assoc( key, cell_store->payload.cons.cdr); - } - } - - return result; -} - - -/** - * Return the canonical version of this key if ut is present as a key in this - * enviroment, defaulting to the oblist if no environment is passed. Key is - * expected to be a string. - */ -struct cons_pointer internedp( struct cons_pointer key, - struct cons_pointer environment) { - struct cons_pointer result = NIL; - - if ( stringp( key)) { - if ( nilp( environment)) { - result = __internedp( key, oblist); - } else { - result = __internedp( key, environment); - } - } - - return result; -} - /** * Return a new key/value store containing all the key/value pairs in this store diff --git a/src/intern.h b/src/intern.h index 148f05f..56adb33 100644 --- a/src/intern.h +++ b/src/intern.h @@ -27,9 +27,8 @@ 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. - * TODO: This function ultimately belongs in lispops. */ -struct cons_pointer assoc( struct cons_pointer key, struct cons_pointer store); +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 diff --git a/src/lispops.c b/src/lispops.c index b4efd11..f91ba02 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -14,7 +14,6 @@ * 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. */ @@ -22,29 +21,68 @@ #include #include #include +#include #include "consspaceobject.h" #include "conspage.h" +#include "equal.h" #include "integer.h" +#include "intern.h" +#include "print.h" #include "read.h" +#include "stack.h" -struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env); -struct cons_pointer lisp_cons( struct cons_pointer args, struct cons_pointer env); -struct cons_pointer lisp_car( struct cons_pointer args, struct cons_pointer env); -struct cons_pointer lisp_cdr( struct cons_pointer args, struct cons_pointer env); -struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env); -struct cons_pointer lisp_throw( struct cons_pointer args, struct cons_pointer env); +/* 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); +/* + * 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. + */ + +/* 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); /** - * in the long run this becomes redundant because it's just (map eval - * args), but it helps bootstrapping. + * Implementation of car in C. If arg is not a cons, does not error but returns nil. */ -struct cons_pointer i_eval_args( struct cons_pointer args, struct cons_pointer tail, struct cons_pointer env) { +struct cons_pointer c_car( struct cons_pointer arg) { struct cons_pointer result = NIL; - if ( ! nilp( args)) { - result = make_cons( lisp_eval( lisp_car( args, env), env), - i_eval_args( lisp_cdr( args, env), tail, env)); + 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; @@ -52,82 +90,123 @@ struct cons_pointer i_eval_args( struct cons_pointer args, struct cons_pointer t /** * (apply fn args...) - * I'm assuming that the function should be protected from evaluation - * in apply because its name has already been resolved to the function - * object in read. + * + * 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 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( make_cons( lisp_car( args, env), i_eval_args( lisp_cdr( args, env), NIL, env)), env); + lisp_eval( args, env, frame); } return result; } /** - * (eval args) + * (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 args, struct cons_pointer env) { - struct cons_pointer result = args; +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 stack_frame* my_frame = + make_stack_frame( previous, make_cons( s_expr, NIL), env); - if ( consp( args)) { + if ( consp( s_expr)) { /* the hard bit. Sort out what function is required and pass the * args to it. */ - struct cons_pointer fn_pointer = lisp_car( args, env); - args = lisp_cdr( args, env); + struct cons_pointer fn_pointer = lisp_eval( c_car( s_expr), env, my_frame); + struct cons_pointer args = c_cdr( s_expr); - if ( functionp( fn_pointer)) { + if ( specialp( fn_pointer)) { + struct cons_space_object special = pointer2cell( fn_pointer); + result = (*special.payload.special.executable)( args, env, previous); + } else if ( functionp( fn_pointer)) { 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)( args, env); - } else { + result = (*function.payload.function.executable)( frame, env); + free_stack_frame( frame); + } else if ( stringp( s_expr)) { + struct cons_pointer canonical = internedp( s_expr, env); + if ( !nilp( canonical)) { + result = c_assoc( canonical, env); + } else { + struct cons_pointer message = + c_string_to_lisp_string( "Attempt to value of unbound name."); + result = lisp_throw( message, my_frame); + } /* 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. */ - result = lisp_throw( args, env); } } + free_stack_frame( my_frame); + return result; } /** - * Apply cons to this argsument list. Effectively, create a cons cell comprising - * (car args) (cadr 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 cons_pointer args, struct cons_pointer env) { - struct cons_pointer result = NIL; +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 ( consp( args)) { - struct cons_space_object cell = pointer2cell( args); - struct cons_pointer a = cell.payload.cons.car; - struct cons_pointer d = pointer2cell( cell.payload.cons.cdr).payload.cons.car; - result = make_cons( a, d); + 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 { - lisp_throw( args, env); + result = make_cons( car, cdr); } return result; } /** - * Apply car to this argsument list. Effectively, (car (car args)) + * (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 cons_pointer args, struct cons_pointer env) { +struct cons_pointer lisp_car(struct stack_frame* frame, struct cons_pointer env) { struct cons_pointer result = NIL; - if ( consp( args)) { - struct cons_space_object cell = pointer2cell( args); - result = pointer2cell( cell.payload.cons.car).payload.cons.car; + 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 { - lisp_throw( args, env); + struct cons_pointer message = + c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence"); + result = lisp_throw( message, frame); } return result; @@ -135,28 +214,95 @@ struct cons_pointer lisp_car( struct cons_pointer args, struct cons_pointer env) /** - * Apply cdr to this argsument list. Effectively, (cdr (car args)) + * (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 cons_pointer args, struct cons_pointer env) { +struct cons_pointer lisp_cdr(struct stack_frame* frame, struct cons_pointer env) { struct cons_pointer result = NIL; - if ( consp( args)) { - struct cons_space_object cell = pointer2cell( args); - result = pointer2cell( cell.payload.cons.cdr).payload.cons.car; + 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 { - lisp_throw( args, env); + 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 args, struct cons_pointer env) { - fprintf( stderr, "An exception was thrown and I've no idea what to do now\n"); +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"); - return NIL; + exit( 1); } diff --git a/src/lispops.h b/src/lispops.h new file mode 100644 index 0000000..c9da923 --- /dev/null +++ b/src/lispops.h @@ -0,0 +1,23 @@ +/** + * 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. + */ + +struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env); + diff --git a/src/read.c b/src/read.c index f7a572f..6fdfe76 100644 --- a/src/read.c +++ b/src/read.c @@ -144,10 +144,6 @@ struct cons_pointer read( FILE* input) { return read_continuation( input, '\0'); } - -struct cons_pointer lisp_read( struct cons_pointer args, struct cons_pointer env) { - return( read( stdin)); -} diff --git a/src/stack.c b/src/stack.c index 7e24574..148ef41 100644 --- a/src/stack.c +++ b/src/stack.c @@ -22,12 +22,16 @@ #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 + * 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 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)); @@ -38,8 +42,31 @@ struct stack_frame* make_stack_frame(struct stack_frame* previous) { result->more = NIL; result->function = NIL; - for ( int i = 0; i < locals_in_frame; i++) { - result->local[i] = 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); + /* TODO: later, going to have to mess with reference counts */ + args = cell.payload.cons.cdr; + } else { + /* TODO: this isn't right. These args should also each be evaled. */ + result->more = args; + args = NIL; + } } return result; @@ -49,6 +76,7 @@ struct stack_frame* make_stack_frame(struct stack_frame* previous) { * Free this stack frame. */ void free_stack_frame( struct stack_frame* frame) { + /* TODO: later, mess with reference counts on locals */ /* TODO: later, push it back on the stack-frame freelist */ free( frame); } @@ -56,15 +84,15 @@ void free_stack_frame( struct stack_frame* frame) { /** * Fetch a pointer to the value of the local variable at this index. */ -struct cons_pointer fetch_local( struct stack_frame* frame, unsigned int index) { +struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int index) { struct cons_pointer result = NIL; - if ( index < locals_in_frame) { - result = frame->local[ index]; + if ( index < args_in_frame) { + result = frame->arg[ index]; } else { struct cons_pointer p = frame->more; - for ( int i = locals_in_frame; i < index; i++) { + for ( int i = args_in_frame; i < index; i++) { p = pointer2cell( p).payload.cons.cdr; } diff --git a/src/stack.h b/src/stack.h index ec3d956..9cb95a1 100644 --- a/src/stack.h +++ b/src/stack.h @@ -19,24 +19,18 @@ */ #include "consspaceobject.h" +#include "conspage.h" #ifndef __stack_h #define __stack_h -/* number of local variables stored in a stack frame */ -#define locals_in_frame 8 - -struct stack_frame* make_stack_frame(struct stack_frame* previous); +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_local( struct stack_frame* frame, unsigned int n); +struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int n); -struct stack_frame { - struct stack_frame* previous; /* the previous frame */ - struct cons_pointer local[locals_in_frame]; - /* first 8 local variable bindings */ - struct cons_pointer more; /* list of any further local - * variable bindings */ - struct cons_pointer function; /* the function to be called */ -}; +/* struct stack_frame is defined in consspaceobject.h to break circularity + * TODO: refactor. */ #endif