From 93b84087ceecf4e7242a5c442be07b4d22f6c376 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 7 Dec 2018 20:09:33 +0000
Subject: [PATCH 01/17] There's an enormous lot of good stuff in this, but I've
 messed up print almost certainly by writing a non-wide character to a wide
 stream.

---
 Makefile                        |   2 +-
 src/conspage.c                  |  29 +++++--
 src/consspaceobject.c           |  86 ++++++++++++++++++---
 src/consspaceobject.h           | 130 ++++++++++++++++++++++++--------
 src/init.c                      |   3 +-
 src/lispops.c                   |  20 +++--
 src/peano.c                     |  40 +++++++++-
 src/print.c                     |  77 ++++++++++---------
 src/read.c                      |  25 +++---
 src/read.h                      |   2 +-
 src/repl.c                      |  80 +++++++++++++++-----
 src/stack.c                     |  12 ++-
 unit-tests/string-allocation.sh |   4 +-
 13 files changed, 379 insertions(+), 131 deletions(-)

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

From d620542ee56c38a6e4878ea2e9e7f53e06368149 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 7 Dec 2018 20:53:09 +0000
Subject: [PATCH 02/17] Trying to get to the point where `make format` works
 the same

on Linux and MacOS
---
 .gitignore            |  2 +
 Makefile              | 10 ++++-
 src/conspage.c        | 13 ++++---
 src/consspaceobject.c | 90 +++++++++++++++++++++----------------------
 src/consspaceobject.h | 11 +++---
 src/init.c            |  2 +-
 src/lispops.c         | 15 ++++----
 src/peano.c           | 33 ++++++++--------
 src/print.c           | 80 +++++++++++++++++++-------------------
 src/read.c            | 19 +++++----
 src/read.h            |  2 +-
 src/repl.c            | 60 ++++++++++++++---------------
 src/stack.c           | 30 +++++++--------
 13 files changed, 191 insertions(+), 176 deletions(-)

diff --git a/.gitignore b/.gitignore
index 15477a1..30afce2 100644
--- a/.gitignore
+++ b/.gitignore
@@ -18,3 +18,5 @@ src/\.#*
 post-scarcity\.iml
 
 doc/
+
+log*
diff --git a/Makefile b/Makefile
index 1ba8422..b300b3c 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,3 @@
-
 TARGET ?= target/psse
 SRC_DIRS ?= ./src
 
@@ -11,7 +10,10 @@ TESTS := $(shell find unit-tests -name *.sh)
 
 INC_DIRS := $(shell find $(SRC_DIRS) -type d)
 INC_FLAGS := $(addprefix -I,$(INC_DIRS))
-INDENT_FLAGS := -kr -br -brf -brs -ce -cdw -npsl -nut -prs -l79 -ts2
+
+INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli0 \
+-d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \
+-npsl -nsc -nsob -nss -nut -prs -l79 -ts2
 
 VERSION := "0.0.2"
 
@@ -25,7 +27,11 @@ doc: $(SRCS) Makefile
 	doxygen
 
 format: $(SRCS) $(HDRS) Makefile
+ifeq ($(shell uname -s), Darwin)
+	gindent $(INDENT_FLAGS) $(SRCS) $(HDRS)
+else
 	indent $(INDENT_FLAGS) $(SRCS) $(HDRS)
+endif
 
 test: $(OBJS) $(TESTS) Makefile
 	bash ./unit-tests.sh
diff --git a/src/conspage.c b/src/conspage.c
index 9b0d218..f044c93 100644
--- a/src/conspage.c
+++ b/src/conspage.c
@@ -55,7 +55,7 @@ void make_cons_page(  ) {
             struct cons_space_object *cell =
                 &conspages[initialised_cons_pages]->cell[i];
             if ( initialised_cons_pages == 0 && i < 3 ) {
-              switch ( i) {
+                switch ( i ) {
                 case 0:
                     /*
                      * initialise cell as NIL
@@ -73,9 +73,11 @@ void make_cons_page(  ) {
                     strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
                     cell->count = MAXREFERENCE;
                     cell->payload.free.car = ( struct cons_pointer ) {
-                    0, 1};
+                        0, 1
+                    };
                     cell->payload.free.cdr = ( struct cons_pointer ) {
-                    0, 1};
+                        0, 1
+                    };
                     fwprintf( stderr, L"Allocated special cell T\n" );
                     break;
                 case 2:
@@ -84,7 +86,7 @@ void make_cons_page(  ) {
                      */
                     strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH );
                     cell->count = MAXREFERENCE;
-                    cell->payload.string.character = (wint_t)L'λ';
+                    cell->payload.string.character = ( wint_t ) L'λ';
                     cell->payload.free.cdr = NIL;
                     fwprintf( stderr, L"Allocated special cell LAMBDA\n" );
                     break;
@@ -120,7 +122,8 @@ void dump_pages( FILE * output ) {
 
         for ( int j = 0; j < CONSPAGESIZE; j++ ) {
             dump_object( output, ( struct cons_pointer ) {
-                         i, j} );
+                         i, j
+                         } );
         }
     }
 }
diff --git a/src/consspaceobject.c b/src/consspaceobject.c
index 8c3de50..0c2260d 100644
--- a/src/consspaceobject.c
+++ b/src/consspaceobject.c
@@ -63,6 +63,29 @@ void dec_ref( struct cons_pointer pointer ) {
     }
 }
 
+void dump_string_cell( FILE * output, wchar_t *prefix,
+                       struct cons_pointer pointer ) {
+    struct cons_space_object cell = pointer2cell( pointer );
+    if ( cell.payload.string.character == 0 ) {
+        fwprintf( output,
+                  L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
+                  prefix,
+                  cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
+                  cell.count );
+    } else {
+        fwprintf( output,
+                  L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
+                  prefix,
+                  ( wint_t ) cell.payload.string.character,
+                  cell.payload.string.character,
+                  cell.payload.string.cdr.page,
+                  cell.payload.string.cdr.offset, cell.count );
+        fwprintf( output, L"\t\t value: " );
+        print( output, pointer );
+        fwprintf( output, L"\n" );
+    }
+}
+
 /**
  * dump the object at this cons_pointer to this output stream.
  */
@@ -85,17 +108,16 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
                   cell.payload.cons.cdr.page,
                   cell.payload.cons.cdr.offset, cell.count );
         break;
-      case EXCEPTIONTV:
-      fwprintf(output, L"\t\tException cell: ");
-        print(output, cell.payload.exception.message);
-      fwprintf( output, L"\n");
-      /* TODO: dump the stack trace */
-      for (struct stack_frame * frame = cell.payload.exception.frame;
-           frame != NULL;
-           frame = frame->previous){
-        dump_frame(output, frame);
-      }
-      break;
+    case EXCEPTIONTV:
+        fwprintf( output, L"\t\tException cell: " );
+        print( output, cell.payload.exception.message );
+        fwprintf( output, L"\n" );
+        /* TODO: dump the stack trace */
+        for ( struct stack_frame * frame = cell.payload.exception.frame;
+              frame != NULL; frame = frame->previous ) {
+            dump_frame( output, frame );
+        }
+        break;
     case FREETV:
         fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
                   cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
@@ -105,40 +127,17 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
                   L"\t\tInteger cell: value %ld, count %u\n",
                   cell.payload.integer.value, cell.count );
         break;
-      case READTV:
-      fwprintf( output, L"\t\tInput stream\n");
+    case READTV:
+        fwprintf( output, L"\t\tInput stream\n" );
     case REALTV:
         fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
                   cell.payload.real.value, cell.count );
         break;
     case STRINGTV:
-      if (cell.payload.string.character == 0) {
-        fwprintf( output,
-                  L"\t\tString cell: termination; next at page %d offset %d, count %u\n",
-                 cell.payload.string.character,
-                  cell.payload.string.cdr.page,
-                  cell.payload.string.cdr.offset, cell.count );
-      }else {
-        fwprintf( output,
-                  L"\t\tString cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
-                  cell.payload.string.character,
-                  cell.payload.string.character,
-                  cell.payload.string.cdr.page,
-                  cell.payload.string.cdr.offset, cell.count );
-        fwprintf( output, L"\t\t value: " );
-        print( output, pointer );
-        fwprintf( output, L"\n" );}
+        dump_string_cell( output, L"String", pointer );
         break;
     case SYMBOLTV:
-        fwprintf( output,
-                  L"\t\tSymbol cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
-                  cell.payload.string.character,
-                  cell.payload.string.character,
-                  cell.payload.string.cdr.page,
-                  cell.payload.string.cdr.offset, cell.count );
-        fwprintf( output, L"\t\t value:" );
-        print( output, pointer );
-        fwprintf( output, L"\n" );
+        dump_string_cell( output, L"Symbol", pointer );
         break;
     }
 }
@@ -168,7 +167,8 @@ struct cons_pointer make_cons( struct cons_pointer car,
  * @param message should be a lisp string describing the problem, but actually any cons pointer will do;
  * @param frame should be the frame in which the exception occurred.
  */
-struct cons_pointer make_exception( struct cons_pointer message, struct stack_frame * frame) {
+struct cons_pointer make_exception( struct cons_pointer message,
+                                    struct stack_frame *frame ) {
     struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
@@ -259,26 +259,26 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable )
  * Construct a cell which points to a stream open for reading.
  * @param input the C stream to wrap.
  */
-struct cons_pointer make_read_stream( FILE * input) {
+struct cons_pointer make_read_stream( FILE * input ) {
     struct cons_pointer pointer = allocate_cell( READTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
-  cell->payload.stream.stream = input;
+    cell->payload.stream.stream = input;
 
-  return pointer;
+    return pointer;
 }
 
 /**
  * Construct a cell which points to a stream open for writeing.
  * @param output the C stream to wrap.
  */
-struct cons_pointer make_write_stream( FILE * output) {
+struct cons_pointer make_write_stream( FILE * output ) {
     struct cons_pointer pointer = allocate_cell( WRITETAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
-  cell->payload.stream.stream = output;
+    cell->payload.stream.stream = output;
 
-  return pointer;
+    return pointer;
 }
 
 /**
diff --git a/src/consspaceobject.h b/src/consspaceobject.h
index 05939c2..c17ded5 100644
--- a/src/consspaceobject.h
+++ b/src/consspaceobject.h
@@ -272,8 +272,8 @@ struct cons_payload {
  * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame.
  */
 struct exception_payload {
-  struct cons_pointer message;
-  struct stack_frame * frame;
+    struct cons_pointer message;
+    struct stack_frame *frame;
 };
 
 /**
@@ -461,7 +461,8 @@ struct cons_pointer make_cons( struct cons_pointer car,
  * @param message should be a lisp string describing the problem, but actually any cons pointer will do;
  * @param frame should be the frame in which the exception occurred.
  */
-struct cons_pointer make_exception( struct cons_pointer message, struct stack_frame * frame);
+struct cons_pointer make_exception( struct cons_pointer message,
+                                    struct stack_frame *frame );
 
 /**
  * Construct a cell which points to an executable Lisp special form.
@@ -496,13 +497,13 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail );
  * Construct a cell which points to a stream open for reading.
  * @param input the C stream to wrap.
  */
-struct cons_pointer make_read_stream( FILE * input);
+struct cons_pointer make_read_stream( FILE * input );
 
 /**
  * Construct a cell which points to a stream open for writeing.
  * @param output the C stream to wrap.
  */
-struct cons_pointer make_write_stream( FILE * output);
+struct cons_pointer make_write_stream( FILE * output );
 
 
 /**
diff --git a/src/init.c b/src/init.c
index 83baa73..616261c 100644
--- a/src/init.c
+++ b/src/init.c
@@ -74,7 +74,7 @@ int main( int argc, char *argv[] ) {
     deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
     deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
     /* deep_bind( c_string_to_lisp_symbol( L"λ"), LAMBDA ); */
-    deep_bind( c_string_to_lisp_symbol( "lambda"), LAMBDA );
+    deep_bind( c_string_to_lisp_symbol( "lambda" ), LAMBDA );
 
     /*
      * primitive function operations
diff --git a/src/lispops.c b/src/lispops.c
index 8019744..1b1eeea 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -475,7 +475,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
             done = true;
         } else {
             result = lisp_throw( c_string_to_lisp_string
-                        ( "Arguments to `cond` must be lists" ), frame );
+                                 ( "Arguments to `cond` must be lists" ),
+                                 frame );
         }
     }
     /* TODO: if there are more than 8 clauses we need to continue into the
@@ -495,11 +496,11 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
 
     struct cons_space_object cell = pointer2cell( message );
 
-  if ( cell.tag.value == EXCEPTIONTV) {
-    result = message;
-  } else {
-    result = make_exception( message, frame);
-  }
+    if ( cell.tag.value == EXCEPTIONTV ) {
+        result = message;
+    } else {
+        result = make_exception( message, frame );
+    }
 
-  return result;
+    return result;
 }
diff --git a/src/peano.c b/src/peano.c
index 43189ea..aec3104 100644
--- a/src/peano.c
+++ b/src/peano.c
@@ -144,9 +144,9 @@ lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) {
             make_real( arg0.payload.real.value -
                        numeric_value( frame->arg[1] ) );
     } else {
-      /* TODO: throw an exception */
-            lisp_throw( c_string_to_lisp_string
-                        ( "Cannot subtract: not a number" ), frame );
+        /* TODO: throw an exception */
+        lisp_throw( c_string_to_lisp_string
+                    ( "Cannot subtract: not a number" ), frame );
     }
 
     // and if not nilp[frame->arg[2]) we also have an error.
@@ -167,21 +167,20 @@ lisp_divide( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
     struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
 
-  if ( numberp(frame->arg[1]) && numeric_value(frame->arg[1]) == 0) {
-    lisp_throw( c_string_to_lisp_string
-                        ( "Cannot divide: divisor is zero" ), frame );
-  } else if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
-      result = make_integer( arg0.payload.integer.value /
-                          arg1.payload.integer.value );
-    } else if ( numberp(frame->arg[0]) && numberp(frame->arg[1])) {
-      result = make_real( numeric_value(frame->arg[0]) / numeric_value(frame->arg[1]));
+    if ( numberp( frame->arg[1] ) && numeric_value( frame->arg[1] ) == 0 ) {
+        lisp_throw( c_string_to_lisp_string
+                    ( "Cannot divide: divisor is zero" ), frame );
+    } else if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
+        result = make_integer( arg0.payload.integer.value /
+                               arg1.payload.integer.value );
+    } else if ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) {
+        result =
+            make_real( numeric_value( frame->arg[0] ) /
+                       numeric_value( frame->arg[1] ) );
     } else {
-            lisp_throw( c_string_to_lisp_string
-                        ( "Cannot divide: not a number" ), frame );
+        lisp_throw( c_string_to_lisp_string
+                    ( "Cannot divide: not a number" ), frame );
     }
 
-  return result;
+    return result;
 }
-
-
-
diff --git a/src/print.c b/src/print.c
index 2eb943e..1fdcafd 100644
--- a/src/print.c
+++ b/src/print.c
@@ -78,45 +78,45 @@ void print( FILE * output, struct cons_pointer pointer ) {
      * statement can ultimately be replaced by a switch, which will be neater.
      */
     switch ( cell.tag.value ) {
-        case CONSTV:
-            print_list( output, pointer );
-            break;
-        case EXCEPTIONTV:
-            fwprintf( output, L"\nException: ");
-            print_string_contents( output, cell.payload.exception.message);
-            break;
-        case INTEGERTV:
-            fwprintf( output, L"%ld", cell.payload.integer.value );
-            break;
-        case LAMBDATV:
-            fwprintf( output, L"lambda" /* "λ" */);
-            break;
-        case NILTV:
-            fwprintf( output, L"nil" );
-            break;
-        case REALTV:
-            fwprintf( output, L"%Lf", cell.payload.real.value );
-            break;
-        case STRINGTV:
-            print_string( output, pointer );
-            break;
-        case SYMBOLTV:
-            print_string_contents( output, pointer );
-            break;
-        case TRUETV:
-            fwprintf( output, L"t" );
-            break;
-        case FUNCTIONTV:
-            fwprintf( output, L"(Function)" );
-            break;
-        case SPECIALTV:
-            fwprintf( output, L"(Special form)" );
-            break;
-        default:
-            fwprintf( stderr,
-                      L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
-                      cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
-                      cell.tag.bytes[2], cell.tag.bytes[3] );
-            break;
+    case CONSTV:
+        print_list( output, pointer );
+        break;
+    case EXCEPTIONTV:
+        fwprintf( output, L"\nException: " );
+        print_string_contents( output, cell.payload.exception.message );
+        break;
+    case INTEGERTV:
+        fwprintf( output, L"%ld", cell.payload.integer.value );
+        break;
+    case LAMBDATV:
+        fwprintf( output, L"lambda" /* "λ" */  );
+        break;
+    case NILTV:
+        fwprintf( output, L"nil" );
+        break;
+    case REALTV:
+        fwprintf( output, L"%Lf", cell.payload.real.value );
+        break;
+    case STRINGTV:
+        print_string( output, pointer );
+        break;
+    case SYMBOLTV:
+        print_string_contents( output, pointer );
+        break;
+    case TRUETV:
+        fwprintf( output, L"t" );
+        break;
+    case FUNCTIONTV:
+        fwprintf( output, L"(Function)" );
+        break;
+    case SPECIALTV:
+        fwprintf( output, L"(Special form)" );
+        break;
+    default:
+        fwprintf( stderr,
+                  L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
+                  cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
+                  cell.tag.bytes[2], cell.tag.bytes[3] );
+        break;
     }
 }
diff --git a/src/read.c b/src/read.c
index eb82c1f..ad74db6 100644
--- a/src/read.c
+++ b/src/read.c
@@ -32,7 +32,8 @@
  */
 
 struct cons_pointer read_number( FILE * input, wint_t initial );
-struct cons_pointer read_list( struct stack_frame *frame, FILE * input, wint_t initial );
+struct cons_pointer read_list( struct stack_frame *frame, FILE * input,
+                               wint_t initial );
 struct cons_pointer read_string( FILE * input, wint_t initial );
 struct cons_pointer read_symbol( FILE * input, wint_t initial );
 
@@ -49,7 +50,8 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
  * treating this initial character as the first character of the object
  * representation.
  */
-struct cons_pointer read_continuation(struct stack_frame *frame, FILE * input, wint_t initial ) {
+struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
+                                       wint_t initial ) {
     struct cons_pointer result = NIL;
 
     wint_t c;
@@ -58,10 +60,10 @@ struct cons_pointer read_continuation(struct stack_frame *frame, FILE * input, w
           c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
 
     switch ( c ) {
-      case EOF:
-            result = lisp_throw( c_string_to_lisp_string
-                        ( "End of input while reading" ), frame );
-      break;
+    case EOF:
+        result = lisp_throw( c_string_to_lisp_string
+                             ( "End of input while reading" ), frame );
+        break;
     case '\'':
         result = c_quote( read_continuation( frame, input, fgetwc( input ) ) );
         break;
@@ -147,7 +149,8 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
  * Read a list from this input stream, which no longer contains the opening
  * left parenthesis.
  */
-struct cons_pointer read_list( struct stack_frame *frame, FILE * input, wint_t initial ) {
+struct cons_pointer read_list( struct stack_frame *frame, FILE * input,
+                               wint_t initial ) {
     struct cons_pointer result = NIL;
 
     if ( initial != ')' ) {
@@ -236,6 +239,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
 /**
  * Read the next object on this input stream and return a cons_pointer to it.
  */
-struct cons_pointer read(struct stack_frame *frame, FILE * input ) {
+struct cons_pointer read( struct stack_frame *frame, FILE * input ) {
     return read_continuation( frame, input, fgetwc( input ) );
 }
diff --git a/src/read.h b/src/read.h
index 2577ba2..af7574b 100644
--- a/src/read.h
+++ b/src/read.h
@@ -14,6 +14,6 @@
 /**
  * read the next object on this input stream and return a cons_pointer to it.
  */
-struct cons_pointer read(struct stack_frame *frame, FILE * input );
+struct cons_pointer read( struct stack_frame *frame, FILE * input );
 
 #endif
diff --git a/src/repl.c b/src/repl.c
index 9df9234..f3a51bd 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -30,41 +30,42 @@
 /**
  * Dummy up a Lisp read call with its own stack frame.
  */
-struct cons_pointer repl_read( struct cons_pointer stream_pointer) {
-      struct stack_frame *frame = make_empty_frame( NULL, oblist );
+struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
+    struct stack_frame *frame = make_empty_frame( NULL, oblist );
 
-      frame->arg[0] = stream_pointer;
-      struct cons_pointer result = lisp_read( frame, oblist);
-      free_stack_frame( frame );
+    frame->arg[0] = stream_pointer;
+    struct cons_pointer result = lisp_read( frame, oblist );
+    free_stack_frame( frame );
 
-  return result;
+    return result;
 }
 
 /**
  * Dummy up a Lisp eval call with its own stack frame.
  */
-struct cons_pointer repl_eval( struct cons_pointer input) {
-      struct stack_frame *frame = make_empty_frame( NULL, oblist );
+struct cons_pointer repl_eval( struct cons_pointer input ) {
+    struct stack_frame *frame = make_empty_frame( NULL, oblist );
 
-      frame->arg[0] = NIL /* input */;
-      struct cons_pointer result = lisp_eval( frame, oblist);
-      free_stack_frame( frame );
+    frame->arg[0] = NIL /* input */ ;
+    struct cons_pointer result = lisp_eval( frame, oblist );
+    free_stack_frame( frame );
 
-  return result;
+    return result;
 }
 
 /**
  * Dummy up a Lisp print call with its own stack frame.
  */
-struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer value) {
-      struct stack_frame *frame = make_empty_frame( NULL, oblist );
+struct cons_pointer repl_print( struct cons_pointer stream_pointer,
+                                struct cons_pointer value ) {
+    struct stack_frame *frame = make_empty_frame( NULL, oblist );
 
-      frame->arg[0] = value;
-      frame->arg[1] = NIL /* stream_pointer */;
-      struct cons_pointer result = lisp_print( frame, oblist);
-      free_stack_frame( frame );
+    frame->arg[0] = value;
+    frame->arg[1] = NIL /* stream_pointer */ ;
+    struct cons_pointer result = lisp_print( frame, oblist );
+    free_stack_frame( frame );
 
-  return result;
+    return result;
 }
 
 /**
@@ -77,21 +78,20 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_
 void
 repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
       bool show_prompt ) {
-    struct cons_pointer input_stream = make_read_stream(in_stream);
-    struct cons_pointer output_stream = make_write_stream(out_stream);
+    struct cons_pointer input_stream = make_read_stream( in_stream );
+    struct cons_pointer output_stream = make_write_stream( out_stream );
 
-      while ( !feof( pointer2cell(input_stream).payload.stream.stream ) ) {
-          if ( show_prompt ) {
-              fwprintf( out_stream, L"\n:: " );
-          }
+    while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
+        if ( show_prompt ) {
+            fwprintf( out_stream, L"\n:: " );
+        }
 
-        struct cons_pointer val = repl_eval( repl_read( input_stream));
+        struct cons_pointer val = repl_eval( repl_read( input_stream ) );
 
         /* suppress the 'end of stream' exception */
-        if ( exceptionp(val) &&
-            !feof( pointer2cell( input_stream).payload.stream.stream ) )
-        {
-          repl_print( output_stream, val);
+        if ( exceptionp( val ) &&
+             !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
+            repl_print( output_stream, val );
         }
     }
 }
diff --git a/src/stack.c b/src/stack.c
index 90a763a..7b4d2da 100644
--- a/src/stack.c
+++ b/src/stack.c
@@ -84,25 +84,25 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
         struct stack_frame *arg_frame = make_empty_frame( previous, env );
         arg_frame->arg[0] = cell.payload.cons.car;
         inc_ref( arg_frame->arg[0] );
-      struct cons_pointer val = lisp_eval( arg_frame, env );
-      if (pointer2cell(val).tag.value == EXCEPTIONTV) {
-        result->arg[0] = val;
-        break;
-      } else {
-        result->arg[i] = val;
-      }
-      inc_ref(val);
+        struct cons_pointer val = lisp_eval( arg_frame, env );
+        if ( pointer2cell( val ).tag.value == EXCEPTIONTV ) {
+            result->arg[0] = val;
+            break;
+        } else {
+            result->arg[i] = val;
+        }
+        inc_ref( val );
         free_stack_frame( arg_frame );
 
         args = cell.payload.cons.cdr;
     }
-  if (!nilp( args)) {
-    /*
-     * TODO: this isn't right. These args should also each be evaled.
-     */
-    result->more = args;
-    inc_ref( result->more );
-  }
+    if ( !nilp( args ) ) {
+        /*
+         * TODO: this isn't right. These args should also each be evaled.
+         */
+        result->more = args;
+        inc_ref( result->more );
+    }
 
     return result;
 }

From fc960dec20de86805a6aa5b60f54084d7fea415c Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 7 Dec 2018 22:33:59 +0000
Subject: [PATCH 03/17] Fixed! A stupid error which was entirely my fault

---
 src/repl.c  |  4 ++--
 src/stack.c | 12 ++++++++----
 2 files changed, 10 insertions(+), 6 deletions(-)

diff --git a/src/repl.c b/src/repl.c
index f3a51bd..a11e511 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -46,7 +46,7 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
 struct cons_pointer repl_eval( struct cons_pointer input ) {
     struct stack_frame *frame = make_empty_frame( NULL, oblist );
 
-    frame->arg[0] = NIL /* input */ ;
+    frame->arg[0] = input;
     struct cons_pointer result = lisp_eval( frame, oblist );
     free_stack_frame( frame );
 
@@ -89,7 +89,7 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
         struct cons_pointer val = repl_eval( repl_read( input_stream ) );
 
         /* suppress the 'end of stream' exception */
-        if ( exceptionp( val ) &&
+        if ( !exceptionp( val ) &&
              !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
             repl_print( output_stream, val );
         }
diff --git a/src/stack.c b/src/stack.c
index 7b4d2da..2c3aa68 100644
--- a/src/stack.c
+++ b/src/stack.c
@@ -69,7 +69,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
                                       struct cons_pointer env ) {
     struct stack_frame *result = make_empty_frame( previous, env );
 
-    for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
+    for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
         /* iterate down the arg list filling in the arg slots in the
          * frame. When there are no more slots, if there are still args,
          * stash them on more */
@@ -81,17 +81,19 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
          * processor to be evaled in parallel; but see notes here:
          * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
          */
-        struct stack_frame *arg_frame = make_empty_frame( previous, env );
+        struct stack_frame *arg_frame = make_empty_frame( result, env );
         arg_frame->arg[0] = cell.payload.cons.car;
         inc_ref( arg_frame->arg[0] );
+
         struct cons_pointer val = lisp_eval( arg_frame, env );
-        if ( pointer2cell( val ).tag.value == EXCEPTIONTV ) {
+        if ( exceptionp( val ) ) {
             result->arg[0] = val;
             break;
         } else {
             result->arg[i] = val;
         }
         inc_ref( val );
+
         free_stack_frame( arg_frame );
 
         args = cell.payload.cons.cdr;
@@ -147,7 +149,9 @@ void free_stack_frame( struct stack_frame *frame ) {
     for ( int i = 0; i < args_in_frame; i++ ) {
         dec_ref( frame->arg[i] );
     }
-    dec_ref( frame->more );
+    if ( !nilp( frame->more ) ) {
+        dec_ref( frame->more );
+    }
 
     free( frame );
 }

From 27fd678888862406d8c445cae43853ea93c65c44 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Sat, 8 Dec 2018 00:28:15 +0000
Subject: [PATCH 04/17] Tried to get more sensible printing of floating point
 numbers

Results are quite disappointing. Resolution on long doubles is nothing like as good as I hoped; they're out by one part in 10^20.

All unit tests except one pass, and the one that doesn't is a very minor rounding issue, so I'm calling it good.
---
 Makefile                        |  2 +-
 src/init.c                      |  3 ++-
 src/integer.c                   |  2 +-
 src/peano.c                     | 15 +++++++++------
 src/peano.h                     |  9 +++++++++
 src/print.c                     | 17 ++++++++++++++++-
 unit-tests/add.sh               |  2 +-
 unit-tests/multiply.sh          |  2 +-
 unit-tests/string-allocation.sh |  7 +++++--
 9 files changed, 45 insertions(+), 14 deletions(-)

diff --git a/Makefile b/Makefile
index b300b3c..bf818ac 100644
--- a/Makefile
+++ b/Makefile
@@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile
 
 .PHONY: clean
 clean:
-	$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~
+	$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~
 
 repl:
 	$(TARGET) -p 2> psse.log
diff --git a/src/init.c b/src/init.c
index 616261c..3f85b51 100644
--- a/src/init.c
+++ b/src/init.c
@@ -73,7 +73,6 @@ int main( int argc, char *argv[] ) {
      */
     deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
     deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
-    /* deep_bind( c_string_to_lisp_symbol( L"λ"), LAMBDA ); */
     deep_bind( c_string_to_lisp_symbol( "lambda" ), LAMBDA );
 
     /*
@@ -85,6 +84,7 @@ int main( int argc, char *argv[] ) {
     bind_function( "car", &lisp_car );
     bind_function( "cdr", &lisp_cdr );
     bind_function( "cons", &lisp_cons );
+    bind_function( "divide", &lisp_divide );
     bind_function( "eq", &lisp_eq );
     bind_function( "equal", &lisp_equal );
     bind_function( "eval", &lisp_eval );
@@ -98,6 +98,7 @@ int main( int argc, char *argv[] ) {
     bind_function( "+", &lisp_add );
     bind_function( "*", &lisp_multiply );
     bind_function( "-", &lisp_subtract );
+    bind_function( "/", &lisp_divide );
 
     /*
      * primitive special forms
diff --git a/src/integer.c b/src/integer.c
index 6352b34..999c803 100644
--- a/src/integer.c
+++ b/src/integer.c
@@ -21,7 +21,7 @@
  * but only integers and reals are so far implemented.
  */
 long double numeric_value( struct cons_pointer pointer ) {
-    double result = NAN;
+    long double result = NAN;
     struct cons_space_object *cell = &pointer2cell( pointer );
 
     if ( integerp( pointer ) ) {
diff --git a/src/peano.c b/src/peano.c
index aec3104..2402440 100644
--- a/src/peano.c
+++ b/src/peano.c
@@ -170,13 +170,16 @@ lisp_divide( struct stack_frame *frame, struct cons_pointer env ) {
     if ( numberp( frame->arg[1] ) && numeric_value( frame->arg[1] ) == 0 ) {
         lisp_throw( c_string_to_lisp_string
                     ( "Cannot divide: divisor is zero" ), frame );
-    } else if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
-        result = make_integer( arg0.payload.integer.value /
-                               arg1.payload.integer.value );
     } else if ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) {
-        result =
-            make_real( numeric_value( frame->arg[0] ) /
-                       numeric_value( frame->arg[1] ) );
+        long int i = ( long int ) numeric_value( frame->arg[0] ) /
+            numeric_value( frame->arg[1] );
+        long double r = ( long double ) numeric_value( frame->arg[0] ) /
+            numeric_value( frame->arg[1] );
+        if ( fabsl( ( long double ) i - r ) < 0.0000000001 ) {
+            result = make_integer( i );
+        } else {
+            result = make_real( r );
+        }
     } else {
         lisp_throw( c_string_to_lisp_string
                     ( "Cannot divide: not a number" ), frame );
diff --git a/src/peano.h b/src/peano.h
index 4650fe0..79735c0 100644
--- a/src/peano.h
+++ b/src/peano.h
@@ -43,6 +43,15 @@ extern "C" {
     struct cons_pointer
      lisp_subtract( struct stack_frame *frame, struct cons_pointer env );
 
+/**
+ * Divide one number by another.
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+    struct cons_pointer
+     lisp_divide( struct stack_frame *frame, struct cons_pointer env );
+
 #ifdef __cplusplus
 }
 #endif
diff --git a/src/print.c b/src/print.c
index 1fdcafd..1988563 100644
--- a/src/print.c
+++ b/src/print.c
@@ -9,6 +9,7 @@
 
 #include <ctype.h>
 #include <stdio.h>
+#include <stdlib.h>
 #include <string.h>
 /*
  * wide characters
@@ -72,6 +73,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) {
 
 void print( FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
+    char *buffer;
 
     /*
      * Because tags have values as well as bytes, this if ... else if
@@ -95,7 +97,20 @@ void print( FILE * output, struct cons_pointer pointer ) {
         fwprintf( output, L"nil" );
         break;
     case REALTV:
-        fwprintf( output, L"%Lf", cell.payload.real.value );
+        /* TODO: using the C heap is a bad plan because it will fragment.
+         * As soon as I have working vector space I'll use a special purpose
+         * vector space object */
+        buffer = ( char * ) malloc( 24 );
+        memset( buffer, 0, 24 );
+        /* format it really long, then clear the trailing zeros */
+        sprintf( buffer, "%-.23Lg", cell.payload.real.value );
+        if ( strchr( buffer, '.' ) != NULL ) {
+            for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
+                buffer[i] = '\0';
+            }
+        }
+        fwprintf( output, L"%s", buffer );
+        free( buffer );
         break;
     case STRINGTV:
         print_string( output, pointer );
diff --git a/unit-tests/add.sh b/unit-tests/add.sh
index ba8e635..7bb29c7 100644
--- a/unit-tests/add.sh
+++ b/unit-tests/add.sh
@@ -11,7 +11,7 @@ else
     exit 1
 fi
 
-expected='5.500000'
+expected='5.5'
 actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "${expected}" = "${actual}" ]
diff --git a/unit-tests/multiply.sh b/unit-tests/multiply.sh
index b9fd5b1..0675a6f 100644
--- a/unit-tests/multiply.sh
+++ b/unit-tests/multiply.sh
@@ -11,7 +11,7 @@ else
     exit 1
 fi
 
-expected='7.500000'
+expected='7.5'
 actual=`echo "(multiply 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "${expected}" = "${actual}" ]
diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh
index e377c42..7fe78c4 100644
--- a/unit-tests/string-allocation.sh
+++ b/unit-tests/string-allocation.sh
@@ -1,14 +1,17 @@
 #!/bin/bash
 
+log=log.$$
 value='"Fred"'
 expected="String cell: character 'F' (70)"
-echo ${value} | target/psse -d 2>/dev/null | grep "${expected}" > /dev/null
+echo ${value} | target/psse -d > ${log} 2>/dev/null
+grep "${expected}" ${log} > /dev/null
 
 if [ $? -eq 0 ]
 then
     echo "OK"
+    rm ${log}
     exit 0
 else
-    echo "Expected '${expected}', not found"
+    echo "Expected '${expected}', not found in ${log}"
     exit 1
 fi

From 9bfc9074b05cdc5a3275bc11179b0328b6b346cf Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Sat, 8 Dec 2018 14:09:57 +0000
Subject: [PATCH 05/17] Improved (for me) formatting on Mac

Don't yet know whether this will work on Linux.
---
 Makefile              |   2 +-
 src/conspage.c        |  68 ++++++++++-----------
 src/consspaceobject.c |  79 ++++++++++++------------
 src/equal.c           |  74 +++++++++++-----------
 src/init.c            |  18 +++---
 src/lispops.c         | 139 +++++++++++++++++++++++++++---------------
 src/peano.c           |  44 ++++++-------
 src/print.c           | 128 +++++++++++++++++++-------------------
 src/read.c            | 135 ++++++++++++++++++++--------------------
 9 files changed, 368 insertions(+), 319 deletions(-)

diff --git a/Makefile b/Makefile
index bf818ac..4797c75 100644
--- a/Makefile
+++ b/Makefile
@@ -11,7 +11,7 @@ TESTS := $(shell find unit-tests -name *.sh)
 INC_DIRS := $(shell find $(SRC_DIRS) -type d)
 INC_FLAGS := $(addprefix -I,$(INC_DIRS))
 
-INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli0 \
+INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \
 -d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \
 -npsl -nsc -nsob -nss -nut -prs -l79 -ts2
 
diff --git a/src/conspage.c b/src/conspage.c
index f044c93..9845284 100644
--- a/src/conspage.c
+++ b/src/conspage.c
@@ -56,40 +56,40 @@ void make_cons_page(  ) {
                 &conspages[initialised_cons_pages]->cell[i];
             if ( initialised_cons_pages == 0 && i < 3 ) {
                 switch ( i ) {
-                case 0:
-                    /*
-                     * initialise cell as NIL
-                     */
-                    strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH );
-                    cell->count = MAXREFERENCE;
-                    cell->payload.free.car = NIL;
-                    cell->payload.free.cdr = NIL;
-                    fwprintf( stderr, L"Allocated special cell NIL\n" );
-                    break;
-                case 1:
-                    /*
-                     * initialise cell as T
-                     */
-                    strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
-                    cell->count = MAXREFERENCE;
-                    cell->payload.free.car = ( struct cons_pointer ) {
-                        0, 1
-                    };
-                    cell->payload.free.cdr = ( struct cons_pointer ) {
-                        0, 1
-                    };
-                    fwprintf( stderr, L"Allocated special cell T\n" );
-                    break;
-                case 2:
-                    /*
-                     * initialise cell as λ
-                     */
-                    strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH );
-                    cell->count = MAXREFERENCE;
-                    cell->payload.string.character = ( wint_t ) L'λ';
-                    cell->payload.free.cdr = NIL;
-                    fwprintf( stderr, L"Allocated special cell LAMBDA\n" );
-                    break;
+                    case 0:
+                        /*
+                         * initialise cell as NIL
+                         */
+                        strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH );
+                        cell->count = MAXREFERENCE;
+                        cell->payload.free.car = NIL;
+                        cell->payload.free.cdr = NIL;
+                        fwprintf( stderr, L"Allocated special cell NIL\n" );
+                        break;
+                    case 1:
+                        /*
+                         * initialise cell as T
+                         */
+                        strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
+                        cell->count = MAXREFERENCE;
+                        cell->payload.free.car = ( struct cons_pointer ) {
+                            0, 1
+                        };
+                        cell->payload.free.cdr = ( struct cons_pointer ) {
+                            0, 1
+                        };
+                        fwprintf( stderr, L"Allocated special cell T\n" );
+                        break;
+                    case 2:
+                        /*
+                         * initialise cell as λ
+                         */
+                        strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH );
+                        cell->count = MAXREFERENCE;
+                        cell->payload.string.character = ( wint_t ) L'λ';
+                        cell->payload.free.cdr = NIL;
+                        fwprintf( stderr, L"Allocated special cell LAMBDA\n" );
+                        break;
                 }
             } else {
                 /*
diff --git a/src/consspaceobject.c b/src/consspaceobject.c
index 0c2260d..1b6173f 100644
--- a/src/consspaceobject.c
+++ b/src/consspaceobject.c
@@ -100,45 +100,46 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
               cell.tag.value, pointer.page, pointer.offset, cell.count );
 
     switch ( cell.tag.value ) {
-    case CONSTV:
-        fwprintf( output,
-                  L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
-                  cell.payload.cons.car.page,
-                  cell.payload.cons.car.offset,
-                  cell.payload.cons.cdr.page,
-                  cell.payload.cons.cdr.offset, cell.count );
-        break;
-    case EXCEPTIONTV:
-        fwprintf( output, L"\t\tException cell: " );
-        print( output, cell.payload.exception.message );
-        fwprintf( output, L"\n" );
-        /* TODO: dump the stack trace */
-        for ( struct stack_frame * frame = cell.payload.exception.frame;
-              frame != NULL; frame = frame->previous ) {
-            dump_frame( output, frame );
-        }
-        break;
-    case FREETV:
-        fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
-                  cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
-        break;
-    case INTEGERTV:
-        fwprintf( output,
-                  L"\t\tInteger cell: value %ld, count %u\n",
-                  cell.payload.integer.value, cell.count );
-        break;
-    case READTV:
-        fwprintf( output, L"\t\tInput stream\n" );
-    case REALTV:
-        fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
-                  cell.payload.real.value, cell.count );
-        break;
-    case STRINGTV:
-        dump_string_cell( output, L"String", pointer );
-        break;
-    case SYMBOLTV:
-        dump_string_cell( output, L"Symbol", pointer );
-        break;
+        case CONSTV:
+            fwprintf( output,
+                      L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
+                      cell.payload.cons.car.page,
+                      cell.payload.cons.car.offset,
+                      cell.payload.cons.cdr.page,
+                      cell.payload.cons.cdr.offset, cell.count );
+            break;
+        case EXCEPTIONTV:
+            fwprintf( output, L"\t\tException cell: " );
+            print( output, cell.payload.exception.message );
+            fwprintf( output, L"\n" );
+            /* TODO: dump the stack trace */
+            for ( struct stack_frame * frame = cell.payload.exception.frame;
+                  frame != NULL; frame = frame->previous ) {
+                dump_frame( output, frame );
+            }
+            break;
+        case FREETV:
+            fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
+                      cell.payload.cons.cdr.page,
+                      cell.payload.cons.cdr.offset );
+            break;
+        case INTEGERTV:
+            fwprintf( output,
+                      L"\t\tInteger cell: value %ld, count %u\n",
+                      cell.payload.integer.value, cell.count );
+            break;
+        case READTV:
+            fwprintf( output, L"\t\tInput stream\n" );
+        case REALTV:
+            fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
+                      cell.payload.real.value, cell.count );
+            break;
+        case STRINGTV:
+            dump_string_cell( output, L"String", pointer );
+            break;
+        case SYMBOLTV:
+            dump_string_cell( output, L"Symbol", pointer );
+            break;
     }
 }
 
diff --git a/src/equal.c b/src/equal.c
index 43e9424..d06903f 100644
--- a/src/equal.c
+++ b/src/equal.c
@@ -59,44 +59,46 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
         struct cons_space_object *cell_b = &pointer2cell( b );
 
         switch ( cell_a->tag.value ) {
-        case CONSTV:
-            result =
-                equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
-                && equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr );
-            break;
-        case STRINGTV:
-        case SYMBOLTV:
-            /*
-             * slightly complex because a string may or may not have a '\0'
-             * cell at the end, but I'll ignore that for now. I think in
-             * practice only the empty string will. 
-             */
-            result =
-                cell_a->payload.string.character ==
-                cell_b->payload.string.character
-                && ( equal( cell_a->payload.string.cdr,
-                            cell_b->payload.string.cdr )
-                     || ( end_of_string( cell_a->payload.string.cdr )
-                          && end_of_string( cell_b->payload.string.cdr ) ) );
-            break;
-        case INTEGERTV:
-        case REALTV:
-            {
-                double num_a = numeric_value( a );
-                double num_b = numeric_value( b );
-                double max =
-                    fabs( num_a ) >
-                    fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
-
+            case CONSTV:
+                result =
+                    equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
+                    && equal( cell_a->payload.cons.cdr,
+                              cell_b->payload.cons.cdr );
+                break;
+            case STRINGTV:
+            case SYMBOLTV:
                 /*
-                 * not more different than one part in a million - close enough 
+                 * slightly complex because a string may or may not have a '\0'
+                 * cell at the end, but I'll ignore that for now. I think in
+                 * practice only the empty string will. 
                  */
-                result = fabs( num_a - num_b ) < ( max / 1000000.0 );
-            }
-            break;
-        default:
-            result = false;
-            break;
+                result =
+                    cell_a->payload.string.character ==
+                    cell_b->payload.string.character
+                    && ( equal( cell_a->payload.string.cdr,
+                                cell_b->payload.string.cdr )
+                         || ( end_of_string( cell_a->payload.string.cdr )
+                              && end_of_string( cell_b->payload.string.
+                                                cdr ) ) );
+                break;
+            case INTEGERTV:
+            case REALTV:
+                {
+                    double num_a = numeric_value( a );
+                    double num_b = numeric_value( b );
+                    double max =
+                        fabs( num_a ) >
+                        fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
+
+                    /*
+                     * not more different than one part in a million - close enough 
+                     */
+                    result = fabs( num_a - num_b ) < ( max / 1000000.0 );
+                }
+                break;
+            default:
+                result = false;
+                break;
         }
 
         /*
diff --git a/src/init.c b/src/init.c
index 3f85b51..8043117 100644
--- a/src/init.c
+++ b/src/init.c
@@ -48,15 +48,15 @@ int main( int argc, char *argv[] ) {
 
     while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) {
         switch ( option ) {
-        case 'd':
-            dump_at_end = true;
-            break;
-        case 'p':
-            show_prompt = true;
-            break;
-        default:
-            fwprintf( stderr, L"Unexpected option %c\n", option );
-            break;
+            case 'd':
+                dump_at_end = true;
+                break;
+            case 'p':
+                show_prompt = true;
+                break;
+            default:
+                fwprintf( stderr, L"Unexpected option %c\n", option );
+                break;
         }
     }
 
diff --git a/src/lispops.c b/src/lispops.c
index 1b1eeea..9ecd602 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -96,6 +96,38 @@ struct cons_pointer eval_form( struct stack_frame *parent,
     return result;
 }
 
+/**
+ * The Lisp interpreter.
+ *
+ * @param frame the stack frame in which the expression is to be interpreted;
+ * @param lexpr the lambda expression to be interpreted;
+ * @param env the environment in which it is to be intepreted.
+ */
+struct cons_pointer
+lisp_lambda( struct stack_frame *frame, struct cons_pointer lexpr,
+             struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+    struct cons_pointer should_be_lambda =
+        eval_form( frame, c_car( lexpr ), env );
+
+    if ( lambdap( should_be_lambda ) ) {
+        struct cons_pointer new_env = env;
+    } else {
+        char *buffer = malloc( 1024 );
+        memset( buffer, '\0', 1024 );
+        sprintf( buffer,
+                 "Expected lambda, but found cell with tag %d (%c%c%c%c)",
+                 fn_cell.tag.value, fn_cell.tag.bytes[0],
+                 fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
+                 fn_cell.tag.bytes[3] );
+        struct cons_pointer message = c_string_to_lisp_string( buffer );
+        free( buffer );
+        result = lisp_throw( message, frame );
+    }
+    return result;
+}
+
+
 
 /**
  * Internal guts of apply.
@@ -118,35 +150,43 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer args = c_cdr( frame->arg[0] );
 
     switch ( fn_cell.tag.value ) {
-    case SPECIALTV:
-        {
-            struct stack_frame *next = make_special_frame( frame, args, env );
-            result = ( *fn_cell.payload.special.executable ) ( next, env );
-            free_stack_frame( next );
-        }
-        break;
+        case SPECIALTV:
+            {
+                struct stack_frame *next =
+                    make_special_frame( frame, args, env );
+                result = ( *fn_cell.payload.special.executable ) ( next, env );
+                free_stack_frame( next );
+            }
+            break;
 
-    case FUNCTIONTV:
-        {
-            struct stack_frame *next = make_stack_frame( frame, args, env );
-            result = ( *fn_cell.payload.special.executable ) ( next, env );
-            free_stack_frame( next );
-        }
-        break;
+        case FUNCTIONTV:
+            {
+                struct stack_frame *next =
+                    make_stack_frame( frame, args, env );
+                result = ( *fn_cell.payload.special.executable ) ( next, env );
+                free_stack_frame( next );
+            }
+            break;
 
-    default:
-        {
-            char *buffer = malloc( 1024 );
-            memset( buffer, '\0', 1024 );
-            sprintf( buffer,
-                     "Unexpected cell with tag %d (%c%c%c%c) in function position",
-                     fn_cell.tag.value, fn_cell.tag.bytes[0],
-                     fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
-                     fn_cell.tag.bytes[3] );
-            struct cons_pointer message = c_string_to_lisp_string( buffer );
-            free( buffer );
-            result = lisp_throw( message, frame );
-        }
+        case CONSTV:
+            {
+                result = lisp_lambda( frame, fn_pointer, env );
+            }
+            break;
+        default:
+            {
+                char *buffer = malloc( 1024 );
+                memset( buffer, '\0', 1024 );
+                sprintf( buffer,
+                         "Unexpected cell with tag %d (%c%c%c%c) in function position",
+                         fn_cell.tag.value, fn_cell.tag.bytes[0],
+                         fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
+                         fn_cell.tag.bytes[3] );
+                struct cons_pointer message =
+                    c_string_to_lisp_string( buffer );
+                free( buffer );
+                result = lisp_throw( message, frame );
+            }
     }
 
     return result;
@@ -193,30 +233,31 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
     dump_frame( stderr, frame );
 
     switch ( cell.tag.value ) {
-    case CONSTV:
-        result = c_apply( frame, env );
-        break;
+        case CONSTV:
+            result = c_apply( frame, env );
+            break;
 
-    case SYMBOLTV:
-        {
-            struct cons_pointer canonical = internedp( frame->arg[0], env );
-            if ( nilp( canonical ) ) {
-                struct cons_pointer message =
-                    c_string_to_lisp_string
-                    ( "Attempt to take value of unbound symbol." );
-                result = lisp_throw( message, frame );
-            } else {
-                result = c_assoc( canonical, env );
+        case SYMBOLTV:
+            {
+                struct cons_pointer canonical =
+                    internedp( frame->arg[0], env );
+                if ( nilp( canonical ) ) {
+                    struct cons_pointer message =
+                        c_string_to_lisp_string
+                        ( "Attempt to take value of unbound symbol." );
+                    result = lisp_throw( message, frame );
+                } else {
+                    result = c_assoc( canonical, env );
+                }
             }
-        }
-        break;
-        /*
-         * the Clojure practice of having a map serve in the function place of
-         * an s-expression is a good one and I should adopt it; also if the
-         * object is a consp it could be interpretable source code but in the
-         * long run I don't want an interpreter, and if I can get away without
-         * so much the better.
-         */
+            break;
+            /*
+             * 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.
+             */
     }
 
     fputws( L"Eval returning ", stderr );
diff --git a/src/peano.c b/src/peano.c
index 2402440..047b7c8 100644
--- a/src/peano.c
+++ b/src/peano.c
@@ -42,17 +42,17 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
         struct cons_space_object current = pointer2cell( frame->arg[i] );
 
         switch ( current.tag.value ) {
-        case INTEGERTV:
-            i_accumulator += current.payload.integer.value;
-            d_accumulator += numeric_value( frame->arg[i] );
-            break;
-        case REALTV:
-            d_accumulator += current.payload.real.value;
-            is_int = false;
-            break;
-        default:
-            lisp_throw( c_string_to_lisp_string( "Cannot add: not a number" ),
-                        frame );
+            case INTEGERTV:
+                i_accumulator += current.payload.integer.value;
+                d_accumulator += numeric_value( frame->arg[i] );
+                break;
+            case REALTV:
+                d_accumulator += current.payload.real.value;
+                is_int = false;
+                break;
+            default:
+                lisp_throw( c_string_to_lisp_string
+                            ( "Cannot add: not a number" ), frame );
         }
 
         if ( !nilp( frame->more ) ) {
@@ -87,17 +87,17 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
         struct cons_space_object arg = pointer2cell( frame->arg[i] );
 
         switch ( arg.tag.value ) {
-        case INTEGERTV:
-            i_accumulator *= arg.payload.integer.value;
-            d_accumulator *= numeric_value( frame->arg[i] );
-            break;
-        case REALTV:
-            d_accumulator *= arg.payload.real.value;
-            is_int = false;
-            break;
-        default:
-            lisp_throw( c_string_to_lisp_string
-                        ( "Cannot multiply: not a number" ), frame );
+            case INTEGERTV:
+                i_accumulator *= arg.payload.integer.value;
+                d_accumulator *= numeric_value( frame->arg[i] );
+                break;
+            case REALTV:
+                d_accumulator *= arg.payload.real.value;
+                is_int = false;
+                break;
+            default:
+                lisp_throw( c_string_to_lisp_string
+                            ( "Cannot multiply: not a number" ), frame );
         }
 
         if ( !nilp( frame->more ) ) {
diff --git a/src/print.c b/src/print.c
index 1988563..ee5a5b3 100644
--- a/src/print.c
+++ b/src/print.c
@@ -49,19 +49,19 @@ print_list_contents( FILE * output, struct cons_pointer pointer,
     struct cons_space_object *cell = &pointer2cell( pointer );
 
     switch ( cell->tag.value ) {
-    case CONSTV:
-        if ( initial_space ) {
-            fputwc( btowc( ' ' ), output );
-        }
-        print( output, cell->payload.cons.car );
+        case CONSTV:
+            if ( initial_space ) {
+                fputwc( btowc( ' ' ), output );
+            }
+            print( output, cell->payload.cons.car );
 
-        print_list_contents( output, cell->payload.cons.cdr, true );
-        break;
-    case NILTV:
-        break;
-    default:
-        fwprintf( output, L" . " );
-        print( output, pointer );
+            print_list_contents( output, cell->payload.cons.cdr, true );
+            break;
+        case NILTV:
+            break;
+        default:
+            fwprintf( output, L" . " );
+            print( output, pointer );
     }
 }
 
@@ -80,58 +80,58 @@ void print( FILE * output, struct cons_pointer pointer ) {
      * statement can ultimately be replaced by a switch, which will be neater.
      */
     switch ( cell.tag.value ) {
-    case CONSTV:
-        print_list( output, pointer );
-        break;
-    case EXCEPTIONTV:
-        fwprintf( output, L"\nException: " );
-        print_string_contents( output, cell.payload.exception.message );
-        break;
-    case INTEGERTV:
-        fwprintf( output, L"%ld", cell.payload.integer.value );
-        break;
-    case LAMBDATV:
-        fwprintf( output, L"lambda" /* "λ" */  );
-        break;
-    case NILTV:
-        fwprintf( output, L"nil" );
-        break;
-    case REALTV:
-        /* TODO: using the C heap is a bad plan because it will fragment.
-         * As soon as I have working vector space I'll use a special purpose
-         * vector space object */
-        buffer = ( char * ) malloc( 24 );
-        memset( buffer, 0, 24 );
-        /* format it really long, then clear the trailing zeros */
-        sprintf( buffer, "%-.23Lg", cell.payload.real.value );
-        if ( strchr( buffer, '.' ) != NULL ) {
-            for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
-                buffer[i] = '\0';
+        case CONSTV:
+            print_list( output, pointer );
+            break;
+        case EXCEPTIONTV:
+            fwprintf( output, L"\nException: " );
+            print_string_contents( output, cell.payload.exception.message );
+            break;
+        case INTEGERTV:
+            fwprintf( output, L"%ld", cell.payload.integer.value );
+            break;
+        case LAMBDATV:
+            fwprintf( output, L"lambda" /* "λ" */  );
+            break;
+        case NILTV:
+            fwprintf( output, L"nil" );
+            break;
+        case REALTV:
+            /* TODO: using the C heap is a bad plan because it will fragment.
+             * As soon as I have working vector space I'll use a special purpose
+             * vector space object */
+            buffer = ( char * ) malloc( 24 );
+            memset( buffer, 0, 24 );
+            /* format it really long, then clear the trailing zeros */
+            sprintf( buffer, "%-.23Lg", cell.payload.real.value );
+            if ( strchr( buffer, '.' ) != NULL ) {
+                for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
+                    buffer[i] = '\0';
+                }
             }
-        }
-        fwprintf( output, L"%s", buffer );
-        free( buffer );
-        break;
-    case STRINGTV:
-        print_string( output, pointer );
-        break;
-    case SYMBOLTV:
-        print_string_contents( output, pointer );
-        break;
-    case TRUETV:
-        fwprintf( output, L"t" );
-        break;
-    case FUNCTIONTV:
-        fwprintf( output, L"(Function)" );
-        break;
-    case SPECIALTV:
-        fwprintf( output, L"(Special form)" );
-        break;
-    default:
-        fwprintf( stderr,
-                  L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
-                  cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
-                  cell.tag.bytes[2], cell.tag.bytes[3] );
-        break;
+            fwprintf( output, L"%s", buffer );
+            free( buffer );
+            break;
+        case STRINGTV:
+            print_string( output, pointer );
+            break;
+        case SYMBOLTV:
+            print_string_contents( output, pointer );
+            break;
+        case TRUETV:
+            fwprintf( output, L"t" );
+            break;
+        case FUNCTIONTV:
+            fwprintf( output, L"(Function)" );
+            break;
+        case SPECIALTV:
+            fwprintf( output, L"(Special form)" );
+            break;
+        default:
+            fwprintf( stderr,
+                      L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
+                      cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
+                      cell.tag.bytes[2], cell.tag.bytes[3] );
+            break;
     }
 }
diff --git a/src/read.c b/src/read.c
index ad74db6..ff0b51f 100644
--- a/src/read.c
+++ b/src/read.c
@@ -60,40 +60,42 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
           c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
 
     switch ( c ) {
-    case EOF:
-        result = lisp_throw( c_string_to_lisp_string
-                             ( "End of input while reading" ), frame );
-        break;
-    case '\'':
-        result = c_quote( read_continuation( frame, input, fgetwc( input ) ) );
-        break;
-    case '(':
-        result = read_list( frame, input, fgetwc( input ) );
-        break;
-    case '"':
-        result = read_string( input, fgetwc( input ) );
-        break;
-    default:
-        if ( c == '.' ) {
-            wint_t next = fgetwc( input );
-            if ( iswdigit( next ) ) {
-                ungetwc( next, input );
+        case EOF:
+            result = lisp_throw( c_string_to_lisp_string
+                                 ( "End of input while reading" ), frame );
+            break;
+        case '\'':
+            result =
+                c_quote( read_continuation( frame, input, fgetwc( input ) ) );
+            break;
+        case '(':
+            result = read_list( frame, input, fgetwc( input ) );
+            break;
+        case '"':
+            result = read_string( input, fgetwc( input ) );
+            break;
+        default:
+            if ( c == '.' ) {
+                wint_t next = fgetwc( input );
+                if ( iswdigit( next ) ) {
+                    ungetwc( next, input );
+                    result = read_number( input, c );
+                } else if ( iswblank( next ) ) {
+                    /* dotted pair. TODO: this isn't right, we
+                     * really need to backtrack up a level. */
+                    result =
+                        read_continuation( frame, input, fgetwc( input ) );
+                } else {
+                    read_symbol( input, c );
+                }
+            } else if ( iswdigit( c ) ) {
                 result = read_number( input, c );
-            } else if ( iswblank( next ) ) {
-                /* dotted pair. TODO: this isn't right, we
-                 * really need to backtrack up a level. */
-                result = read_continuation( frame, input, fgetwc( input ) );
+            } else if ( iswprint( c ) ) {
+                result = read_symbol( input, c );
             } else {
-                read_symbol( input, c );
+                fwprintf( stderr,
+                          L"Unrecognised start of input character %c\n", c );
             }
-        } else if ( iswdigit( c ) ) {
-            result = read_number( input, c );
-        } else if ( iswprint( c ) ) {
-            result = read_symbol( input, c );
-        } else {
-            fwprintf( stderr, L"Unrecognised start of input character %c\n",
-                      c );
-        }
     }
 
     return result;
@@ -177,15 +179,16 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
     struct cons_pointer result;
 
     switch ( initial ) {
-    case '\0':
-        result = make_string( initial, NIL );
-        break;
-    case '"':
-        result = make_string( '\0', NIL );
-        break;
-    default:
-        result = make_string( initial, read_string( input, fgetwc( input ) ) );
-        break;
+        case '\0':
+            result = make_string( initial, NIL );
+            break;
+        case '"':
+            result = make_string( '\0', NIL );
+            break;
+        default:
+            result =
+                make_string( initial, read_string( input, fgetwc( input ) ) );
+            break;
     }
 
     return result;
@@ -196,37 +199,39 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
     struct cons_pointer result;
 
     switch ( initial ) {
-    case '\0':
-        result = make_symbol( initial, NIL );
-        break;
-    case '"':
-        /*
-         * THIS IS NOT A GOOD IDEA, but is legal
-         */
-        result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
-        break;
-    case ')':
-        /*
-         * unquoted strings may not include right-parenthesis
-         */
-        result = make_symbol( '\0', NIL );
-        /*
-         * push back the character read
-         */
-        ungetwc( initial, input );
-        break;
-    default:
-        if ( iswprint( initial ) && !iswblank( initial ) ) {
+        case '\0':
+            result = make_symbol( initial, NIL );
+            break;
+        case '"':
+            /*
+             * THIS IS NOT A GOOD IDEA, but is legal
+             */
             result =
                 make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
-        } else {
-            result = NIL;
+            break;
+        case ')':
+            /*
+             * unquoted strings may not include right-parenthesis
+             */
+            result = make_symbol( '\0', NIL );
             /*
              * push back the character read
              */
             ungetwc( initial, input );
-        }
-        break;
+            break;
+        default:
+            if ( iswprint( initial ) && !iswblank( initial ) ) {
+                result =
+                    make_symbol( initial,
+                                 read_symbol( input, fgetwc( input ) ) );
+            } else {
+                result = NIL;
+                /*
+                 * push back the character read
+                 */
+                ungetwc( initial, input );
+            }
+            break;
     }
 
     fputws( L"Read symbol '", stderr );

From 7d0b6bec97c49a587312b2b76752c9471c5983d2 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Wed, 12 Dec 2018 11:48:24 +0000
Subject: [PATCH 06/17] Colourised print.

---
 .gitignore            |  8 +++++++
 src/conspage.c        |  9 +++-----
 src/consspaceobject.c |  2 +-
 src/init.c            |  1 +
 src/lispops.c         |  7 ++++---
 src/print.c           | 49 +++++++++++++++++++++++++++++++++++++------
 src/print.h           |  1 +
 7 files changed, 61 insertions(+), 16 deletions(-)

diff --git a/.gitignore b/.gitignore
index 30afce2..6840d19 100644
--- a/.gitignore
+++ b/.gitignore
@@ -20,3 +20,11 @@ post-scarcity\.iml
 doc/
 
 log*
+
+\.cproject
+
+\.gdb_history
+
+\.project
+
+\.settings/language\.settings\.xml
diff --git a/src/conspage.c b/src/conspage.c
index 9845284..a88b62a 100644
--- a/src/conspage.c
+++ b/src/conspage.c
@@ -73,11 +73,9 @@ void make_cons_page(  ) {
                         strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
                         cell->count = MAXREFERENCE;
                         cell->payload.free.car = ( struct cons_pointer ) {
-                            0, 1
-                        };
+                        0, 1};
                         cell->payload.free.cdr = ( struct cons_pointer ) {
-                            0, 1
-                        };
+                        0, 1};
                         fwprintf( stderr, L"Allocated special cell T\n" );
                         break;
                     case 2:
@@ -122,8 +120,7 @@ void dump_pages( FILE * output ) {
 
         for ( int j = 0; j < CONSPAGESIZE; j++ ) {
             dump_object( output, ( struct cons_pointer ) {
-                         i, j
-                         } );
+                         i, j} );
         }
     }
 }
diff --git a/src/consspaceobject.c b/src/consspaceobject.c
index 1b6173f..2d1464e 100644
--- a/src/consspaceobject.c
+++ b/src/consspaceobject.c
@@ -63,7 +63,7 @@ void dec_ref( struct cons_pointer pointer ) {
     }
 }
 
-void dump_string_cell( FILE * output, wchar_t *prefix,
+void dump_string_cell( FILE * output, wchar_t * prefix,
                        struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
     if ( cell.payload.string.character == 0 ) {
diff --git a/src/init.c b/src/init.c
index 8043117..67a5fbb 100644
--- a/src/init.c
+++ b/src/init.c
@@ -53,6 +53,7 @@ int main( int argc, char *argv[] ) {
                 break;
             case 'p':
                 show_prompt = true;
+		print_use_colours = true;
                 break;
             default:
                 fwprintf( stderr, L"Unexpected option %c\n", option );
diff --git a/src/lispops.c b/src/lispops.c
index 9ecd602..9815816 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -114,12 +114,13 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer lexpr,
         struct cons_pointer new_env = env;
     } else {
         char *buffer = malloc( 1024 );
+        struct cons_space_object not_lambda = pointer2cell( should_be_lambda );
         memset( buffer, '\0', 1024 );
         sprintf( buffer,
                  "Expected lambda, but found cell with tag %d (%c%c%c%c)",
-                 fn_cell.tag.value, fn_cell.tag.bytes[0],
-                 fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
-                 fn_cell.tag.bytes[3] );
+                 not_lambda.tag.value, not_lambda.tag.bytes[0],
+                 not_lambda.tag.bytes[1], not_lambda.tag.bytes[2],
+                 not_lambda.tag.bytes[3] );
         struct cons_pointer message = c_string_to_lisp_string( buffer );
         free( buffer );
         result = lisp_throw( message, frame );
diff --git a/src/print.c b/src/print.c
index ee5a5b3..31971a2 100644
--- a/src/print.c
+++ b/src/print.c
@@ -22,6 +22,8 @@
 #include "integer.h"
 #include "print.h"
 
+int print_use_colours = 0;
+
 void print_string_contents( FILE * output, struct cons_pointer pointer ) {
     if ( stringp( pointer ) || symbolp( pointer ) ) {
         struct cons_space_object *cell = &pointer2cell( pointer );
@@ -66,9 +68,19 @@ print_list_contents( FILE * output, struct cons_pointer pointer,
 }
 
 void print_list( FILE * output, struct cons_pointer pointer ) {
-    fputwc( btowc( '(' ), output );
+    if ( print_use_colours ) {
+        fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" );
+    } else {
+        fputws( L"(", output );
+    };
+
     print_list_contents( output, pointer, false );
-    fputwc( btowc( ')' ), output );
+    if ( print_use_colours ) {
+        fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" );
+    } else {
+        fputws( L")", output );
+    }
+
 }
 
 void print( FILE * output, struct cons_pointer pointer ) {
@@ -84,11 +96,19 @@ void print( FILE * output, struct cons_pointer pointer ) {
             print_list( output, pointer );
             break;
         case EXCEPTIONTV:
-            fwprintf( output, L"\nException: " );
+            fwprintf( output, L"\n%sException: ",
+                      print_use_colours ? "\x1B[31m" : "" );
             print_string_contents( output, cell.payload.exception.message );
+            fputws( L"\x1B[39m", output );
             break;
         case INTEGERTV:
-            fwprintf( output, L"%ld", cell.payload.integer.value );
+            if ( print_use_colours ) {
+                fputws( L"\x1B[34m", output );
+            }
+            fwprintf( output, L"%ld%", cell.payload.integer.value );
+            if ( print_use_colours ) {
+                fputws( L"\x1B[39m", output );
+            }
             break;
         case LAMBDATV:
             fwprintf( output, L"lambda" /* "λ" */  );
@@ -109,14 +129,30 @@ void print( FILE * output, struct cons_pointer pointer ) {
                     buffer[i] = '\0';
                 }
             }
+            if ( print_use_colours ) {
+                fputws( L"\x1B[34m", output );
+            }
             fwprintf( output, L"%s", buffer );
+            if ( print_use_colours ) {
+                fputws( L"\x1B[39m", output );
+            }
             free( buffer );
             break;
         case STRINGTV:
+            if ( print_use_colours ) {
+                fputws( L"\x1B[36m", output );
+            }
             print_string( output, pointer );
+            if ( print_use_colours ) {
+                fputws( L"\x1B[39m", output );
+            }
             break;
         case SYMBOLTV:
+            if ( print_use_colours )
+                fputws( L"\x1B[1;33m", output );
             print_string_contents( output, pointer );
+            if ( print_use_colours )
+                fputws( L"\x1B[0;39m", output );
             break;
         case TRUETV:
             fwprintf( output, L"t" );
@@ -129,9 +165,10 @@ void print( FILE * output, struct cons_pointer pointer ) {
             break;
         default:
             fwprintf( stderr,
-                      L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
+                      L"%sError: Unrecognised tag value %d (%c%c%c%c)%s\n",
+                      "\x1B[31m",
                       cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
-                      cell.tag.bytes[2], cell.tag.bytes[3] );
+                      cell.tag.bytes[2], cell.tag.bytes[3], "\x1B[39m" );
             break;
     }
 }
diff --git a/src/print.h b/src/print.h
index a3fb4ab..7ee9c80 100644
--- a/src/print.h
+++ b/src/print.h
@@ -15,5 +15,6 @@
 #define __print_h
 
 void print( FILE * output, struct cons_pointer pointer );
+extern int print_use_colours;
 
 #endif

From 7189c0172caba1967c5d13e4444df2f2015cc484 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Wed, 12 Dec 2018 16:20:16 +0000
Subject: [PATCH 07/17] Much work on the interpreter, but it is getting messy

Going to try something radically different
---
 src/consspaceobject.h | 14 ++++-----
 src/equal.c           |  4 +--
 src/init.c            |  3 +-
 src/lispops.c         | 72 +++++++++++++++++++++++++++++++++----------
 src/lispops.h         | 10 ++++++
 src/print.c           | 26 ++++++++++++++--
 6 files changed, 99 insertions(+), 30 deletions(-)

diff --git a/src/consspaceobject.h b/src/consspaceobject.h
index c17ded5..0b50e07 100644
--- a/src/consspaceobject.h
+++ b/src/consspaceobject.h
@@ -34,6 +34,13 @@
 #define CONSTAG     "CONS"
 #define CONSTV      1397641027
 
+/**
+ * An exception.
+ */
+#define EXCEPTIONTAG "EXEP"
+/* TODO: this is wrong */
+#define EXCEPTIONTV 1346721861
+
 /**
  * An unallocated cell on the free list - should never be encountered by a Lisp
  * function. 1162170950
@@ -117,13 +124,6 @@
 /* TODO: this is wrong */
 #define WRITETV 1414091351
 
-/**
- * An exception.
- */
-#define EXCEPTIONTAG "EXEP"
-/* TODO: this is wrong */
-#define EXCEPTIONTV 1346721861
-
 /**
  * a cons pointer which points to the special NIL cell
  */
diff --git a/src/equal.c b/src/equal.c
index d06903f..ef0b897 100644
--- a/src/equal.c
+++ b/src/equal.c
@@ -78,8 +78,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && ( equal( cell_a->payload.string.cdr,
                                 cell_b->payload.string.cdr )
                          || ( end_of_string( cell_a->payload.string.cdr )
-                              && end_of_string( cell_b->payload.string.
-                                                cdr ) ) );
+                              && end_of_string( cell_b->payload.
+                                                string.cdr ) ) );
                 break;
             case INTEGERTV:
             case REALTV:
diff --git a/src/init.c b/src/init.c
index 67a5fbb..e4a320f 100644
--- a/src/init.c
+++ b/src/init.c
@@ -53,7 +53,7 @@ int main( int argc, char *argv[] ) {
                 break;
             case 'p':
                 show_prompt = true;
-		print_use_colours = true;
+                print_use_colours = true;
                 break;
             default:
                 fwprintf( stderr, L"Unexpected option %c\n", option );
@@ -74,6 +74,7 @@ int main( int argc, char *argv[] ) {
      */
     deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
     deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
+    /* lambda is even more privileged than a special form */
     deep_bind( c_string_to_lisp_symbol( "lambda" ), LAMBDA );
 
     /*
diff --git a/src/lispops.c b/src/lispops.c
index 9815816..ee59c40 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -104,26 +104,53 @@ struct cons_pointer eval_form( struct stack_frame *parent,
  * @param env the environment in which it is to be intepreted.
  */
 struct cons_pointer
-lisp_lambda( struct stack_frame *frame, struct cons_pointer lexpr,
-             struct cons_pointer env ) {
+lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer result = NIL;
+    struct cons_pointer lexpr = frame->arg[0];
     struct cons_pointer should_be_lambda =
         eval_form( frame, c_car( lexpr ), env );
 
+    dump_frame( stderr, frame );
+
     if ( lambdap( should_be_lambda ) ) {
         struct cons_pointer new_env = env;
+        struct cons_pointer args = c_car( c_cdr( lexpr ) );
+        struct cons_pointer body = c_cdr( c_cdr( lexpr ) );
+
+        for ( int i = 1; i < args_in_frame && consp( args ); i++ ) {
+            args = c_cdr( args );
+            struct cons_pointer arg = c_car( args );
+            print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
+            print( stderr, arg );
+            print( stderr, c_string_to_lisp_string( " to " ) );
+            print( stderr, frame->arg[i] );
+
+            new_env = make_cons( make_cons( arg, frame->arg[i] ), new_env );
+        }
+
+        while ( !nilp( body ) ) {
+            struct cons_pointer sexpr = c_car( body );
+            body = c_cdr( body );
+
+            result = eval_form( frame, sexpr, new_env );
+        }
     } else {
-        char *buffer = malloc( 1024 );
-        struct cons_space_object not_lambda = pointer2cell( should_be_lambda );
-        memset( buffer, '\0', 1024 );
-        sprintf( buffer,
-                 "Expected lambda, but found cell with tag %d (%c%c%c%c)",
-                 not_lambda.tag.value, not_lambda.tag.bytes[0],
-                 not_lambda.tag.bytes[1], not_lambda.tag.bytes[2],
-                 not_lambda.tag.bytes[3] );
-        struct cons_pointer message = c_string_to_lisp_string( buffer );
-        free( buffer );
-        result = lisp_throw( message, frame );
+        if ( exceptionp( should_be_lambda ) ) {
+            result = should_be_lambda;
+        } else {
+            char *buffer = malloc( 1024 );
+            struct cons_space_object not_lambda =
+                pointer2cell( should_be_lambda );
+            memset( buffer, '\0', 1024 );
+            sprintf( buffer,
+                     "Expected lambda, but found cell with tag %d (%c%c%c%c)",
+                     not_lambda.tag.value, not_lambda.tag.bytes[0],
+                     not_lambda.tag.bytes[1], not_lambda.tag.bytes[2],
+                     not_lambda.tag.bytes[3] );
+            struct cons_pointer message = c_string_to_lisp_string( buffer );
+            free( buffer );
+            result = lisp_throw( message, frame );
+        }
     }
     return result;
 }
@@ -159,7 +186,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 free_stack_frame( next );
             }
             break;
-
         case FUNCTIONTV:
             {
                 struct stack_frame *next =
@@ -168,12 +194,17 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 free_stack_frame( next );
             }
             break;
-
         case CONSTV:
             {
-                result = lisp_lambda( frame, fn_pointer, env );
+                fwprintf( stdout,
+                          L"Treating cons as lambda expression (apply)\n" );
+                result = lisp_lambda( frame, env );
             }
             break;
+        case EXCEPTIONTV:
+            /* just pass exceptions straight back */
+            result = fn_pointer;
+            break;
         default:
             {
                 char *buffer = malloc( 1024 );
@@ -235,7 +266,14 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
 
     switch ( cell.tag.value ) {
         case CONSTV:
-            result = c_apply( frame, env );
+            print( stderr, frame->arg[0] );
+            if ( lambdap( c_car( frame->arg[0] ) ) ) {
+                fwprintf( stdout,
+                          L"Treating cons as lambda expression (eval)\n" );
+                result = lisp_lambda( frame, env );
+            } else {
+                result = c_apply( frame, env );
+            }
             break;
 
         case SYMBOLTV:
diff --git a/src/lispops.h b/src/lispops.h
index 6fd6e6b..fac1ec0 100644
--- a/src/lispops.h
+++ b/src/lispops.h
@@ -37,6 +37,16 @@ struct cons_pointer lisp_eval( struct stack_frame *frame,
                                struct cons_pointer env );
 struct cons_pointer lisp_apply( struct stack_frame *frame,
                                 struct cons_pointer env );
+                                /**
+ * The Lisp interpreter.
+ *
+ * @param frame the stack frame in which the expression is to be interpreted;
+ * @param lexpr the lambda expression to be interpreted;
+ * @param env the environment in which it is to be intepreted.
+ */
+struct cons_pointer lisp_lambda( struct stack_frame *frame,
+                                 struct cons_pointer env );
+
 struct cons_pointer lisp_quote( struct stack_frame *frame,
                                 struct cons_pointer env );
 
diff --git a/src/print.c b/src/print.c
index 31971a2..d57afc2 100644
--- a/src/print.c
+++ b/src/print.c
@@ -22,20 +22,34 @@
 #include "integer.h"
 #include "print.h"
 
+/**
+ * Whether or not we colorise output.
+ * TODO: this should be a Lisp symbol binding, not a C variable.
+ */
 int print_use_colours = 0;
 
+/**
+ * print all the characters in the symbol or string indicated by `pointer` 
+ * onto this `output`; if `pointer` does not indicate a string or symbol,
+ * don't print anything but just return.
+ */
 void print_string_contents( FILE * output, struct cons_pointer pointer ) {
-    if ( stringp( pointer ) || symbolp( pointer ) ) {
+    while ( stringp( pointer ) || symbolp( pointer ) ) {
         struct cons_space_object *cell = &pointer2cell( pointer );
         wint_t c = cell->payload.string.character;
 
         if ( c != '\0' ) {
             fputwc( c, output );
         }
-        print_string_contents( output, cell->payload.string.cdr );
+        pointer = cell->payload.string.cdr;
     }
 }
 
+/**
+ * print all the characters in the string indicated by `pointer` onto
+ * the stream at this `output`, prepending and appending double quote
+ * characters.
+ */
 void print_string( FILE * output, struct cons_pointer pointer ) {
     fputwc( btowc( '"' ), output );
     print_string_contents( output, pointer );
@@ -43,7 +57,9 @@ void print_string( FILE * output, struct cons_pointer pointer ) {
 }
 
 /**
- * Print a single list cell (cons cell).
+ * Print a single list cell (cons cell) indicated by `pointer` to the
+ * stream indicated by `output`. if `initial_space` is `true`, prepend 
+ * a space character.
  */
 void
 print_list_contents( FILE * output, struct cons_pointer pointer,
@@ -83,6 +99,10 @@ void print_list( FILE * output, struct cons_pointer pointer ) {
 
 }
 
+/**
+ * Print the cons-space object indicated by `pointer` to the stream indicated 
+ * by `output`.
+ */
 void print( FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
     char *buffer;

From 676b2317434c28b81e84e059829c6099ae5f2808 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Wed, 12 Dec 2018 18:49:05 +0000
Subject: [PATCH 08/17] Interpreter working!

---
 src/conspage.c        |  12 +----
 src/consspaceobject.c |  24 ++++++++-
 src/consspaceobject.h |  28 ++++++----
 src/equal.c           |   4 +-
 src/init.c            |   3 +-
 src/lispops.c         | 122 ++++++++++++++++++++----------------------
 src/print.c           |   6 ++-
 7 files changed, 108 insertions(+), 91 deletions(-)

diff --git a/src/conspage.c b/src/conspage.c
index a88b62a..e016c86 100644
--- a/src/conspage.c
+++ b/src/conspage.c
@@ -54,7 +54,7 @@ void make_cons_page(  ) {
         for ( int i = 0; i < CONSPAGESIZE; i++ ) {
             struct cons_space_object *cell =
                 &conspages[initialised_cons_pages]->cell[i];
-            if ( initialised_cons_pages == 0 && i < 3 ) {
+            if ( initialised_cons_pages == 0 && i < 2 ) {
                 switch ( i ) {
                     case 0:
                         /*
@@ -78,16 +78,6 @@ void make_cons_page(  ) {
                         0, 1};
                         fwprintf( stderr, L"Allocated special cell T\n" );
                         break;
-                    case 2:
-                        /*
-                         * initialise cell as λ
-                         */
-                        strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH );
-                        cell->count = MAXREFERENCE;
-                        cell->payload.string.character = ( wint_t ) L'λ';
-                        cell->payload.free.cdr = NIL;
-                        fwprintf( stderr, L"Allocated special cell LAMBDA\n" );
-                        break;
                 }
             } else {
                 /*
diff --git a/src/consspaceobject.c b/src/consspaceobject.c
index 2d1464e..defc56f 100644
--- a/src/consspaceobject.c
+++ b/src/consspaceobject.c
@@ -128,6 +128,12 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
                       L"\t\tInteger cell: value %ld, count %u\n",
                       cell.payload.integer.value, cell.count );
             break;
+        case LAMBDATV:
+            fwprintf( output, L"Lambda cell; args: " );
+            print( output, cell.payload.lambda.args );
+            fwprintf( output, L";\n\t\t\tbody: " );
+            print( output, cell.payload.lambda.args );
+            break;
         case READTV:
             fwprintf( output, L"\t\tInput stream\n" );
         case REALTV:
@@ -152,8 +158,7 @@ struct cons_pointer make_cons( struct cons_pointer car,
 
     pointer = allocate_cell( CONSTAG );
 
-    struct cons_space_object *cell =
-        &conspages[pointer.page]->cell[pointer.offset];
+    struct cons_space_object *cell = &pointer2cell( pointer );
 
     inc_ref( car );
     inc_ref( cdr );
@@ -195,6 +200,21 @@ make_function( struct cons_pointer src, struct cons_pointer ( *executable )
     return pointer;
 }
 
+/**
+ * Construct a lambda (interpretable source) cell
+ */
+struct cons_pointer make_lambda( struct cons_pointer args,
+                                 struct cons_pointer body ) {
+    struct cons_pointer pointer = allocate_cell( LAMBDATAG );
+    struct cons_space_object *cell = &pointer2cell( pointer );
+    inc_ref( args );
+    inc_ref( body );
+    cell->payload.lambda.args = args;
+    cell->payload.lambda.body = body;
+
+    return pointer;
+}
+
 /**
  * Construct a string from this character (which later will be UTF) and
  * this tail. A string is implemented as a flat list of cells each of which
diff --git a/src/consspaceobject.h b/src/consspaceobject.h
index 0b50e07..22b7c18 100644
--- a/src/consspaceobject.h
+++ b/src/consspaceobject.h
@@ -61,8 +61,7 @@
 #define INTEGERTV   1381256777
 
 /**
- * Lambda is very special, and, like NIL and TRUE, we need to identify it
- * quickly and cheaply. So we will give it, too, a special cons cell at {0,2}
+ * A lambda cell.
  */
 #define LAMBDATAG  "LMDA"
 #define LAMBDATV   1094995276
@@ -134,11 +133,6 @@
  */
 #define TRUE (struct cons_pointer){ 0, 1}
 
-/**
- * a cons pointer which points to the special λ cell
- */
-#define LAMBDA (struct cons_pointer){ 0,2}
-
 /**
  * the maximum possible value of a reference count
  */
@@ -173,7 +167,7 @@
 #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG))
 
 /**
- * true if conspointer points to the special Lambda cell, else false
+ * true if conspointer points to a special Lambda cell, else false
  */
 #define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG))
 
@@ -309,11 +303,15 @@ struct integer_payload {
     long int value;
 };
 
+struct lambda_payload {
+    struct cons_pointer args;
+    struct cons_pointer body;
+};
+
 /**
  * payload for a real number cell. Internals of this liable to change to give 128 bits
  * precision, but I'm not sure of the detail.
- */
-struct real_payload {
+ */ struct real_payload {
     long double value;
 };
 
@@ -403,6 +401,10 @@ struct cons_space_object {
          * if tag == INTEGERTAG
          */
         struct integer_payload integer;
+        /*
+         * if tag == LAMBDATAG 
+         */
+        struct lambda_payload lambda;
         /*
          * if tag == NILTAG; we'll treat the special cell NIL as just a cons
          */
@@ -472,6 +474,12 @@ struct cons_pointer make_function( struct cons_pointer src,
                                     ( struct stack_frame *,
                                       struct cons_pointer ) );
 
+/**
+ * Construct a lambda (interpretable source) cell
+ */
+struct cons_pointer make_lambda( struct cons_pointer args,
+                                 struct cons_pointer body );
+
 /**
  * Construct a cell which points to an executable Lisp special form.
  */
diff --git a/src/equal.c b/src/equal.c
index ef0b897..d06903f 100644
--- a/src/equal.c
+++ b/src/equal.c
@@ -78,8 +78,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && ( equal( cell_a->payload.string.cdr,
                                 cell_b->payload.string.cdr )
                          || ( end_of_string( cell_a->payload.string.cdr )
-                              && end_of_string( cell_b->payload.
-                                                string.cdr ) ) );
+                              && end_of_string( cell_b->payload.string.
+                                                cdr ) ) );
                 break;
             case INTEGERTV:
             case REALTV:
diff --git a/src/init.c b/src/init.c
index e4a320f..e782e9a 100644
--- a/src/init.c
+++ b/src/init.c
@@ -74,8 +74,6 @@ int main( int argc, char *argv[] ) {
      */
     deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
     deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
-    /* lambda is even more privileged than a special form */
-    deep_bind( c_string_to_lisp_symbol( "lambda" ), LAMBDA );
 
     /*
      * primitive function operations
@@ -106,6 +104,7 @@ int main( int argc, char *argv[] ) {
      * primitive special forms
      */
     bind_special( "cond", &lisp_cond );
+    bind_special( "lambda", &lisp_lambda );
     bind_special( "quote", &lisp_quote );
 
 
diff --git a/src/lispops.c b/src/lispops.c
index ee59c40..b2f7800 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -100,58 +100,58 @@ struct cons_pointer eval_form( struct stack_frame *parent,
  * The Lisp interpreter.
  *
  * @param frame the stack frame in which the expression is to be interpreted;
- * @param lexpr the lambda expression to be interpreted;
  * @param env the environment in which it is to be intepreted.
  */
 struct cons_pointer
 lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
-    struct cons_pointer result = NIL;
-    struct cons_pointer lexpr = frame->arg[0];
-    struct cons_pointer should_be_lambda =
-        eval_form( frame, c_car( lexpr ), env );
-
     dump_frame( stderr, frame );
+    struct cons_pointer body =
+        !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
 
-    if ( lambdap( should_be_lambda ) ) {
-        struct cons_pointer new_env = env;
-        struct cons_pointer args = c_car( c_cdr( lexpr ) );
-        struct cons_pointer body = c_cdr( c_cdr( lexpr ) );
-
-        for ( int i = 1; i < args_in_frame && consp( args ); i++ ) {
-            args = c_cdr( args );
-            struct cons_pointer arg = c_car( args );
-            print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
-            print( stderr, arg );
-            print( stderr, c_string_to_lisp_string( " to " ) );
-            print( stderr, frame->arg[i] );
-
-            new_env = make_cons( make_cons( arg, frame->arg[i] ), new_env );
+    for ( int i = args_in_frame - 1; i >= 0; i-- ) {
+        if ( !nilp( frame->arg[i] ) ) {
+            body = make_cons( frame->arg[i], body );
         }
 
-        while ( !nilp( body ) ) {
-            struct cons_pointer sexpr = c_car( body );
-            body = c_cdr( body );
-
-            result = eval_form( frame, sexpr, new_env );
-        }
-    } else {
-        if ( exceptionp( should_be_lambda ) ) {
-            result = should_be_lambda;
-        } else {
-            char *buffer = malloc( 1024 );
-            struct cons_space_object not_lambda =
-                pointer2cell( should_be_lambda );
-            memset( buffer, '\0', 1024 );
-            sprintf( buffer,
-                     "Expected lambda, but found cell with tag %d (%c%c%c%c)",
-                     not_lambda.tag.value, not_lambda.tag.bytes[0],
-                     not_lambda.tag.bytes[1], not_lambda.tag.bytes[2],
-                     not_lambda.tag.bytes[3] );
-            struct cons_pointer message = c_string_to_lisp_string( buffer );
-            free( buffer );
-            result = lisp_throw( message, frame );
-        }
     }
+
+    return make_lambda( frame->arg[0], body );
+}
+
+
+struct cons_pointer
+eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
+             struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+    fwprintf( stderr, L"eval_lambda called" );
+
+    struct cons_pointer new_env = env;
+    struct cons_pointer args = cell.payload.lambda.args;
+    struct cons_pointer body = cell.payload.lambda.body;
+    struct cons_pointer vals = frame->arg[0];
+
+    while ( consp( args ) && consp( vals ) ) {
+        struct cons_pointer arg = c_car( args );
+        struct cons_pointer val = c_car( vals );
+        print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
+        print( stderr, arg );
+        print( stderr, c_string_to_lisp_string( " to " ) );
+        print( stderr, val );
+        fputws( L"\"\n", stderr );
+
+        new_env = make_cons( make_cons( arg, val ), new_env );
+        args = c_cdr( args );
+        vals = c_cdr( vals );
+
+    }
+
+    while ( !nilp( body ) ) {
+        struct cons_pointer sexpr = c_car( body );
+        body = c_cdr( body );
+        fputws( L"In lambda: ", stderr );
+        result = eval_form( frame, sexpr, new_env );
+    }
+
     return result;
 }
 
@@ -178,13 +178,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer args = c_cdr( frame->arg[0] );
 
     switch ( fn_cell.tag.value ) {
-        case SPECIALTV:
-            {
-                struct stack_frame *next =
-                    make_special_frame( frame, args, env );
-                result = ( *fn_cell.payload.special.executable ) ( next, env );
-                free_stack_frame( next );
-            }
+        case EXCEPTIONTV:
+            /* just pass exceptions straight back */
+            result = fn_pointer;
             break;
         case FUNCTIONTV:
             {
@@ -194,16 +190,21 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 free_stack_frame( next );
             }
             break;
-        case CONSTV:
+        case LAMBDATV:
             {
-                fwprintf( stdout,
-                          L"Treating cons as lambda expression (apply)\n" );
-                result = lisp_lambda( frame, env );
+                struct stack_frame *next =
+                    make_stack_frame( frame, args, env );
+                result = eval_lambda( fn_cell, next, env );
+                free_stack_frame( next );
             }
             break;
-        case EXCEPTIONTV:
-            /* just pass exceptions straight back */
-            result = fn_pointer;
+        case SPECIALTV:
+            {
+                struct stack_frame *next =
+                    make_special_frame( frame, args, env );
+                result = ( *fn_cell.payload.special.executable ) ( next, env );
+                free_stack_frame( next );
+            }
             break;
         default:
             {
@@ -266,12 +267,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
 
     switch ( cell.tag.value ) {
         case CONSTV:
-            print( stderr, frame->arg[0] );
-            if ( lambdap( c_car( frame->arg[0] ) ) ) {
-                fwprintf( stdout,
-                          L"Treating cons as lambda expression (eval)\n" );
-                result = lisp_lambda( frame, env );
-            } else {
+            {
                 result = c_apply( frame, env );
             }
             break;
diff --git a/src/print.c b/src/print.c
index d57afc2..d6b966a 100644
--- a/src/print.c
+++ b/src/print.c
@@ -131,7 +131,11 @@ void print( FILE * output, struct cons_pointer pointer ) {
             }
             break;
         case LAMBDATV:
-            fwprintf( output, L"lambda" /* "λ" */  );
+            fputws( L"(lambda ", output );
+            print( output, cell.payload.lambda.args );
+            fputws( L" ", output );
+            print( output, cell.payload.lambda.body );
+            fputws( L")", output );
             break;
         case NILTV:
             fwprintf( output, L"nil" );

From 434c17eb0e2cc71d398a60895991e9b88af45cc2 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Wed, 12 Dec 2018 21:12:49 +0000
Subject: [PATCH 09/17] And now the interpreter works (I think) correctly!

---
 src/conspage.c           |  9 ++++++---
 src/consspaceobject.c    |  2 +-
 src/equal.c              |  4 ++--
 src/lispops.c            |  9 ++++-----
 unit-tests/intepreter.sh | 12 ++++++++++++
 5 files changed, 25 insertions(+), 11 deletions(-)
 create mode 100644 unit-tests/intepreter.sh

diff --git a/src/conspage.c b/src/conspage.c
index e016c86..0b13baf 100644
--- a/src/conspage.c
+++ b/src/conspage.c
@@ -73,9 +73,11 @@ void make_cons_page(  ) {
                         strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
                         cell->count = MAXREFERENCE;
                         cell->payload.free.car = ( struct cons_pointer ) {
-                        0, 1};
+                            0, 1
+                        };
                         cell->payload.free.cdr = ( struct cons_pointer ) {
-                        0, 1};
+                            0, 1
+                        };
                         fwprintf( stderr, L"Allocated special cell T\n" );
                         break;
                 }
@@ -110,7 +112,8 @@ void dump_pages( FILE * output ) {
 
         for ( int j = 0; j < CONSPAGESIZE; j++ ) {
             dump_object( output, ( struct cons_pointer ) {
-                         i, j} );
+                         i, j
+                         } );
         }
     }
 }
diff --git a/src/consspaceobject.c b/src/consspaceobject.c
index defc56f..4ecd054 100644
--- a/src/consspaceobject.c
+++ b/src/consspaceobject.c
@@ -63,7 +63,7 @@ void dec_ref( struct cons_pointer pointer ) {
     }
 }
 
-void dump_string_cell( FILE * output, wchar_t * prefix,
+void dump_string_cell( FILE * output, wchar_t *prefix,
                        struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
     if ( cell.payload.string.character == 0 ) {
diff --git a/src/equal.c b/src/equal.c
index d06903f..ef0b897 100644
--- a/src/equal.c
+++ b/src/equal.c
@@ -78,8 +78,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && ( equal( cell_a->payload.string.cdr,
                                 cell_b->payload.string.cdr )
                          || ( end_of_string( cell_a->payload.string.cdr )
-                              && end_of_string( cell_b->payload.string.
-                                                cdr ) ) );
+                              && end_of_string( cell_b->payload.
+                                                string.cdr ) ) );
                 break;
             case INTEGERTV:
             case REALTV:
diff --git a/src/lispops.c b/src/lispops.c
index b2f7800..8529bd9 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -128,11 +128,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
     struct cons_pointer new_env = env;
     struct cons_pointer args = cell.payload.lambda.args;
     struct cons_pointer body = cell.payload.lambda.body;
-    struct cons_pointer vals = frame->arg[0];
 
-    while ( consp( args ) && consp( vals ) ) {
+    for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
         struct cons_pointer arg = c_car( args );
-        struct cons_pointer val = c_car( vals );
+        struct cons_pointer val = frame->arg[i];
         print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
         print( stderr, arg );
         print( stderr, c_string_to_lisp_string( " to " ) );
@@ -141,8 +140,6 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
 
         new_env = make_cons( make_cons( arg, val ), new_env );
         args = c_cdr( args );
-        vals = c_cdr( vals );
-
     }
 
     while ( !nilp( body ) ) {
@@ -194,6 +191,8 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
             {
                 struct stack_frame *next =
                     make_stack_frame( frame, args, env );
+                fputws( L"Stack frame for lambda\n", stderr );
+                dump_frame( stderr, next );
                 result = eval_lambda( fn_cell, next, env );
                 free_stack_frame( next );
             }
diff --git a/unit-tests/intepreter.sh b/unit-tests/intepreter.sh
new file mode 100644
index 0000000..9eb2a06
--- /dev/null
+++ b/unit-tests/intepreter.sh
@@ -0,0 +1,12 @@
+#!/bin/bash
+
+expected='6'
+actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

From 0550b0168ff9141b847111a8b5c8d2b90cd88c13 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Wed, 12 Dec 2018 21:12:49 +0000
Subject: [PATCH 10/17] And now the interpreter works (I think) correctly!

---
 src/conspage.c           |  9 ++++++---
 src/consspaceobject.c    |  6 +++---
 src/init.c               |  5 ++++-
 src/lispops.c            | 37 ++++++++++++++++++++++++++++++++-----
 src/lispops.h            | 24 ++++++++++++++----------
 unit-tests/intepreter.sh | 12 ++++++++++++
 6 files changed, 71 insertions(+), 22 deletions(-)
 create mode 100644 unit-tests/intepreter.sh

diff --git a/src/conspage.c b/src/conspage.c
index e016c86..0b13baf 100644
--- a/src/conspage.c
+++ b/src/conspage.c
@@ -73,9 +73,11 @@ void make_cons_page(  ) {
                         strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
                         cell->count = MAXREFERENCE;
                         cell->payload.free.car = ( struct cons_pointer ) {
-                        0, 1};
+                            0, 1
+                        };
                         cell->payload.free.cdr = ( struct cons_pointer ) {
-                        0, 1};
+                            0, 1
+                        };
                         fwprintf( stderr, L"Allocated special cell T\n" );
                         break;
                 }
@@ -110,7 +112,8 @@ void dump_pages( FILE * output ) {
 
         for ( int j = 0; j < CONSPAGESIZE; j++ ) {
             dump_object( output, ( struct cons_pointer ) {
-                         i, j} );
+                         i, j
+                         } );
         }
     }
 }
diff --git a/src/consspaceobject.c b/src/consspaceobject.c
index defc56f..30bfa83 100644
--- a/src/consspaceobject.c
+++ b/src/consspaceobject.c
@@ -63,7 +63,7 @@ void dec_ref( struct cons_pointer pointer ) {
     }
 }
 
-void dump_string_cell( FILE * output, wchar_t * prefix,
+void dump_string_cell( FILE * output, wchar_t *prefix,
                        struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
     if ( cell.payload.string.character == 0 ) {
@@ -129,10 +129,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
                       cell.payload.integer.value, cell.count );
             break;
         case LAMBDATV:
-            fwprintf( output, L"Lambda cell; args: " );
+            fwprintf( output, L"\t\tLambda cell; args: " );
             print( output, cell.payload.lambda.args );
             fwprintf( output, L";\n\t\t\tbody: " );
-            print( output, cell.payload.lambda.args );
+            print( output, cell.payload.lambda.body );
             break;
         case READTV:
             fwprintf( output, L"\t\tInput stream\n" );
diff --git a/src/init.c b/src/init.c
index e782e9a..9c217c8 100644
--- a/src/init.c
+++ b/src/init.c
@@ -48,12 +48,14 @@ int main( int argc, char *argv[] ) {
 
     while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) {
         switch ( option ) {
+            case 'c':
+                print_use_colours = true;
+                break;
             case 'd':
                 dump_at_end = true;
                 break;
             case 'p':
                 show_prompt = true;
-                print_use_colours = true;
                 break;
             default:
                 fwprintf( stderr, L"Unexpected option %c\n", option );
@@ -106,6 +108,7 @@ int main( int argc, char *argv[] ) {
     bind_special( "cond", &lisp_cond );
     bind_special( "lambda", &lisp_lambda );
     bind_special( "quote", &lisp_quote );
+    bind_special( "set!", &lisp_set_shriek );
 
 
     /* bind the oblist last, at this stage. Something clever needs to be done
diff --git a/src/lispops.c b/src/lispops.c
index b2f7800..945c412 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -128,11 +128,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
     struct cons_pointer new_env = env;
     struct cons_pointer args = cell.payload.lambda.args;
     struct cons_pointer body = cell.payload.lambda.body;
-    struct cons_pointer vals = frame->arg[0];
 
-    while ( consp( args ) && consp( vals ) ) {
+    for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
         struct cons_pointer arg = c_car( args );
-        struct cons_pointer val = c_car( vals );
+        struct cons_pointer val = frame->arg[i];
         print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
         print( stderr, arg );
         print( stderr, c_string_to_lisp_string( " to " ) );
@@ -141,8 +140,6 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
 
         new_env = make_cons( make_cons( arg, val ), new_env );
         args = c_cdr( args );
-        vals = c_cdr( vals );
-
     }
 
     while ( !nilp( body ) ) {
@@ -194,6 +191,8 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
             {
                 struct stack_frame *next =
                     make_stack_frame( frame, args, env );
+                fputws( L"Stack frame for lambda\n", stderr );
+                dump_frame( stderr, next );
                 result = eval_lambda( fn_cell, next, env );
                 free_stack_frame( next );
             }
@@ -283,6 +282,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
                     result = lisp_throw( message, frame );
                 } else {
                     result = c_assoc( canonical, env );
+                    inc_ref( result );
                 }
             }
             break;
@@ -341,6 +341,33 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
     return frame->arg[0];
 }
 
+/**
+ * (set! symbol value)
+ * (set! symbol value namespace)
+ *
+ * Special form.
+ * `namespace` defaults to the oblist.
+ * Binds `symbol` to `value` in the namespace, altering the namespace in so doing.
+ */
+struct cons_pointer
+lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+    struct cons_pointer namespace =
+        nilp( frame->arg[2] ) ? oblist : frame->arg[2];
+
+    if ( symbolp( frame->arg[0] ) ) {
+        deep_bind( frame->arg[0], eval_form( frame, frame->arg[1], env ) );
+        result = frame->arg[1];
+    } else {
+        result =
+            make_exception( c_string_to_lisp_string
+                            ( "The first argument to `set!` is not a symbol" ),
+                            frame );
+    }
+
+    return result;
+}
+
 /**
  * (cons a b)
  *
diff --git a/src/lispops.h b/src/lispops.h
index fac1ec0..dbbf55a 100644
--- a/src/lispops.h
+++ b/src/lispops.h
@@ -31,13 +31,17 @@
 struct cons_pointer c_type( struct cons_pointer pointer );
 
 /*
- * special forms 
+ * special forms
  */
 struct cons_pointer lisp_eval( struct stack_frame *frame,
                                struct cons_pointer env );
 struct cons_pointer lisp_apply( struct stack_frame *frame,
                                 struct cons_pointer env );
-                                /**
+
+struct cons_pointer
+lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
+
+/**
  * The Lisp interpreter.
  *
  * @param frame the stack frame in which the expression is to be interpreted;
@@ -51,7 +55,7 @@ struct cons_pointer lisp_quote( struct stack_frame *frame,
                                 struct cons_pointer env );
 
 /*
- * functions 
+ * functions
  */
 struct cons_pointer lisp_cons( struct stack_frame *frame,
                                struct cons_pointer env );
@@ -80,22 +84,22 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env );
 
 
 /**
- * Function; evaluate the forms which are listed in my single argument 
+ * Function; evaluate the forms which are listed in my single argument
  * sequentially and return the value of the last. This function is called 'do'
  * in some dialects of Lisp.
- * 
+ *
  * @param frame My stack frame.
  * @param env My environment (ignored).
- * @return the value of the last form on the sequence which is my single 
+ * @return the value of the last form on the sequence which is my single
  * argument.
  */
 struct cons_pointer
 lisp_progn( struct stack_frame *frame, struct cons_pointer env );
 
 /**
- * Special form: conditional. Each arg is expected to be a list; if the first 
- * item in such a list evaluates to non-NIL, the remaining items in that list 
- * are evaluated in turn and the value of the last returned. If no arg (clause) 
+ * Special form: conditional. Each arg is expected to be a list; if the first
+ * item in such a list evaluates to non-NIL, the remaining items in that list
+ * are evaluated in turn and the value of the last returned. If no arg (clause)
  * has a first element which evaluates to non NIL, then NIL is returned.
  * @param frame My stack frame.
  * @param env My environment (ignored).
@@ -105,7 +109,7 @@ struct cons_pointer
 lisp_cond( struct stack_frame *frame, struct cons_pointer env );
 
 /*
- * neither, at this stage, really 
+ * neither, at this stage, really
  */
 struct cons_pointer lisp_throw( struct cons_pointer message,
                                 struct stack_frame *frame );
diff --git a/unit-tests/intepreter.sh b/unit-tests/intepreter.sh
new file mode 100644
index 0000000..9eb2a06
--- /dev/null
+++ b/unit-tests/intepreter.sh
@@ -0,0 +1,12 @@
+#!/bin/bash
+
+expected='6'
+actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

From facd5ccc94827a777cc0bd3375507da22f9819a3 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Thu, 13 Dec 2018 17:08:47 +0000
Subject: [PATCH 11/17] Started work on nlambda. It isn't working yet.

---
 lisp/defun.lisp       | 27 ++++++++++++++++++++++++++
 src/consspaceobject.c | 16 ++++++++++++++++
 src/consspaceobject.h | 18 +++++++++++++++++-
 src/init.c            |  1 +
 src/lispops.c         | 44 +++++++++++++++++++++++++++++++------------
 src/lispops.h         | 11 ++++++++++-
 src/print.c           | 19 +++++++++++--------
 src/read.c            |  4 ++++
 8 files changed, 118 insertions(+), 22 deletions(-)
 create mode 100644 lisp/defun.lisp

diff --git a/lisp/defun.lisp b/lisp/defun.lisp
new file mode 100644
index 0000000..4aaeb6d
--- /dev/null
+++ b/lisp/defun.lisp
@@ -0,0 +1,27 @@
+;; Because I don't (yet) have syntax for varargs, the body must be passed
+;; to defun as a list of sexprs.
+(set! defun!
+      (nlambda
+       (name args body)
+       (cond (symbolp name)
+         (set! name (apply lambda (cons args body))))))
+
+(defun! square (x) ((* x x)))
+
+(set! defsp!
+      (nlambda
+       (name args body)
+       (cond (symbolp name)
+         (set! name (nlambda args body)))))
+
+(defsp! cube (x) ((* x x x)))
+
+(set! p 5)
+
+(square 5) ;; should work
+
+(square p) ;; should work
+
+(cube 5) ;; should work
+
+(cube p) ;; should fail: unbound symbol
diff --git a/src/consspaceobject.c b/src/consspaceobject.c
index 30bfa83..6d6a805 100644
--- a/src/consspaceobject.c
+++ b/src/consspaceobject.c
@@ -215,6 +215,22 @@ struct cons_pointer make_lambda( struct cons_pointer args,
     return pointer;
 }
 
+/**
+ * Construct an nlambda (interpretable source) cell; to a
+ * lambda as a special form is to a function.
+ */
+struct cons_pointer make_nlambda( struct cons_pointer args,
+                                 struct cons_pointer body ) {
+    struct cons_pointer pointer = allocate_cell( NLAMBDATAG );
+    struct cons_space_object *cell = &pointer2cell( pointer );
+    inc_ref( args );
+    inc_ref( body );
+    cell->payload.lambda.args = args;
+    cell->payload.lambda.body = body;
+
+    return pointer;
+}
+
 /**
  * Construct a string from this character (which later will be UTF) and
  * this tail. A string is implemented as a flat list of cells each of which
diff --git a/src/consspaceobject.h b/src/consspaceobject.h
index 22b7c18..e6f6f83 100644
--- a/src/consspaceobject.h
+++ b/src/consspaceobject.h
@@ -73,6 +73,12 @@
 #define NILTAG      "NIL "
 #define NILTV       541870414
 
+/**
+ * An nlambda cell.
+ */
+#define NLAMBDATAG  "NLMD"
+#define NLAMBDATV   1145916494
+
 /**
  * An open read stream.
  */
@@ -303,6 +309,9 @@ struct integer_payload {
     long int value;
 };
 
+/**
+ * payload for lambda and nlambda cells
+ */
 struct lambda_payload {
     struct cons_pointer args;
     struct cons_pointer body;
@@ -402,7 +411,7 @@ struct cons_space_object {
          */
         struct integer_payload integer;
         /*
-         * if tag == LAMBDATAG 
+         * if tag == LAMBDATAG or NLAMBDATAG
          */
         struct lambda_payload lambda;
         /*
@@ -481,6 +490,13 @@ struct cons_pointer make_lambda( struct cons_pointer args,
                                  struct cons_pointer body );
 
 /**
+ * Construct an nlambda (interpretable source) cell; to a
+ * lambda as a special form is to a function.
+ */
+struct cons_pointer make_nlambda( struct cons_pointer args,
+                                 struct cons_pointer body );
+
+  /**
  * Construct a cell which points to an executable Lisp special form.
  */
 struct cons_pointer make_special( struct cons_pointer src,
diff --git a/src/init.c b/src/init.c
index 9c217c8..a0b8559 100644
--- a/src/init.c
+++ b/src/init.c
@@ -107,6 +107,7 @@ int main( int argc, char *argv[] ) {
      */
     bind_special( "cond", &lisp_cond );
     bind_special( "lambda", &lisp_lambda );
+    bind_special( "nlambda", &lisp_nlambda );
     bind_special( "quote", &lisp_quote );
     bind_special( "set!", &lisp_set_shriek );
 
diff --git a/src/lispops.c b/src/lispops.c
index 945c412..09704aa 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -96,15 +96,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
     return result;
 }
 
-/**
- * The Lisp interpreter.
- *
- * @param frame the stack frame in which the expression is to be interpreted;
- * @param env the environment in which it is to be intepreted.
- */
-struct cons_pointer
-lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
-    dump_frame( stderr, frame );
+struct cons_pointer compose_body(  struct stack_frame *frame ) {
     struct cons_pointer body =
         !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
 
@@ -112,10 +104,31 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
         if ( !nilp( frame->arg[i] ) ) {
             body = make_cons( frame->arg[i], body );
         }
-
     }
 
-    return make_lambda( frame->arg[0], body );
+  return body;
+}
+
+/**
+ * Construct an interpretable function.
+ *
+ * @param frame the stack frame in which the expression is to be interpreted;
+ * @param env the environment in which it is to be intepreted.
+ */
+struct cons_pointer
+lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
+    return make_lambda( frame->arg[0], compose_body( frame ) );
+}
+
+/**
+ * Construct an interpretable special form.
+ *
+ * @param frame the stack frame in which the expression is to be interpreted;
+ * @param env the environment in which it is to be intepreted.
+ */
+struct cons_pointer
+lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) {
+    return make_nlambda( frame->arg[0], compose_body( frame ) );
 }
 
 
@@ -153,7 +166,6 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
 }
 
 
-
 /**
  * Internal guts of apply.
  * @param frame the stack frame, expected to have only one argument, a list
@@ -197,6 +209,14 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 free_stack_frame( next );
             }
             break;
+        case NLAMBDATV:
+            {
+                struct stack_frame *next =
+                    make_special_frame( frame, args, env );
+                result = ( *fn_cell.payload.special.executable ) ( next, env );
+                free_stack_frame( next );
+            }
+            break;
         case SPECIALTV:
             {
                 struct stack_frame *next =
diff --git a/src/lispops.h b/src/lispops.h
index dbbf55a..6d49b9b 100644
--- a/src/lispops.h
+++ b/src/lispops.h
@@ -42,7 +42,7 @@ struct cons_pointer
 lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
 
 /**
- * The Lisp interpreter.
+ * Construct an interpretable function.
  *
  * @param frame the stack frame in which the expression is to be interpreted;
  * @param lexpr the lambda expression to be interpreted;
@@ -51,6 +51,15 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
 struct cons_pointer lisp_lambda( struct stack_frame *frame,
                                  struct cons_pointer env );
 
+/**
+ * Construct an interpretable special form.
+ *
+ * @param frame the stack frame in which the expression is to be interpreted;
+ * @param env the environment in which it is to be intepreted.
+ */
+struct cons_pointer
+lisp_nlambda( struct stack_frame *frame, struct cons_pointer env );
+
 struct cons_pointer lisp_quote( struct stack_frame *frame,
                                 struct cons_pointer env );
 
diff --git a/src/print.c b/src/print.c
index d6b966a..7957e5e 100644
--- a/src/print.c
+++ b/src/print.c
@@ -29,7 +29,7 @@
 int print_use_colours = 0;
 
 /**
- * print all the characters in the symbol or string indicated by `pointer` 
+ * print all the characters in the symbol or string indicated by `pointer`
  * onto this `output`; if `pointer` does not indicate a string or symbol,
  * don't print anything but just return.
  */
@@ -58,7 +58,7 @@ void print_string( FILE * output, struct cons_pointer pointer ) {
 
 /**
  * Print a single list cell (cons cell) indicated by `pointer` to the
- * stream indicated by `output`. if `initial_space` is `true`, prepend 
+ * stream indicated by `output`. if `initial_space` is `true`, prepend
  * a space character.
  */
 void
@@ -100,7 +100,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) {
 }
 
 /**
- * Print the cons-space object indicated by `pointer` to the stream indicated 
+ * Print the cons-space object indicated by `pointer` to the stream indicated
  * by `output`.
  */
 void print( FILE * output, struct cons_pointer pointer ) {
@@ -131,15 +131,18 @@ void print( FILE * output, struct cons_pointer pointer ) {
             }
             break;
         case LAMBDATV:
-            fputws( L"(lambda ", output );
-            print( output, cell.payload.lambda.args );
-            fputws( L" ", output );
-            print( output, cell.payload.lambda.body );
-            fputws( L")", output );
+            print( output, make_cons( c_string_to_lisp_symbol("lambda"),
+                                     make_cons( cell.payload.lambda.args,
+                                               cell.payload.lambda.body ) ) );
             break;
         case NILTV:
             fwprintf( output, L"nil" );
             break;
+        case NLAMBDATV:
+            print( output, make_cons( c_string_to_lisp_symbol("nlambda"),
+                                     make_cons( cell.payload.lambda.args,
+                                               cell.payload.lambda.body ) ) );
+            break;
         case REALTV:
             /* TODO: using the C heap is a bad plan because it will fragment.
              * As soon as I have working vector space I'll use a special purpose
diff --git a/src/read.c b/src/read.c
index ff0b51f..ef094d5 100644
--- a/src/read.c
+++ b/src/read.c
@@ -60,6 +60,10 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
           c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
 
     switch ( c ) {
+        case ';':
+            for ( c= fgetwc( input ); c != '\n';  c= fgetwc( input ));
+            /* skip all characters from semi-colon to the end of the line */
+            break;
         case EOF:
             result = lisp_throw( c_string_to_lisp_string
                                  ( "End of input while reading" ), frame );

From 11409301da5cce61a818b3978875af04e71d03a1 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Thu, 13 Dec 2018 19:23:44 +0000
Subject: [PATCH 12/17] Tactical commit before trying adventurous change in
 peano

---
 src/conspage.c        |   2 +-
 src/consspaceobject.c |   5 +-
 src/consspaceobject.h |   2 +-
 src/equal.c           |  22 +++++----
 src/lispops.c         | 109 +++++++++++++++++++++++++++++++++++-------
 src/lispops.h         |  33 +++++++++++++
 src/peano.c           |  58 +++++++++++++++++-----
 src/print.c           |  30 +++++-------
 src/read.c            |   2 +-
 src/stack.c           |  21 ++++----
 10 files changed, 215 insertions(+), 69 deletions(-)

diff --git a/src/conspage.c b/src/conspage.c
index 0b13baf..afa8bf4 100644
--- a/src/conspage.c
+++ b/src/conspage.c
@@ -129,7 +129,7 @@ void free_cell( struct cons_pointer pointer ) {
 
     if ( !check_tag( pointer, FREETAG ) ) {
         if ( cell->count == 0 ) {
-            fwprintf( stderr, L"Freeing cell\n" );
+            fwprintf( stderr, L"Freeing cell " );
             dump_object( stderr, pointer );
             strncpy( &cell->tag.bytes[0], FREETAG, 4 );
             cell->payload.free.car = NIL;
diff --git a/src/consspaceobject.c b/src/consspaceobject.c
index 6d6a805..0e8f455 100644
--- a/src/consspaceobject.c
+++ b/src/consspaceobject.c
@@ -92,7 +92,7 @@ void dump_string_cell( FILE * output, wchar_t *prefix,
 void dump_object( FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
     fwprintf( output,
-              L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
+              L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
               cell.tag.bytes[0],
               cell.tag.bytes[1],
               cell.tag.bytes[2],
@@ -112,7 +112,6 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
             fwprintf( output, L"\t\tException cell: " );
             print( output, cell.payload.exception.message );
             fwprintf( output, L"\n" );
-            /* TODO: dump the stack trace */
             for ( struct stack_frame * frame = cell.payload.exception.frame;
                   frame != NULL; frame = frame->previous ) {
                 dump_frame( output, frame );
@@ -220,7 +219,7 @@ struct cons_pointer make_lambda( struct cons_pointer args,
  * lambda as a special form is to a function.
  */
 struct cons_pointer make_nlambda( struct cons_pointer args,
-                                 struct cons_pointer body ) {
+                                  struct cons_pointer body ) {
     struct cons_pointer pointer = allocate_cell( NLAMBDATAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
     inc_ref( args );
diff --git a/src/consspaceobject.h b/src/consspaceobject.h
index e6f6f83..ed5cbd1 100644
--- a/src/consspaceobject.h
+++ b/src/consspaceobject.h
@@ -494,7 +494,7 @@ struct cons_pointer make_lambda( struct cons_pointer args,
  * lambda as a special form is to a function.
  */
 struct cons_pointer make_nlambda( struct cons_pointer args,
-                                 struct cons_pointer body );
+                                  struct cons_pointer body );
 
   /**
  * Construct a cell which points to an executable Lisp special form.
diff --git a/src/equal.c b/src/equal.c
index d06903f..0f0597c 100644
--- a/src/equal.c
+++ b/src/equal.c
@@ -15,7 +15,7 @@
 #include "integer.h"
 
 /**
- * Shallow, and thus cheap, equality: true if these two objects are 
+ * Shallow, and thus cheap, equality: true if these two objects are
  * the same object, else false.
  */
 bool eq( struct cons_pointer a, struct cons_pointer b ) {
@@ -26,7 +26,7 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) {
  * True if the objects at these two cons pointers have the same tag, else false.
  * @param a a pointer to a cons-space object;
  * @param b another pointer to a cons-space object.
- * @return true if the objects at these two cons pointers have the same tag, 
+ * @return true if the objects at these two cons pointers have the same tag,
  * else false.
  */
 bool same_type( struct cons_pointer a, struct cons_pointer b ) {
@@ -60,6 +60,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
 
         switch ( cell_a->tag.value ) {
             case CONSTV:
+            case LAMBDATV:
+            case NLAMBDATV:
                 result =
                     equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
                     && equal( cell_a->payload.cons.cdr,
@@ -70,7 +72,7 @@ bool equal( struct cons_pointer a, struct cons_pointer 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. 
+                 * practice only the empty string will.
                  */
                 result =
                     cell_a->payload.string.character ==
@@ -78,10 +80,14 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && ( equal( cell_a->payload.string.cdr,
                                 cell_b->payload.string.cdr )
                          || ( end_of_string( cell_a->payload.string.cdr )
-                              && end_of_string( cell_b->payload.string.
-                                                cdr ) ) );
+                              && end_of_string( cell_b->payload.
+                                                string.cdr ) ) );
                 break;
             case INTEGERTV:
+                result =
+                    cell_a->payload.integer.value ==
+                    cell_b->payload.integer.value;
+                break;
             case REALTV:
                 {
                     double num_a = numeric_value( a );
@@ -91,7 +97,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                         fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
 
                     /*
-                     * not more different than one part in a million - close enough 
+                     * not more different than one part in a million - close enough
                      */
                     result = fabs( num_a - num_b ) < ( max / 1000000.0 );
                 }
@@ -103,8 +109,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
 
         /*
          * there's only supposed ever to be one T and one NIL cell, so each
-         * should be caught by eq; equality of vector-space objects is a whole 
-         * other ball game so we won't deal with it now (and indeed may never). 
+         * should be caught by eq; equality of vector-space objects is a whole
+         * other ball game so we won't deal with it now (and indeed may never).
          * I'm not certain what equality means for read and write streams, so
          * I'll ignore them, too, for now.
          */
diff --git a/src/lispops.c b/src/lispops.c
index 09704aa..9a62e06 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -91,12 +91,35 @@ struct cons_pointer eval_form( struct stack_frame *parent,
     next->arg[0] = form;
     inc_ref( next->arg[0] );
     result = lisp_eval( next, env );
+
+  if (!exceptionp( result)) {
+    /* if we're returning an exception, we should NOT free the
+     * stack frame. Corollary is, when we free an exception, we
+     * should free all the frames it's holding on to. */
     free_stack_frame( next );
+  }
 
     return result;
 }
 
-struct cons_pointer compose_body(  struct stack_frame *frame ) {
+/**
+ * eval all the forms in this `list` in the context of this stack `frame`
+ * and this `env`, and return a list of their values. If the arg passed as
+ * `list` is not in fact a list, return nil.
+ */
+struct cons_pointer eval_forms( struct stack_frame *frame,
+                                struct cons_pointer list,
+                                struct cons_pointer env ) {
+    return consp( list ) ?
+      make_cons( eval_form( frame, c_car( list ), env ), eval_forms( frame, c_cdr( list), env)) :
+      NIL;
+}
+
+
+/**
+ * used to construct the body for `lambda` and `nlambda` expressions.
+ */
+struct cons_pointer compose_body( struct stack_frame *frame ) {
     struct cons_pointer body =
         !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
 
@@ -106,7 +129,7 @@ struct cons_pointer compose_body(  struct stack_frame *frame ) {
         }
     }
 
-  return body;
+    return body;
 }
 
 /**
@@ -131,7 +154,17 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) {
     return make_nlambda( frame->arg[0], compose_body( frame ) );
 }
 
+void log_binding( struct cons_pointer name, struct cons_pointer val ) {
+    print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
+    print( stderr, name );
+    print( stderr, c_string_to_lisp_string( " to " ) );
+    print( stderr, val );
+    fputws( L"\"\n", stderr );
+}
 
+/**
+ * Evaluate a lambda or nlambda expression.
+ */
 struct cons_pointer
 eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
              struct cons_pointer env ) {
@@ -139,20 +172,36 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
     fwprintf( stderr, L"eval_lambda called" );
 
     struct cons_pointer new_env = env;
-    struct cons_pointer args = cell.payload.lambda.args;
+    struct cons_pointer names = cell.payload.lambda.args;
     struct cons_pointer body = cell.payload.lambda.body;
 
-    for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
-        struct cons_pointer arg = c_car( args );
-        struct cons_pointer val = frame->arg[i];
-        print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
-        print( stderr, arg );
-        print( stderr, c_string_to_lisp_string( " to " ) );
-        print( stderr, val );
-        fputws( L"\"\n", stderr );
+    if ( consp( names ) ) {
+        /* if `names` is a list, bind successive items from that list
+         * to values of arguments */
+        for ( int i = 0; i < args_in_frame && consp( names ); i++ ) {
+            struct cons_pointer name = c_car( names );
+            struct cons_pointer val = frame->arg[i];
 
-        new_env = make_cons( make_cons( arg, val ), new_env );
-        args = c_cdr( args );
+            new_env = bind( name, val, new_env );
+            log_binding( name, val );
+
+            names = c_cdr( names );
+        }
+    } else if ( symbolp( names ) ) {
+        /* if `names` is a symbol, rather than a list of symbols,
+         * then bind a list of the values of args to that symbol. */
+        struct cons_pointer vals = frame->more;
+
+        for ( int i = args_in_frame - 1; i >= 0; i-- ) {
+            struct cons_pointer val = eval_form( frame, frame->arg[i], env );
+
+            if ( nilp( val ) && nilp( vals ) ) {  /* nothing */
+            } else {
+                vals = make_cons( val, vals );
+            }
+        }
+
+        new_env = bind( names, vals, new_env );
     }
 
     while ( !nilp( body ) ) {
@@ -181,7 +230,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
     fn_frame->arg[0] = c_car( frame->arg[0] );
     inc_ref( fn_frame->arg[0] );
     struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
+
+  if (!exceptionp( result)) {
+    /* if we're returning an exception, we should NOT free the
+     * stack frame. Corollary is, when we free an exception, we
+     * should free all the frames it's holding on to. */
     free_stack_frame( fn_frame );
+  }
 
     struct cons_space_object fn_cell = pointer2cell( fn_pointer );
     struct cons_pointer args = c_cdr( frame->arg[0] );
@@ -196,7 +251,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 struct stack_frame *next =
                     make_stack_frame( frame, args, env );
                 result = ( *fn_cell.payload.special.executable ) ( next, env );
-                free_stack_frame( next );
+  if (!exceptionp( result)) {
+    /* if we're returning an exception, we should NOT free the
+     * stack frame. Corollary is, when we free an exception, we
+     * should free all the frames it's holding on to. */
+    free_stack_frame( next );
+  }
             }
             break;
         case LAMBDATV:
@@ -206,7 +266,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 fputws( L"Stack frame for lambda\n", stderr );
                 dump_frame( stderr, next );
                 result = eval_lambda( fn_cell, next, env );
-                free_stack_frame( next );
+  if (!exceptionp( result)) {
+    /* if we're returning an exception, we should NOT free the
+     * stack frame. Corollary is, when we free an exception, we
+     * should free all the frames it's holding on to. */
+    free_stack_frame( next );
+  }
             }
             break;
         case NLAMBDATV:
@@ -214,7 +279,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 struct stack_frame *next =
                     make_special_frame( frame, args, env );
                 result = ( *fn_cell.payload.special.executable ) ( next, env );
-                free_stack_frame( next );
+  if (!exceptionp( result)) {
+    /* if we're returning an exception, we should NOT free the
+     * stack frame. Corollary is, when we free an exception, we
+     * should free all the frames it's holding on to. */
+    free_stack_frame( next );
+  }
             }
             break;
         case SPECIALTV:
@@ -222,7 +292,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 struct stack_frame *next =
                     make_special_frame( frame, args, env );
                 result = ( *fn_cell.payload.special.executable ) ( next, env );
-                free_stack_frame( next );
+  if (!exceptionp( result)) {
+    /* if we're returning an exception, we should NOT free the
+     * stack frame. Corollary is, when we free an exception, we
+     * should free all the frames it's holding on to. */
+    free_stack_frame( next );
+  }
             }
             break;
         default:
diff --git a/src/lispops.h b/src/lispops.h
index 6d49b9b..a0b82cf 100644
--- a/src/lispops.h
+++ b/src/lispops.h
@@ -30,6 +30,39 @@
  */
 struct cons_pointer c_type( struct cons_pointer pointer );
 
+/**
+ * Implementation of car in C. If arg is not a cons, does not error but returns nil.
+ */
+struct cons_pointer c_car( struct cons_pointer arg );
+
+/**
+ * Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
+ */
+struct cons_pointer c_cdr( struct cons_pointer arg );
+
+
+/**
+ * Useful building block; evaluate this single form in the context of this
+ * parent stack frame and this environment.
+ * @param parent the parent stack frame.
+ * @param form the form to be evaluated.
+ * @param env the evaluation environment.
+ * @return the result of evaluating the form.
+ */
+struct cons_pointer eval_form( struct stack_frame *parent,
+                               struct cons_pointer form,
+                               struct cons_pointer env );
+
+/**
+ * eval all the forms in this `list` in the context of this stack `frame`
+ * and this `env`, and return a list of their values. If the arg passed as
+ * `list` is not in fact a list, return nil.
+ */
+struct cons_pointer eval_forms( struct stack_frame *frame,
+                                struct cons_pointer list,
+                                struct cons_pointer env );
+
+
 /*
  * special forms
  */
diff --git a/src/peano.c b/src/peano.c
index 047b7c8..eed1b05 100644
--- a/src/peano.c
+++ b/src/peano.c
@@ -54,19 +54,36 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
                 lisp_throw( c_string_to_lisp_string
                             ( "Cannot add: not a number" ), frame );
         }
+    }
 
-        if ( !nilp( frame->more ) ) {
-            lisp_throw( c_string_to_lisp_string
-                        ( "Cannot yet add more than 8 numbers" ), frame );
-        }
+    struct cons_pointer more = frame->more;
 
-        if ( is_int ) {
-            result = make_integer( i_accumulator );
-        } else {
-            result = make_real( d_accumulator );
+    while ( consp( more ) ) {
+        struct cons_pointer pointer = c_car( more );
+        more = c_cdr( more);
+        struct cons_space_object current = pointer2cell( pointer );
+
+        switch ( current.tag.value ) {
+            case INTEGERTV:
+                i_accumulator += current.payload.integer.value;
+                d_accumulator += numeric_value( pointer );
+                break;
+            case REALTV:
+                d_accumulator += current.payload.real.value;
+                is_int = false;
+                break;
+            default:
+                lisp_throw( c_string_to_lisp_string
+                            ( "Cannot add: not a number" ), frame );
         }
     }
 
+    if ( is_int ) {
+        result = make_integer( i_accumulator );
+    } else {
+        result = make_real( d_accumulator );
+    }
+
     return result;
 }
 
@@ -99,18 +116,35 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
                 lisp_throw( c_string_to_lisp_string
                             ( "Cannot multiply: not a number" ), frame );
         }
+    }
 
-        if ( !nilp( frame->more ) ) {
-            lisp_throw( c_string_to_lisp_string
-                        ( "Cannot yet multiply more than 8 numbers" ), frame );
+    struct cons_pointer more = frame->more;
+
+    while ( consp( more ) ) {
+        struct cons_pointer pointer = c_car( more );
+        more = c_cdr( more);
+        struct cons_space_object current = pointer2cell( pointer );
+
+        switch ( current.tag.value ) {
+            case INTEGERTV:
+                i_accumulator *= current.payload.integer.value;
+                d_accumulator *= numeric_value( pointer );
+                break;
+            case REALTV:
+                d_accumulator *= current.payload.real.value;
+                is_int = false;
+                break;
+            default:
+                lisp_throw( c_string_to_lisp_string
+                            ( "Cannot add: not a number" ), frame );
         }
+    }
 
         if ( is_int ) {
             result = make_integer( i_accumulator );
         } else {
             result = make_real( d_accumulator );
         }
-    }
 
     return result;
 }
diff --git a/src/print.c b/src/print.c
index 7957e5e..b6973b1 100644
--- a/src/print.c
+++ b/src/print.c
@@ -119,29 +119,27 @@ void print( FILE * output, struct cons_pointer pointer ) {
             fwprintf( output, L"\n%sException: ",
                       print_use_colours ? "\x1B[31m" : "" );
             print_string_contents( output, cell.payload.exception.message );
-            fputws( L"\x1B[39m", output );
             break;
         case INTEGERTV:
             if ( print_use_colours ) {
                 fputws( L"\x1B[34m", output );
             }
             fwprintf( output, L"%ld%", cell.payload.integer.value );
-            if ( print_use_colours ) {
-                fputws( L"\x1B[39m", output );
-            }
             break;
         case LAMBDATV:
-            print( output, make_cons( c_string_to_lisp_symbol("lambda"),
-                                     make_cons( cell.payload.lambda.args,
-                                               cell.payload.lambda.body ) ) );
+            print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
+                                      make_cons( cell.payload.lambda.args,
+                                                 cell.payload.lambda.
+                                                 body ) ) );
             break;
         case NILTV:
             fwprintf( output, L"nil" );
             break;
         case NLAMBDATV:
-            print( output, make_cons( c_string_to_lisp_symbol("nlambda"),
-                                     make_cons( cell.payload.lambda.args,
-                                               cell.payload.lambda.body ) ) );
+            print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
+                                      make_cons( cell.payload.lambda.args,
+                                                 cell.payload.lambda.
+                                                 body ) ) );
             break;
         case REALTV:
             /* TODO: using the C heap is a bad plan because it will fragment.
@@ -160,9 +158,6 @@ void print( FILE * output, struct cons_pointer pointer ) {
                 fputws( L"\x1B[34m", output );
             }
             fwprintf( output, L"%s", buffer );
-            if ( print_use_colours ) {
-                fputws( L"\x1B[39m", output );
-            }
             free( buffer );
             break;
         case STRINGTV:
@@ -170,16 +165,11 @@ void print( FILE * output, struct cons_pointer pointer ) {
                 fputws( L"\x1B[36m", output );
             }
             print_string( output, pointer );
-            if ( print_use_colours ) {
-                fputws( L"\x1B[39m", output );
-            }
             break;
         case SYMBOLTV:
             if ( print_use_colours )
                 fputws( L"\x1B[1;33m", output );
             print_string_contents( output, pointer );
-            if ( print_use_colours )
-                fputws( L"\x1B[0;39m", output );
             break;
         case TRUETV:
             fwprintf( output, L"t" );
@@ -198,4 +188,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
                       cell.tag.bytes[2], cell.tag.bytes[3], "\x1B[39m" );
             break;
     }
+
+    if ( print_use_colours ) {
+        fputws( L"\x1B[39m", output );
+    }
 }
diff --git a/src/read.c b/src/read.c
index ef094d5..5d8b78b 100644
--- a/src/read.c
+++ b/src/read.c
@@ -61,7 +61,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
 
     switch ( c ) {
         case ';':
-            for ( c= fgetwc( input ); c != '\n';  c= fgetwc( input ));
+            for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) );
             /* skip all characters from semi-colon to the end of the line */
             break;
         case EOF:
diff --git a/src/stack.c b/src/stack.c
index 2c3aa68..74df15f 100644
--- a/src/stack.c
+++ b/src/stack.c
@@ -98,14 +98,14 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
 
         args = cell.payload.cons.cdr;
     }
-    if ( !nilp( args ) ) {
-        /*
-         * TODO: this isn't right. These args should also each be evaled.
-         */
-        result->more = args;
-        inc_ref( result->more );
+    if ( consp( args ) ) {
+        /* if we still have args, eval them and stick the values on `more` */
+        struct cons_pointer more = eval_forms( previous, args, env );
+        result->more = more;
+        inc_ref( more );
     }
 
+  dump_frame( stderr, result );
     return result;
 }
 
@@ -133,8 +133,10 @@ struct stack_frame *make_special_frame( struct stack_frame *previous,
 
         args = cell.payload.cons.cdr;
     }
-    result->more = args;
-    inc_ref( args );
+    if ( consp( args ) ) {
+        result->more = args;
+        inc_ref( args );
+    }
 
     return result;
 }
@@ -174,6 +176,9 @@ void dump_frame( FILE * output, struct stack_frame *frame ) {
         print( output, frame->arg[arg] );
         fputws( L"\n", output );
     }
+    fputws( L"More: \t", output);
+    print( output, frame->more);
+        fputws( L"\n", output );
 }
 
 

From cec32eff54310f52660d2b6a3b3e5152e589cf22 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Thu, 13 Dec 2018 23:20:34 +0000
Subject: [PATCH 13/17] Progress, but there's something wrong with nlambdas

---
 lisp/defun.lisp         |  15 ++--
 lisp/fact.lisp          |   4 ++
 src/init.c              |   3 +-
 src/lispops.c           | 111 ++++++++++++++++-------------
 src/peano.c             | 150 ++++++++++++++++++++++------------------
 src/print.c             |  15 ++--
 src/read.c              | 130 ++++++++++++++++++----------------
 src/repl.c              |  23 ++++--
 src/stack.c             |   8 +--
 unit-tests/many-args.sh |  13 ++++
 unit-tests/progn.sh     |   4 +-
 unit-tests/varargs.sh   |  16 +++++
 12 files changed, 288 insertions(+), 204 deletions(-)
 create mode 100644 lisp/fact.lisp
 create mode 100644 unit-tests/many-args.sh
 create mode 100644 unit-tests/varargs.sh

diff --git a/lisp/defun.lisp b/lisp/defun.lisp
index 4aaeb6d..83f65c2 100644
--- a/lisp/defun.lisp
+++ b/lisp/defun.lisp
@@ -2,17 +2,18 @@
 ;; to defun as a list of sexprs.
 (set! defun!
       (nlambda
-       (name args body)
-       (cond (symbolp name)
-         (set! name (apply lambda (cons args body))))))
+       form
+       (cond ((symbolp (car form))
+         (set! (car form) (apply lambda (cdr form)))))
+       (t nil)))
 
-(defun! square (x) ((* x x)))
+(defun! square (x) (* x x))
 
 (set! defsp!
       (nlambda
-       (name args body)
-       (cond (symbolp name)
-         (set! name (nlambda args body)))))
+       form
+       (cond (symbolp (car form))
+         (set! (car form) (apply nlambda (cdr form))))))
 
 (defsp! cube (x) ((* x x x)))
 
diff --git a/lisp/fact.lisp b/lisp/fact.lisp
new file mode 100644
index 0000000..b204299
--- /dev/null
+++ b/lisp/fact.lisp
@@ -0,0 +1,4 @@
+(set! fact
+      (lambda (n)
+      (cond ((= n 1) 1)
+        (true (* n (fact (- n 1)))))))
diff --git a/src/init.c b/src/init.c
index a0b8559..b69177d 100644
--- a/src/init.c
+++ b/src/init.c
@@ -46,7 +46,7 @@ int main( int argc, char *argv[] ) {
     bool dump_at_end = false;
     bool show_prompt = false;
 
-    while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) {
+    while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) {
         switch ( option ) {
             case 'c':
                 print_use_colours = true;
@@ -108,6 +108,7 @@ int main( int argc, char *argv[] ) {
     bind_special( "cond", &lisp_cond );
     bind_special( "lambda", &lisp_lambda );
     bind_special( "nlambda", &lisp_nlambda );
+    bind_special( "progn", &lisp_progn );
     bind_special( "quote", &lisp_quote );
     bind_special( "set!", &lisp_set_shriek );
 
diff --git a/src/lispops.c b/src/lispops.c
index 9a62e06..fe71c60 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -92,12 +92,12 @@ struct cons_pointer eval_form( struct stack_frame *parent,
     inc_ref( next->arg[0] );
     result = lisp_eval( next, env );
 
-  if (!exceptionp( result)) {
-    /* if we're returning an exception, we should NOT free the
-     * stack frame. Corollary is, when we free an exception, we
-     * should free all the frames it's holding on to. */
-    free_stack_frame( next );
-  }
+    if ( !exceptionp( result ) ) {
+        /* if we're returning an exception, we should NOT free the
+         * stack frame. Corollary is, when we free an exception, we
+         * should free all the frames it's holding on to. */
+        free_stack_frame( next );
+    }
 
     return result;
 }
@@ -111,8 +111,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
                                 struct cons_pointer list,
                                 struct cons_pointer env ) {
     return consp( list ) ?
-      make_cons( eval_form( frame, c_car( list ), env ), eval_forms( frame, c_cdr( list), env)) :
-      NIL;
+        make_cons( eval_form( frame, c_car( list ), env ),
+                   eval_forms( frame, c_cdr( list ), env ) ) : NIL;
 }
 
 
@@ -231,12 +231,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
     inc_ref( fn_frame->arg[0] );
     struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
 
-  if (!exceptionp( result)) {
-    /* if we're returning an exception, we should NOT free the
-     * stack frame. Corollary is, when we free an exception, we
-     * should free all the frames it's holding on to. */
-    free_stack_frame( fn_frame );
-  }
+    if ( !exceptionp( result ) ) {
+        /* if we're returning an exception, we should NOT free the
+         * stack frame. Corollary is, when we free an exception, we
+         * should free all the frames it's holding on to. */
+        free_stack_frame( fn_frame );
+    }
 
     struct cons_space_object fn_cell = pointer2cell( fn_pointer );
     struct cons_pointer args = c_cdr( frame->arg[0] );
@@ -251,12 +251,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 struct stack_frame *next =
                     make_stack_frame( frame, args, env );
                 result = ( *fn_cell.payload.special.executable ) ( next, env );
-  if (!exceptionp( result)) {
-    /* if we're returning an exception, we should NOT free the
-     * stack frame. Corollary is, when we free an exception, we
-     * should free all the frames it's holding on to. */
-    free_stack_frame( next );
-  }
+                if ( !exceptionp( result ) ) {
+                    /* if we're returning an exception, we should NOT free the
+                     * stack frame. Corollary is, when we free an exception, we
+                     * should free all the frames it's holding on to. */
+                    free_stack_frame( next );
+                }
             }
             break;
         case LAMBDATV:
@@ -266,12 +266,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 fputws( L"Stack frame for lambda\n", stderr );
                 dump_frame( stderr, next );
                 result = eval_lambda( fn_cell, next, env );
-  if (!exceptionp( result)) {
-    /* if we're returning an exception, we should NOT free the
-     * stack frame. Corollary is, when we free an exception, we
-     * should free all the frames it's holding on to. */
-    free_stack_frame( next );
-  }
+                if ( !exceptionp( result ) ) {
+                    /* if we're returning an exception, we should NOT free the
+                     * stack frame. Corollary is, when we free an exception, we
+                     * should free all the frames it's holding on to. */
+                    free_stack_frame( next );
+                }
             }
             break;
         case NLAMBDATV:
@@ -279,12 +279,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 struct stack_frame *next =
                     make_special_frame( frame, args, env );
                 result = ( *fn_cell.payload.special.executable ) ( next, env );
-  if (!exceptionp( result)) {
-    /* if we're returning an exception, we should NOT free the
-     * stack frame. Corollary is, when we free an exception, we
-     * should free all the frames it's holding on to. */
-    free_stack_frame( next );
-  }
+                if ( !exceptionp( result ) ) {
+                    /* if we're returning an exception, we should NOT free the
+                     * stack frame. Corollary is, when we free an exception, we
+                     * should free all the frames it's holding on to. */
+                    free_stack_frame( next );
+                }
             }
             break;
         case SPECIALTV:
@@ -292,12 +292,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 struct stack_frame *next =
                     make_special_frame( frame, args, env );
                 result = ( *fn_cell.payload.special.executable ) ( next, env );
-  if (!exceptionp( result)) {
-    /* if we're returning an exception, we should NOT free the
-     * stack frame. Corollary is, when we free an exception, we
-     * should free all the frames it's holding on to. */
-    free_stack_frame( next );
-  }
+                if ( !exceptionp( result ) ) {
+                    /* if we're returning an exception, we should NOT free the
+                     * stack frame. Corollary is, when we free an exception, we
+                     * should free all the frames it's holding on to. */
+                    free_stack_frame( next );
+                }
             }
             break;
         default:
@@ -382,12 +382,16 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
             }
             break;
             /*
+             * TODO:
              * the Clojure practice of having a map serve in the function place of
              * an s-expression is a good one and I should adopt it; also if the
              * object is a consp it could be interpretable source code but in the
              * long run I don't want an interpreter, and if I can get away without
              * so much the better.
              */
+        default:
+            result = frame->arg[0];
+            break;
     }
 
     fputws( L"Eval returning ", stderr );
@@ -616,7 +620,9 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
 
 
 /**
- * Function; evaluate the forms which are listed in my single argument
+ * (progn forms...)
+ *
+ * Special form; evaluate the forms which are listed in my arguments
  * sequentially and return the value of the last. This function is called 'do'
  * in some dialects of Lisp.
  *
@@ -627,14 +633,17 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
  */
 struct cons_pointer
 lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
-    struct cons_pointer remaining = frame->arg[0];
+    struct cons_pointer remaining = frame->more;
     struct cons_pointer result = NIL;
 
-    while ( consp( remaining ) ) {
-        struct cons_space_object cell = pointer2cell( remaining );
-        result = eval_form( frame, cell.payload.cons.car, env );
+    for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
+        result = eval_form( frame, frame->arg[i], env );
+    }
 
-        remaining = cell.payload.cons.cdr;
+    while ( consp( remaining ) ) {
+        result = eval_form( frame, c_car( remaining ), env );
+
+        remaining = c_cdr( remaining );
     }
 
     return result;
@@ -661,12 +670,16 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
 
         if ( consp( clause_pointer ) ) {
             struct cons_space_object cell = pointer2cell( clause_pointer );
+          result = eval_form( frame, c_car( clause_pointer ), env);
+
+            if ( !nilp( result ) ) {
+                struct cons_pointer vals = eval_forms( frame, c_cdr( clause_pointer ), env );
+
+              while (consp( vals)) {
+                result = c_car(vals);
+                vals = c_cdr(vals);
+              }
 
-            if ( !nilp( eval_form( frame, cell.payload.cons.car, env ) ) ) {
-                struct stack_frame *next = make_empty_frame( frame, env );
-                next->arg[0] = cell.payload.cons.cdr;
-                inc_ref( next->arg[0] );
-                result = lisp_progn( next, env );
                 done = true;
             }
         } else if ( nilp( clause_pointer ) ) {
diff --git a/src/peano.c b/src/peano.c
index eed1b05..691c95f 100644
--- a/src/peano.c
+++ b/src/peano.c
@@ -25,6 +25,36 @@
 #include "real.h"
 #include "stack.h"
 
+/**
+ * Internal guts of add. Dark and mysterious.
+ */
+struct cons_pointer add_accumulate( struct cons_pointer arg,
+                                    struct stack_frame *frame,
+                                    long int *i_accumulator,
+                                    long double *d_accumulator, int *is_int ) {
+    struct cons_pointer result = NIL;
+    struct cons_space_object cell = pointer2cell( arg );
+
+    switch ( cell.tag.value ) {
+        case INTEGERTV:
+            ( *i_accumulator ) += cell.payload.integer.value;
+            ( *d_accumulator ) += numeric_value( arg );
+            break;
+        case REALTV:
+            ( *d_accumulator ) += cell.payload.real.value;
+            ( *is_int ) &= false;
+            break;
+        case EXCEPTIONTV:
+            result = arg;
+            break;
+        default:
+            result = lisp_throw( c_string_to_lisp_string
+                                 ( "Cannot multiply: not a number" ), frame );
+    }
+    return result;
+}
+
+
 /**
  * Add an indefinite number of numbers together
  * @param env the evaluation environment - ignored;
@@ -36,46 +66,21 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer result = NIL;
     long int i_accumulator = 0;
     long double d_accumulator = 0;
-    bool is_int = true;
+    int is_int = true;
 
     for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
-        struct cons_space_object current = pointer2cell( frame->arg[i] );
-
-        switch ( current.tag.value ) {
-            case INTEGERTV:
-                i_accumulator += current.payload.integer.value;
-                d_accumulator += numeric_value( frame->arg[i] );
-                break;
-            case REALTV:
-                d_accumulator += current.payload.real.value;
-                is_int = false;
-                break;
-            default:
-                lisp_throw( c_string_to_lisp_string
-                            ( "Cannot add: not a number" ), frame );
-        }
+        result =
+            add_accumulate( frame->arg[i], frame, &i_accumulator,
+                            &d_accumulator, &is_int );
     }
 
     struct cons_pointer more = frame->more;
 
     while ( consp( more ) ) {
-        struct cons_pointer pointer = c_car( more );
-        more = c_cdr( more);
-        struct cons_space_object current = pointer2cell( pointer );
-
-        switch ( current.tag.value ) {
-            case INTEGERTV:
-                i_accumulator += current.payload.integer.value;
-                d_accumulator += numeric_value( pointer );
-                break;
-            case REALTV:
-                d_accumulator += current.payload.real.value;
-                is_int = false;
-                break;
-            default:
-                lisp_throw( c_string_to_lisp_string
-                            ( "Cannot add: not a number" ), frame );
-        }
+        result =
+            add_accumulate( c_car( more ), frame, &i_accumulator,
+                            &d_accumulator, &is_int );
+        more = c_cdr( more );
     }
 
     if ( is_int ) {
@@ -87,6 +92,36 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
     return result;
 }
 
+/**
+ * Internal guts of multiply. Dark and mysterious.
+ */
+struct cons_pointer multiply_accumulate( struct cons_pointer arg,
+                                         struct stack_frame *frame,
+                                         long int *i_accumulator,
+                                         long double *d_accumulator,
+                                         int *is_int ) {
+    struct cons_pointer result = NIL;
+    struct cons_space_object cell = pointer2cell( arg );
+
+    switch ( cell.tag.value ) {
+        case INTEGERTV:
+            ( *i_accumulator ) *= cell.payload.integer.value;
+            ( *d_accumulator ) *= numeric_value( arg );
+            break;
+        case REALTV:
+            ( *d_accumulator ) *= cell.payload.real.value;
+            ( *is_int ) &= false;
+            break;
+        case EXCEPTIONTV:
+            result = arg;
+            break;
+        default:
+            result = lisp_throw( c_string_to_lisp_string
+                                 ( "Cannot multiply: not a number" ), frame );
+    }
+    return result;
+}
+
 /**
  * Multiply an indefinite number of numbers together
  * @param env the evaluation environment - ignored;
@@ -98,53 +133,32 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer result = NIL;
     long int i_accumulator = 1;
     long double d_accumulator = 1;
-    bool is_int = true;
+    int is_int = true;
 
-    for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
-        struct cons_space_object arg = pointer2cell( frame->arg[i] );
-
-        switch ( arg.tag.value ) {
-            case INTEGERTV:
-                i_accumulator *= arg.payload.integer.value;
-                d_accumulator *= numeric_value( frame->arg[i] );
-                break;
-            case REALTV:
-                d_accumulator *= arg.payload.real.value;
-                is_int = false;
-                break;
-            default:
-                lisp_throw( c_string_to_lisp_string
-                            ( "Cannot multiply: not a number" ), frame );
-        }
+    for ( int i = 0;
+          i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result );
+          i++ ) {
+        result =
+            multiply_accumulate( frame->arg[i], frame, &i_accumulator,
+                                 &d_accumulator, &is_int );
     }
 
     struct cons_pointer more = frame->more;
 
-    while ( consp( more ) ) {
-        struct cons_pointer pointer = c_car( more );
-        more = c_cdr( more);
-        struct cons_space_object current = pointer2cell( pointer );
-
-        switch ( current.tag.value ) {
-            case INTEGERTV:
-                i_accumulator *= current.payload.integer.value;
-                d_accumulator *= numeric_value( pointer );
-                break;
-            case REALTV:
-                d_accumulator *= current.payload.real.value;
-                is_int = false;
-                break;
-            default:
-                lisp_throw( c_string_to_lisp_string
-                            ( "Cannot add: not a number" ), frame );
-        }
+    while ( consp( more ) && !exceptionp( result ) ) {
+        result =
+            multiply_accumulate( c_car( more ), frame, &i_accumulator,
+                                 &d_accumulator, &is_int );
+        more = c_cdr( more );
     }
 
+    if ( !exceptionp( result ) ) {
         if ( is_int ) {
             result = make_integer( i_accumulator );
         } else {
             result = make_real( d_accumulator );
         }
+    }
 
     return result;
 }
diff --git a/src/print.c b/src/print.c
index b6973b1..e3002f8 100644
--- a/src/print.c
+++ b/src/print.c
@@ -120,6 +120,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
                       print_use_colours ? "\x1B[31m" : "" );
             print_string_contents( output, cell.payload.exception.message );
             break;
+        case FUNCTIONTV:
+            fwprintf( output, L"(Function)" );
+            break;
         case INTEGERTV:
             if ( print_use_colours ) {
                 fputws( L"\x1B[34m", output );
@@ -141,6 +144,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
                                                  cell.payload.lambda.
                                                  body ) ) );
             break;
+        case READTV:
+            fwprintf( output, L"(Input stream)" );
+            break;
         case REALTV:
             /* TODO: using the C heap is a bad plan because it will fragment.
              * As soon as I have working vector space I'll use a special purpose
@@ -171,15 +177,12 @@ void print( FILE * output, struct cons_pointer pointer ) {
                 fputws( L"\x1B[1;33m", output );
             print_string_contents( output, pointer );
             break;
-        case TRUETV:
-            fwprintf( output, L"t" );
-            break;
-        case FUNCTIONTV:
-            fwprintf( output, L"(Function)" );
-            break;
         case SPECIALTV:
             fwprintf( output, L"(Special form)" );
             break;
+        case TRUETV:
+            fwprintf( output, L"t" );
+            break;
         default:
             fwprintf( stderr,
                       L"%sError: Unrecognised tag value %d (%c%c%c%c)%s\n",
diff --git a/src/read.c b/src/read.c
index 5d8b78b..3bee19f 100644
--- a/src/read.c
+++ b/src/read.c
@@ -59,47 +59,59 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
     for ( c = initial;
           c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
 
-    switch ( c ) {
-        case ';':
-            for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) );
-            /* skip all characters from semi-colon to the end of the line */
-            break;
-        case EOF:
-            result = lisp_throw( c_string_to_lisp_string
-                                 ( "End of input while reading" ), frame );
-            break;
-        case '\'':
-            result =
-                c_quote( read_continuation( frame, input, fgetwc( input ) ) );
-            break;
-        case '(':
-            result = read_list( frame, input, fgetwc( input ) );
-            break;
-        case '"':
-            result = read_string( input, fgetwc( input ) );
-            break;
-        default:
-            if ( c == '.' ) {
-                wint_t next = fgetwc( input );
-                if ( iswdigit( next ) ) {
-                    ungetwc( next, input );
-                    result = read_number( input, c );
-                } else if ( iswblank( next ) ) {
-                    /* dotted pair. TODO: this isn't right, we
-                     * really need to backtrack up a level. */
-                    result =
-                        read_continuation( frame, input, fgetwc( input ) );
-                } else {
-                    read_symbol( input, c );
+    if ( feof( input ) ) {
+        result =
+            make_exception( c_string_to_lisp_string
+                            ( "End of file while reading" ), frame );
+    } else {
+        switch ( c ) {
+            case ';':
+                for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) );
+                /* skip all characters from semi-colon to the end of the line */
+                break;
+            case EOF:
+                result = lisp_throw( c_string_to_lisp_string
+                                     ( "End of input while reading" ), frame );
+                break;
+            case '\'':
+                result =
+                    c_quote( read_continuation
+                             ( frame, input, fgetwc( input ) ) );
+                break;
+            case '(':
+                result = read_list( frame, input, fgetwc( input ) );
+                break;
+            case '"':
+                result = read_string( input, fgetwc( input ) );
+                break;
+            case '.':
+                {
+                    wint_t next = fgetwc( input );
+                    if ( iswdigit( next ) ) {
+                        ungetwc( next, input );
+                        result = read_number( input, c );
+                    } else if ( iswblank( next ) ) {
+                        /* dotted pair. TODO: this isn't right, we
+                         * really need to backtrack up a level. */
+                        result =
+                            read_continuation( frame, input, fgetwc( input ) );
+                    } else {
+                        read_symbol( input, c );
+                    }
                 }
-            } else if ( iswdigit( c ) ) {
-                result = read_number( input, c );
-            } else if ( iswprint( c ) ) {
-                result = read_symbol( input, c );
-            } else {
-                fwprintf( stderr,
-                          L"Unrecognised start of input character %c\n", c );
-            }
+                break;
+            default:
+                if ( iswdigit( c ) ) {
+                    result = read_number( input, c );
+                } else if ( iswprint( c ) ) {
+                    result = read_symbol( input, c );
+                } else {
+                    result =
+                        make_exception( c_string_to_lisp_string
+                                        ( "Unrecognised start of input character" ),
+                                        frame );
+                }
+        }
     }
 
     return result;
@@ -114,19 +126,16 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
     int places_of_decimals = 0;
     bool seen_period = false;
     wint_t c;
-
     fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
-
-    for ( c = initial; iswdigit( c ) || c == btowc( '.' );
-          c = fgetwc( input ) ) {
+    for ( c = initial; iswdigit( c )
+          || c == btowc( '.' ); c = fgetwc( input ) ) {
         if ( c == btowc( '.' ) ) {
             seen_period = true;
         } else {
             accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
-
-            fwprintf( stderr, L"Added character %c, accumulator now %ld\n", c,
-                      accumulator );
-
+            fwprintf( stderr,
+                      L"Added character %c, accumulator now %ld\n",
+                      c, accumulator );
             if ( seen_period ) {
                 places_of_decimals++;
             }
@@ -137,11 +146,9 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
      * push back the character read which was not a digit
      */
     ungetwc( c, input );
-
     if ( seen_period ) {
         long double rv = ( long double )
             ( accumulator / pow( 10, places_of_decimals ) );
-
         fwprintf( stderr, L"read_numer returning %Lf\n", rv );
         result = make_real( rv );
     } else {
@@ -155,14 +162,15 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
  * Read a list from this input stream, which no longer contains the opening
  * left parenthesis.
  */
-struct cons_pointer read_list( struct stack_frame *frame, FILE * input,
-                               wint_t initial ) {
+struct cons_pointer read_list( struct
+                               stack_frame
+                               *frame, FILE * input, wint_t initial ) {
     struct cons_pointer result = NIL;
-
     if ( initial != ')' ) {
-        fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial,
-                  initial );
-        struct cons_pointer car = read_continuation( frame, input, initial );
+        fwprintf( stderr,
+                  L"read_list starting '%C' (%d)\n", initial, initial );
+        struct cons_pointer car = read_continuation( frame, input,
+                                                     initial );
         result = make_cons( car, read_list( frame, input, fgetwc( input ) ) );
     } else {
         fwprintf( stderr, L"End of list detected\n" );
@@ -181,7 +189,6 @@ struct cons_pointer read_list( struct stack_frame *frame, FILE * input,
 struct cons_pointer read_string( FILE * input, wint_t initial ) {
     struct cons_pointer cdr = NIL;
     struct cons_pointer result;
-
     switch ( initial ) {
         case '\0':
             result = make_string( initial, NIL );
@@ -201,7 +208,6 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
 struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
     struct cons_pointer cdr = NIL;
     struct cons_pointer result;
-
     switch ( initial ) {
         case '\0':
             result = make_symbol( initial, NIL );
@@ -224,7 +230,8 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
             ungetwc( initial, input );
             break;
         default:
-            if ( iswprint( initial ) && !iswblank( initial ) ) {
+            if ( iswprint( initial )
+                 && !iswblank( initial ) ) {
                 result =
                     make_symbol( initial,
                                  read_symbol( input, fgetwc( input ) ) );
@@ -241,13 +248,14 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
     fputws( L"Read symbol '", stderr );
     print( stderr, result );
     fputws( L"'\n", stderr );
-
     return result;
 }
 
 /**
  * Read the next object on this input stream and return a cons_pointer to it.
  */
-struct cons_pointer read( struct stack_frame *frame, FILE * input ) {
+struct cons_pointer read( struct
+                          stack_frame
+                          *frame, FILE * input ) {
     return read_continuation( frame, input, fgetwc( input ) );
 }
diff --git a/src/repl.c b/src/repl.c
index a11e511..596cb61 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -48,7 +48,10 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
 
     frame->arg[0] = input;
     struct cons_pointer result = lisp_eval( frame, oblist );
-    free_stack_frame( frame );
+
+    if ( !exceptionp( result ) ) {
+        free_stack_frame( frame );
+    }
 
     return result;
 }
@@ -86,12 +89,20 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
             fwprintf( out_stream, L"\n:: " );
         }
 
-        struct cons_pointer val = repl_eval( repl_read( input_stream ) );
+        struct cons_pointer input = repl_read( input_stream );
 
-        /* suppress the 'end of stream' exception */
-        if ( !exceptionp( val ) &&
-             !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
-            repl_print( output_stream, val );
+        if ( exceptionp( input ) ) {
+            break;
+        } else {
+
+            struct cons_pointer val = repl_eval( input );
+
+            /* suppress the 'end of stream' exception */
+            if ( !exceptionp( val ) &&
+                 !feof( pointer2cell( input_stream ).payload.stream.
+                        stream ) ) {
+                repl_print( output_stream, val );
+            }
         }
     }
 }
diff --git a/src/stack.c b/src/stack.c
index 74df15f..ea1f911 100644
--- a/src/stack.c
+++ b/src/stack.c
@@ -105,7 +105,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
         inc_ref( more );
     }
 
-  dump_frame( stderr, result );
+    dump_frame( stderr, result );
     return result;
 }
 
@@ -176,9 +176,9 @@ void dump_frame( FILE * output, struct stack_frame *frame ) {
         print( output, frame->arg[arg] );
         fputws( L"\n", output );
     }
-    fputws( L"More: \t", output);
-    print( output, frame->more);
-        fputws( L"\n", output );
+    fputws( L"More: \t", output );
+    print( output, frame->more );
+    fputws( L"\n", output );
 }
 
 
diff --git a/unit-tests/many-args.sh b/unit-tests/many-args.sh
new file mode 100644
index 0000000..2db2318
--- /dev/null
+++ b/unit-tests/many-args.sh
@@ -0,0 +1,13 @@
+#!/bin/bash
+
+expected="120"
+actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    exit 0
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh
index 94c7f40..017646b 100644
--- a/unit-tests/progn.sh
+++ b/unit-tests/progn.sh
@@ -1,7 +1,7 @@
 #!/bin/bash
 
 expected='5'
-actual=`echo "(progn '((add 2 3)))" | target/psse 2> /dev/null | head -2 | tail -1`
+actual=`echo "(progn (add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "${expected}" = "${actual}" ]
 then
@@ -12,7 +12,7 @@ else
 fi
 
 expected='"foo"'
-actual=`echo "(progn '((add 2.5 3) \"foo\"))" | target/psse 2> /dev/null | head -2 | tail -1`
+actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "${expected}" = "${actual}" ]
 then
diff --git a/unit-tests/varargs.sh b/unit-tests/varargs.sh
new file mode 100644
index 0000000..6c31163
--- /dev/null
+++ b/unit-tests/varargs.sh
@@ -0,0 +1,16 @@
+#!/bin/bash
+
+expected='(lambda l l)(1 2 3 4 5 6 7 8 9 10)'
+actual=`target/psse 2>/dev/null <<EOF
+(set! list (lambda l l))
+(list 1 2 3 4 5 6 7 8 9 10)
+EOF`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    exit 0
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

From 637d78fb1b24a9ab8f20908f92f0c395ce5c3674 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Tue, 18 Dec 2018 21:10:03 +0000
Subject: [PATCH 14/17] Much work, all I think positive, but defun still
 doesn't work.

---
 lisp/defun.lisp       |  4 +-
 src/conspage.c        | 27 +++++++++++++
 src/consspaceobject.c |  9 +++++
 src/equal.c           |  4 +-
 src/init.c            |  7 +---
 src/intern.c          | 15 ++++---
 src/lispops.c         | 92 +++++++++++++++++++++++++++++++++++--------
 src/lispops.h         |  6 +++
 src/print.c           | 17 ++++----
 src/repl.c            | 10 +++--
 src/stack.c           |  5 ++-
 unit-tests/lambda.sh  | 16 ++++++++
 12 files changed, 164 insertions(+), 48 deletions(-)
 create mode 100644 unit-tests/lambda.sh

diff --git a/lisp/defun.lisp b/lisp/defun.lisp
index 83f65c2..e86df35 100644
--- a/lisp/defun.lisp
+++ b/lisp/defun.lisp
@@ -4,8 +4,8 @@
       (nlambda
        form
        (cond ((symbolp (car form))
-         (set! (car form) (apply lambda (cdr form)))))
-       (t nil)))
+         (set (car form) (apply lambda (cdr form))))
+         (t nil))))
 
 (defun! square (x) (* x x))
 
diff --git a/src/conspage.c b/src/conspage.c
index afa8bf4..ad83680 100644
--- a/src/conspage.c
+++ b/src/conspage.c
@@ -127,6 +127,33 @@ void dump_pages( FILE * output ) {
 void free_cell( struct cons_pointer pointer ) {
     struct cons_space_object *cell = &pointer2cell( pointer );
 
+    switch ( cell->tag.value ) {
+            /* for all the types of cons-space object which point to other
+             * cons-space objects, cascade the decrement. */
+        case CONSTV:
+            dec_ref( cell->payload.cons.car );
+            dec_ref( cell->payload.cons.cdr );
+            break;
+        case EXCEPTIONTV:
+            dec_ref( cell->payload.exception.message );
+            break;
+        case FUNCTIONTV:
+            dec_ref( cell->payload.function.source );
+            break;
+        case LAMBDATV:
+        case NLAMBDATV:
+            dec_ref( cell->payload.lambda.args );
+            dec_ref( cell->payload.lambda.body );
+            break;
+        case SPECIALTV:
+            dec_ref( cell->payload.special.source );
+            break;
+        case STRINGTV:
+        case SYMBOLTV:
+            dec_ref( cell->payload.string.cdr );
+            break;
+    }
+
     if ( !check_tag( pointer, FREETAG ) ) {
         if ( cell->count == 0 ) {
             fwprintf( stderr, L"Freeing cell " );
diff --git a/src/consspaceobject.c b/src/consspaceobject.c
index 0e8f455..0fe28e3 100644
--- a/src/consspaceobject.c
+++ b/src/consspaceobject.c
@@ -177,6 +177,9 @@ struct cons_pointer make_exception( struct cons_pointer message,
     struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
+    inc_ref( pointer );         /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
+
+    inc_ref( message );
     cell->payload.exception.message = message;
     cell->payload.exception.frame = frame;
 
@@ -206,6 +209,9 @@ struct cons_pointer make_lambda( struct cons_pointer args,
                                  struct cons_pointer body ) {
     struct cons_pointer pointer = allocate_cell( LAMBDATAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
+
+    inc_ref( pointer );         /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
+
     inc_ref( args );
     inc_ref( body );
     cell->payload.lambda.args = args;
@@ -221,6 +227,9 @@ struct cons_pointer make_lambda( struct cons_pointer args,
 struct cons_pointer make_nlambda( struct cons_pointer args,
                                   struct cons_pointer body ) {
     struct cons_pointer pointer = allocate_cell( NLAMBDATAG );
+
+    inc_ref( pointer );         /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
+
     struct cons_space_object *cell = &pointer2cell( pointer );
     inc_ref( args );
     inc_ref( body );
diff --git a/src/equal.c b/src/equal.c
index 0f0597c..ebb085e 100644
--- a/src/equal.c
+++ b/src/equal.c
@@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && ( equal( cell_a->payload.string.cdr,
                                 cell_b->payload.string.cdr )
                          || ( end_of_string( cell_a->payload.string.cdr )
-                              && end_of_string( cell_b->payload.
-                                                string.cdr ) ) );
+                              && end_of_string( cell_b->payload.string.
+                                                cdr ) ) );
                 break;
             case INTEGERTV:
                 result =
diff --git a/src/init.c b/src/init.c
index b69177d..70e2499 100644
--- a/src/init.c
+++ b/src/init.c
@@ -92,8 +92,10 @@ int main( int argc, char *argv[] ) {
     bind_function( "eval", &lisp_eval );
     bind_function( "multiply", &lisp_multiply );
     bind_function( "read", &lisp_read );
+    bind_function( "oblist", &lisp_oblist );
     bind_function( "print", &lisp_print );
     bind_function( "progn", &lisp_progn );
+    bind_function( "set", &lisp_set );
     bind_function( "subtract", &lisp_subtract );
     bind_function( "type", &lisp_type );
 
@@ -112,11 +114,6 @@ int main( int argc, char *argv[] ) {
     bind_special( "quote", &lisp_quote );
     bind_special( "set!", &lisp_set_shriek );
 
-
-    /* bind the oblist last, at this stage. Something clever needs to be done
-     * here and I'm not sure what it is. */
-    deep_bind( c_string_to_lisp_symbol( "oblist" ), oblist );
-
     repl( stdin, stdout, stderr, show_prompt );
 
     if ( dump_at_end ) {
diff --git a/src/intern.c b/src/intern.c
index 12f9da3..100589a 100644
--- a/src/intern.c
+++ b/src/intern.c
@@ -4,11 +4,11 @@
  * For now this implements an oblist and shallow binding; local environments can
  * be consed onto the front of the oblist. Later, this won't do; bindings will happen
  * in namespaces, which will probably be implemented as hash tables.
- * 
+ *
  * Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
  * so when a symbol is rebound in the master oblist, what in fact we do is construct
  * a new oblist without the previous binding but with the new binding. Anything which,
- * prior to this action, held a pointer to the old oblist (as all current threads' 
+ * prior to this action, held a pointer to the old oblist (as all current threads'
  * environments must do) continues to hold a pointer to the old oblist, and consequently
  * doesn't see the change. This is probably good but does mean you cannot use bindings
  * on the oblist to signal between threads.
@@ -26,12 +26,12 @@
 #include "print.h"
 
 /**
- * The object list. What is added to this during system setup is 'global', that is, 
+ * The object list. What is added to this during system setup is 'global', that is,
  * visible to all sessions/threads. What is added during a session/thread is local to
  * that session/thread (because shallow binding). There must be some way for a user to
  * make the contents of their own environment persistent between threads but I don't
  * know what it is yet. At some stage there must be a way to rebind deep values so
- * they're visible to all users/threads, but again I don't yet have any idea how 
+ * they're visible to all users/threads, but again I don't yet have any idea how
  * that will work.
  */
 struct cons_pointer oblist = NIL;
@@ -114,8 +114,8 @@ bind( struct cons_pointer key, struct cons_pointer value,
 }
 
 /**
- * Binds this key to this value in the global oblist, but doesn't affect the 
- * current environment. May not be useful except in bootstrapping (and even 
+ * Binds this key to this value in the global oblist, but doesn't affect the
+ * current environment. May not be useful except in bootstrapping (and even
  * there it may not be especially useful).
  */
 struct cons_pointer
@@ -133,10 +133,9 @@ struct cons_pointer
 intern( struct cons_pointer key, struct cons_pointer environment ) {
     struct cons_pointer result = environment;
     struct cons_pointer canonical = internedp( key, environment );
-
     if ( nilp( canonical ) ) {
         /*
-         * not currently bound 
+         * not currently bound
          */
         result = bind( key, NIL, environment );
     }
diff --git a/src/lispops.c b/src/lispops.c
index fe71c60..cf70d8a 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -63,7 +63,7 @@ struct cons_pointer c_car( struct cons_pointer arg ) {
 struct cons_pointer c_cdr( struct cons_pointer arg ) {
     struct cons_pointer result = NIL;
 
-    if ( consp( arg ) ) {
+    if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) {
         result = pointer2cell( arg ).payload.cons.cdr;
     }
 
@@ -115,6 +115,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
                    eval_forms( frame, c_cdr( list ), env ) ) : NIL;
 }
 
+/**
+ * Return the object list (root namespace).
+ *
+ * (oblist)
+ */
+struct cons_pointer
+lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) {
+    return oblist;
+}
+
 
 /**
  * used to construct the body for `lambda` and `nlambda` expressions.
@@ -123,12 +133,18 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
     struct cons_pointer body =
         !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
 
-    for ( int i = args_in_frame - 1; i >= 0; i-- ) {
-        if ( !nilp( frame->arg[i] ) ) {
+    for ( int i = args_in_frame - 1; i > 0; i-- ) {
+        if ( !nilp( body ) ) {
+            body = make_cons( frame->arg[i], body );
+        } else if ( !nilp( frame->arg[i] ) ) {
             body = make_cons( frame->arg[i], body );
         }
     }
 
+    fputws( L"compose_body returning ", stderr );
+    print( stderr, body );
+    fputws( L"\n", stderr );
+
     return body;
 }
 
@@ -169,7 +185,7 @@ struct cons_pointer
 eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
              struct cons_pointer env ) {
     struct cons_pointer result = NIL;
-    fwprintf( stderr, L"eval_lambda called" );
+    fwprintf( stderr, L"eval_lambda called\n" );
 
     struct cons_pointer new_env = env;
     struct cons_pointer names = cell.payload.lambda.args;
@@ -278,7 +294,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
             {
                 struct stack_frame *next =
                     make_special_frame( frame, args, env );
-                result = ( *fn_cell.payload.special.executable ) ( next, env );
+                fputws( L"Stack frame for nlambda\n", stderr );
+                dump_frame( stderr, next );
+                result = eval_lambda( fn_cell, next, env );
                 if ( !exceptionp( result ) ) {
                     /* if we're returning an exception, we should NOT free the
                      * stack frame. Corollary is, when we free an exception, we
@@ -440,13 +458,45 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
     return frame->arg[0];
 }
 
+
+/**
+ * (set name value)
+ * (set name value namespace)
+ *
+ * Function.
+ * `namespace` defaults to the oblist.
+ * Binds the value of `name` in the `namespace` to value of `value`, altering
+ * the namespace in so doing. `namespace` defaults to the value of `oblist`.
+ */
+struct cons_pointer
+lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+    struct cons_pointer namespace =
+        nilp( frame->arg[2] ) ? oblist : frame->arg[2];
+
+    if ( symbolp( frame->arg[0] ) ) {
+        deep_bind( frame->arg[0], frame->arg[1] );
+        result = frame->arg[1];
+    } else {
+        result =
+            make_exception( make_cons
+                            ( c_string_to_lisp_string
+                              ( "The first argument to `set!` is not a symbol: " ),
+                              make_cons( frame->arg[0], NIL ) ), frame );
+    }
+
+    return result;
+}
+
+
 /**
  * (set! symbol value)
  * (set! symbol value namespace)
  *
  * Special form.
  * `namespace` defaults to the oblist.
- * Binds `symbol` to `value` in the namespace, altering the namespace in so doing.
+ * Binds `symbol` in the `namespace` to value of `value`, altering
+ * the namespace in so doing. `namespace` defaults to the value of `oblist`.
  */
 struct cons_pointer
 lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
@@ -455,13 +505,15 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
         nilp( frame->arg[2] ) ? oblist : frame->arg[2];
 
     if ( symbolp( frame->arg[0] ) ) {
-        deep_bind( frame->arg[0], eval_form( frame, frame->arg[1], env ) );
-        result = frame->arg[1];
+        struct cons_pointer val = eval_form( frame, frame->arg[1], env );
+        deep_bind( frame->arg[0], val );
+        result = val;
     } else {
         result =
-            make_exception( c_string_to_lisp_string
-                            ( "The first argument to `set!` is not a symbol" ),
-                            frame );
+            make_exception( make_cons
+                            ( c_string_to_lisp_string
+                              ( "The first argument to `set!` is not a symbol: " ),
+                              make_cons( frame->arg[0], NIL ) ), frame );
     }
 
     return result;
@@ -670,15 +722,16 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
 
         if ( consp( clause_pointer ) ) {
             struct cons_space_object cell = pointer2cell( clause_pointer );
-          result = eval_form( frame, c_car( clause_pointer ), env);
+            result = eval_form( frame, c_car( clause_pointer ), env );
 
             if ( !nilp( result ) ) {
-                struct cons_pointer vals = eval_forms( frame, c_cdr( clause_pointer ), env );
+                struct cons_pointer vals =
+                    eval_forms( frame, c_cdr( clause_pointer ), env );
 
-              while (consp( vals)) {
-                result = c_car(vals);
-                vals = c_cdr(vals);
-              }
+                while ( consp( vals ) ) {
+                    result = c_car( vals );
+                    vals = c_cdr( vals );
+                }
 
                 done = true;
             }
@@ -698,6 +751,11 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
 
 /**
  * TODO: make this do something sensible somehow.
+ * This requires that a frame be a heap-space object with a cons-space
+ * object pointing to it. Then this should become a normal lisp function
+ * which expects a normally bound frame and environment, such that
+ * frame->arg[0] is the message, and frame->arg[1] is the cons-space
+ * pointer to the frame in which the exception occurred.
  */
 struct cons_pointer
 lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
diff --git a/src/lispops.h b/src/lispops.h
index a0b82cf..122e149 100644
--- a/src/lispops.h
+++ b/src/lispops.h
@@ -71,6 +71,12 @@ struct cons_pointer lisp_eval( struct stack_frame *frame,
 struct cons_pointer lisp_apply( struct stack_frame *frame,
                                 struct cons_pointer env );
 
+struct cons_pointer
+lisp_oblist( struct stack_frame *frame, struct cons_pointer env );
+
+struct cons_pointer
+lisp_set( struct stack_frame *frame, struct cons_pointer env );
+
 struct cons_pointer
 lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
 
diff --git a/src/print.c b/src/print.c
index e3002f8..42bf8b4 100644
--- a/src/print.c
+++ b/src/print.c
@@ -132,8 +132,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case LAMBDATV:
             print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.lambda.
-                                                 body ) ) );
+                                                 cell.payload.
+                                                 lambda.body ) ) );
             break;
         case NILTV:
             fwprintf( output, L"nil" );
@@ -141,8 +141,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case NLAMBDATV:
             print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.lambda.
-                                                 body ) ) );
+                                                 cell.payload.
+                                                 lambda.body ) ) );
             break;
         case READTV:
             fwprintf( output, L"(Input stream)" );
@@ -173,8 +173,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
             print_string( output, pointer );
             break;
         case SYMBOLTV:
-            if ( print_use_colours )
+            if ( print_use_colours ) {
                 fputws( L"\x1B[1;33m", output );
+            }
             print_string_contents( output, pointer );
             break;
         case SPECIALTV:
@@ -185,10 +186,10 @@ void print( FILE * output, struct cons_pointer pointer ) {
             break;
         default:
             fwprintf( stderr,
-                      L"%sError: Unrecognised tag value %d (%c%c%c%c)%s\n",
-                      "\x1B[31m",
+                      L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",
+                      print_use_colours ? "\x1B[31m" : "",
                       cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
-                      cell.tag.bytes[2], cell.tag.bytes[3], "\x1B[39m" );
+                      cell.tag.bytes[2], cell.tag.bytes[3] );
             break;
     }
 
diff --git a/src/repl.c b/src/repl.c
index 596cb61..40f6300 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -97,10 +97,12 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
 
             struct cons_pointer val = repl_eval( input );
 
-            /* suppress the 'end of stream' exception */
-            if ( !exceptionp( val ) &&
-                 !feof( pointer2cell( input_stream ).payload.stream.
-                        stream ) ) {
+            if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
+                /* suppress the 'end of stream' exception */
+                if ( !exceptionp( val ) ) {
+                    repl_print( output_stream, val );
+                }
+            } else {
                 repl_print( output_stream, val );
             }
         }
diff --git a/src/stack.c b/src/stack.c
index ea1f911..cf75df8 100644
--- a/src/stack.c
+++ b/src/stack.c
@@ -169,9 +169,10 @@ void dump_frame( FILE * output, struct stack_frame *frame ) {
     for ( int arg = 0; arg < args_in_frame; arg++ ) {
         struct cons_space_object cell = pointer2cell( frame->arg[arg] );
 
-        fwprintf( output, L"Arg %d:\t%c%c%c%c\t", arg,
+        fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
                   cell.tag.bytes[0],
-                  cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3] );
+                  cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
+                  cell.count );
 
         print( output, frame->arg[arg] );
         fputws( L"\n", output );
diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh
new file mode 100644
index 0000000..c1197e0
--- /dev/null
+++ b/unit-tests/lambda.sh
@@ -0,0 +1,16 @@
+#!/bin/bash
+
+expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)'
+actual=`target/psse 2>/dev/null <<EOF
+(set! list (lambda (l) l))
+(list '(1 2 3 4 5 6 7 8 9 10))
+EOF`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    exit 0
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

From 7cd2cbf7853d93985675092d5c7a4d80543fb935 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Thu, 20 Dec 2018 11:01:13 +0000
Subject: [PATCH 15/17] Very small progress.

---
 src/equal.c   | 4 ++--
 src/init.c    | 1 +
 src/lispops.c | 4 +++-
 src/print.c   | 8 ++++----
 4 files changed, 10 insertions(+), 7 deletions(-)

diff --git a/src/equal.c b/src/equal.c
index ebb085e..0f0597c 100644
--- a/src/equal.c
+++ b/src/equal.c
@@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && ( equal( cell_a->payload.string.cdr,
                                 cell_b->payload.string.cdr )
                          || ( end_of_string( cell_a->payload.string.cdr )
-                              && end_of_string( cell_b->payload.string.
-                                                cdr ) ) );
+                              && end_of_string( cell_b->payload.
+                                                string.cdr ) ) );
                 break;
             case INTEGERTV:
                 result =
diff --git a/src/init.c b/src/init.c
index 70e2499..876bdad 100644
--- a/src/init.c
+++ b/src/init.c
@@ -103,6 +103,7 @@ int main( int argc, char *argv[] ) {
     bind_function( "*", &lisp_multiply );
     bind_function( "-", &lisp_subtract );
     bind_function( "/", &lisp_divide );
+    bind_function( "=", &lisp_equal );
 
     /*
      * primitive special forms
diff --git a/src/lispops.c b/src/lispops.c
index cf70d8a..46ebed3 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -390,8 +390,10 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
                     internedp( frame->arg[0], env );
                 if ( nilp( canonical ) ) {
                     struct cons_pointer message =
+                      c_cons(
                         c_string_to_lisp_string
-                        ( "Attempt to take value of unbound symbol." );
+                        ( "Attempt to take value of unbound symbol." ),
+                      frame->arg[0]);
                     result = lisp_throw( message, frame );
                 } else {
                     result = c_assoc( canonical, env );
diff --git a/src/print.c b/src/print.c
index 42bf8b4..87eff85 100644
--- a/src/print.c
+++ b/src/print.c
@@ -132,8 +132,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case LAMBDATV:
             print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.
-                                                 lambda.body ) ) );
+                                                 cell.payload.lambda.
+                                                 body ) ) );
             break;
         case NILTV:
             fwprintf( output, L"nil" );
@@ -141,8 +141,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case NLAMBDATV:
             print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.
-                                                 lambda.body ) ) );
+                                                 cell.payload.lambda.
+                                                 body ) ) );
             break;
         case READTV:
             fwprintf( output, L"(Input stream)" );

From 5a84f5e305edf358bf82f8b1920b489604b3358b Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 21 Dec 2018 21:35:57 +0000
Subject: [PATCH 16/17] Fixed the eval-real test

So that it passes provided the answer is right to within one part in a million. Also worked on a solution to returning exceptions from make_stack_frame
---
 lisp/fact.lisp          |  2 +-
 src/lispops.c           | 22 +++++++++++++---------
 src/stack.c             |  5 +++--
 src/stack.h             | 15 ++++++++-------
 unit-tests/eval-real.sh |  7 ++++++-
 unit-tests/recursion.sh | 21 +++++++++++++++++++++
 6 files changed, 52 insertions(+), 20 deletions(-)
 create mode 100644 unit-tests/recursion.sh

diff --git a/lisp/fact.lisp b/lisp/fact.lisp
index b204299..2f578a6 100644
--- a/lisp/fact.lisp
+++ b/lisp/fact.lisp
@@ -1,4 +1,4 @@
 (set! fact
       (lambda (n)
       (cond ((= n 1) 1)
-        (true (* n (fact (- n 1)))))))
+        (t (* n (fact (- n 1)))))))
diff --git a/src/lispops.c b/src/lispops.c
index 46ebed3..62338b1 100644
--- a/src/lispops.c
+++ b/src/lispops.c
@@ -241,7 +241,6 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
 struct cons_pointer
 c_apply( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer result = NIL;
-
     struct stack_frame *fn_frame = make_empty_frame( frame, env );
     fn_frame->arg[0] = c_car( frame->arg[0] );
     inc_ref( fn_frame->arg[0] );
@@ -264,28 +263,34 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
             break;
         case FUNCTIONTV:
             {
+                struct cons_pointer exep = NIL;
                 struct stack_frame *next =
-                    make_stack_frame( frame, args, env );
+                    make_stack_frame( frame, args, env, &exep );
                 result = ( *fn_cell.payload.special.executable ) ( next, env );
-                if ( !exceptionp( result ) ) {
+                if ( exceptionp( exep ) ) {
                     /* if we're returning an exception, we should NOT free the
                      * stack frame. Corollary is, when we free an exception, we
                      * should free all the frames it's holding on to. */
+                    result = exep;
+                } else {
                     free_stack_frame( next );
                 }
             }
             break;
         case LAMBDATV:
             {
+                struct cons_pointer exep = NIL;
                 struct stack_frame *next =
-                    make_stack_frame( frame, args, env );
+                    make_stack_frame( frame, args, env, &exep );
                 fputws( L"Stack frame for lambda\n", stderr );
                 dump_frame( stderr, next );
                 result = eval_lambda( fn_cell, next, env );
-                if ( !exceptionp( result ) ) {
+                if ( exceptionp( result ) ) {
                     /* if we're returning an exception, we should NOT free the
                      * stack frame. Corollary is, when we free an exception, we
                      * should free all the frames it's holding on to. */
+                    result = exep;
+                } else {
                     free_stack_frame( next );
                 }
             }
@@ -390,10 +395,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
                     internedp( frame->arg[0], env );
                 if ( nilp( canonical ) ) {
                     struct cons_pointer message =
-                      c_cons(
-                        c_string_to_lisp_string
-                        ( "Attempt to take value of unbound symbol." ),
-                      frame->arg[0]);
+                        make_cons( c_string_to_lisp_string
+                                   ( "Attempt to take value of unbound symbol." ),
+                                   frame->arg[0] );
                     result = lisp_throw( message, frame );
                 } else {
                     result = c_assoc( canonical, env );
diff --git a/src/stack.c b/src/stack.c
index cf75df8..3554f22 100644
--- a/src/stack.c
+++ b/src/stack.c
@@ -66,7 +66,8 @@ struct stack_frame *make_empty_frame( struct stack_frame *previous,
  */
 struct stack_frame *make_stack_frame( struct stack_frame *previous,
                                       struct cons_pointer args,
-                                      struct cons_pointer env ) {
+                                      struct cons_pointer env,
+                                      struct cons_pointer *exception ) {
     struct stack_frame *result = make_empty_frame( previous, env );
 
     for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
@@ -87,7 +88,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
 
         struct cons_pointer val = lisp_eval( arg_frame, env );
         if ( exceptionp( val ) ) {
-            result->arg[0] = val;
+            exception = &val;
             break;
         } else {
             result->arg[i] = val;
diff --git a/src/stack.h b/src/stack.h
index 3a7f0ad..ebb1aa1 100644
--- a/src/stack.h
+++ b/src/stack.h
@@ -4,13 +4,13 @@
  * The Lisp evaluation stack.
  *
  * Stack frames could be implemented in cons space; indeed, the stack
- * could simply be an assoc list consed onto the front of the environment. 
- * But such a stack would be costly to search. The design sketched here, 
- * with stack frames as special objects, SHOULD be substantially more 
+ * could simply be an assoc list consed onto the front of the environment.
+ * But such a stack would be costly to search. The design sketched here,
+ * with stack frames as special objects, SHOULD be substantially more
  * efficient, but does imply we need to generalise the idea of cons pages
  * with freelists to a more general 'equal sized object pages', so that
  * allocating/freeing stack frames can be more efficient.
- * 
+ *
  * Stack frames are not yet a first class object; they have no VECP pointer
  * in cons space.
  *
@@ -35,7 +35,8 @@ struct stack_frame *make_empty_frame( struct stack_frame *previous,
 
 struct stack_frame *make_stack_frame( struct stack_frame *previous,
                                       struct cons_pointer args,
-                                      struct cons_pointer env );
+                                      struct cons_pointer env,
+                                      struct cons_pointer *exception );
 void free_stack_frame( struct stack_frame *frame );
 
 /**
@@ -48,7 +49,7 @@ void dump_frame( FILE * output, struct stack_frame *frame );
 struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
 
 /**
- * A 'special' frame is exactly like a normal stack frame except that the 
+ * A 'special' frame is exactly like a normal stack frame except that the
  * arguments are unevaluated.
  * @param previous the previous stack frame;
  * @param args a list of the arguments to be stored in this stack frame;
@@ -61,7 +62,7 @@ struct stack_frame *make_special_frame( struct stack_frame *previous,
 
 /*
  * struct stack_frame is defined in consspaceobject.h to break circularity
- * TODO: refactor. 
+ * TODO: refactor.
  */
 
 #endif
diff --git a/unit-tests/eval-real.sh b/unit-tests/eval-real.sh
index 39de72f..8832719 100644
--- a/unit-tests/eval-real.sh
+++ b/unit-tests/eval-real.sh
@@ -8,10 +8,15 @@ actual=`echo "(eval 5.05)" |\
   head -2 |\
   tail -1`
 
-if [ "${expected}" = "${actual}" ]
+outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
+
+
+if [ "${outcome}" = "1" ]
 then
     echo "OK"
 else
     echo "Fail: expected '${expected}', got '${actual}'"
     exit 1
 fi
+
+
diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh
new file mode 100644
index 0000000..a49154b
--- /dev/null
+++ b/unit-tests/recursion.sh
@@ -0,0 +1,21 @@
+#!/bin/bash
+
+expected='nil3628800'
+actual=`target/psse 2>/dev/null <<EOF
+(progn
+  (set! fact
+    (lambda (n)
+    (cond ((= n 1) 1)
+      (t (* n (fact (- n 1)))))))
+  nil)
+(fact 10)
+EOF`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    exit 0
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

From 71b9a618140479e5157fc47399e0152bdd410ad1 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 21 Dec 2018 21:39:57 +0000
Subject: [PATCH 17/17] Upversioned to 0.0.3

---
 src/equal.c   | 4 ++--
 src/print.c   | 8 ++++----
 src/version.h | 2 +-
 3 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/src/equal.c b/src/equal.c
index 0f0597c..ebb085e 100644
--- a/src/equal.c
+++ b/src/equal.c
@@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && ( equal( cell_a->payload.string.cdr,
                                 cell_b->payload.string.cdr )
                          || ( end_of_string( cell_a->payload.string.cdr )
-                              && end_of_string( cell_b->payload.
-                                                string.cdr ) ) );
+                              && end_of_string( cell_b->payload.string.
+                                                cdr ) ) );
                 break;
             case INTEGERTV:
                 result =
diff --git a/src/print.c b/src/print.c
index 87eff85..42bf8b4 100644
--- a/src/print.c
+++ b/src/print.c
@@ -132,8 +132,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case LAMBDATV:
             print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.lambda.
-                                                 body ) ) );
+                                                 cell.payload.
+                                                 lambda.body ) ) );
             break;
         case NILTV:
             fwprintf( output, L"nil" );
@@ -141,8 +141,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case NLAMBDATV:
             print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.lambda.
-                                                 body ) ) );
+                                                 cell.payload.
+                                                 lambda.body ) ) );
             break;
         case READTV:
             fwprintf( output, L"(Input stream)" );
diff --git a/src/version.h b/src/version.h
index d827a52..eb9d34e 100644
--- a/src/version.h
+++ b/src/version.h
@@ -8,4 +8,4 @@
  *  Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
-#define VERSION "0.0.2"
+#define VERSION "0.0.3"