Merge branch 'master' into develop

src/consspaceobject.c

@@ -11,6 +11,9 @@
 #include <stdint.h>
 #include <stdlib.h>
 #include <string.h>
+/* wide characters */
+#include <wchar.h>
+#include <wctype.h>
 
 #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)) {
+  if ( check_tag( tail, tag) || check_tag( tail, NILTAG)) {
-    pointer = allocate_cell( STRINGTAG);
+    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;
+}

src/consspaceobject.h

@@ -8,8 +8,12 @@
  *  Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#include <stdbool.h>
 #include <stdint.h>
 #include <stdio.h>
+/* wide characters */
+#include <wchar.h>
+#include <wctype.h>
 
 #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 INTEGERTV   1381256777
-#define READTAG  "READ"
+
-#define REALTAG  "REAL"
+/**
-#define STRINGTAG  "STRG"
+ * The special cons cell at address {0,0} whose car and cdr both point to itself.
-#define TRUETAG  "TRUE"
+ * 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
+ * Construct a cell which points to an executable Lisp special form.
- * 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( 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

src/equal.c

@@ -0,0 +1,62 @@
+/**
+ * equal.c
+ *
+ * Checks for shallow and deep equality
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <math.h>
+#include <stdbool.h>
+
+#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;
+}

src/equal.h

@@ -0,0 +1,30 @@
+/**
+ * equal.h
+ *
+ * Checks for shallow and deep equality
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <math.h>
+#include <stdbool.h>
+
+#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

src/init.c

@@ -1,8 +1,8 @@
 /**
  * init.c
  *
- * Start up and initialise the environement - just enough to get working and (ultimately)
+ * Start up and initialise the environement - just enough to get working 
- * hand off to the executive.
+ * and (ultimately) hand off to the executive.
  *
  *
  * (c) 2017 Simon Brooke <simon@journeyman.cc>
@@ -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);
   

src/integer.c

@@ -7,10 +7,32 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#define _GNU_SOURCE
+#include <math.h>
+
 #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.
  */

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.
  */

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 <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <stdbool.h>
+
+#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;
+}

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 <simon@journeyman.cc>
+ * 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

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 <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <ctype.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#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);
+}
+

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 <simon@journeyman.cc>
+ * 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);

src/print.c

@@ -11,6 +11,9 @@
 #include <ctype.h>
 #include <stdio.h>
 #include <string.h>
+/* wide characters */
+#include <wchar.h>
+#include <wctype.h>
 
 #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) {
+  switch ( cell->tag.value) {
-  if ( check_tag( pointer, CONSTAG)) {
+  case CONSTV :
-    struct cons_space_object* cell = &pointer2cell(pointer);
+    if (initial_space) {
-
+      fputc( ' ', output);
+    }      
     print( output, cell->payload.cons.car);
 
-    if ( !nilp( cell->payload.cons.cdr)) {
+    print_list_contents( output, cell->payload.cons.cdr, true);
-      fputc( ' ', output);
+    break;
-    }
+  case NILTV:
-    print_list_contents( output, cell->payload.cons.cdr);
+    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)) {
+    break;
-    fprintf( output, "NIL");
+  case NILTV :
-  } else if ( check_tag( pointer, REALTAG)) {
+    fprintf( output, "nil");
-    fprintf( output, "%Lf", cell.payload.real.value);
+    break;
-  } else if ( check_tag( pointer, STRINGTAG)) {
+  case STRINGTV :
     print_string( output, pointer);
-  } else if ( check_tag( pointer, TRUETAG)) {
+    break;
-    fprintf( output, "T");
+  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]);
   }
 }

src/read.c

@@ -8,12 +8,15 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
-#include <ctype.h>
 #include <stdbool.h>
 #include <stdio.h>
+/* wide characters */
+#include <wchar.h>
+#include <wctype.h>
 
 #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_number( FILE* input, wint_t initial);
-struct cons_pointer read_list( FILE* input, char initial);
+struct cons_pointer read_list( FILE* input, wint_t initial);
-struct cons_pointer read_string( FILE* input, char 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, fgetwc( input));
-    result = read_list(input, fgetc( input));
     break;
-  case '"': result = read_string(input, fgetc( input));
+  case '"':
-    break;
+    result = read_string(input, fgetwc( input));
-  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);
     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 read_list( FILE* input, wint_t initial) {
-  struct cons_pointer cdr = NIL;
   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, read_list( input, fgetwc( input)));
-    result = make_cons( car, cdr);
+  } 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
+ * Read a string. This means either a string delimited by double quotes 
- * double quote. Note that there is (for now) a problem with the list
+ * (is_quoted == true), in which case it may contain whitespace but may
- * representation of a string, which is that there's no obvious representation of
+ * not contain a double quote character (unless escaped), or one not
- * an empty string.
+ * 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));
 }
+
     
 
 

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 <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <stdlib.h>
+
+#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;
+}

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 <simon@journeyman.cc>
+ * 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

unit-tests/complex-list.sh

@@ -1,7 +1,7 @@
 #!/bin/bash
 
-expected='(1 2 3 ("Fred") NIL 77354)'
+expected='(1 2 3 ("Fred") nil 77354)'
-actual=`echo '(1 2 3 ("Fred") () 77354 )' | target/psse 2> /dev/null`
+actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null`
 
 if [ "${expected}" = "${actual}" ]
 then

unit-tests/nil.sh

@@ -1,6 +1,6 @@
 #!/bin/bash
 
-expected=NIL
+expected=nil
 actual=`echo '()' | target/psse 2> /dev/null`
 
 if [ "${expected}" = "${actual}" ]

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

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

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