Merge branch 'release/0.0.1'

.gitignore

@@ -1,6 +1,14 @@
 
-*.o
-
 *.d
 
+*.o
+
 target/
+
+nbproject/
+
+*~
+
+src/\.#*
+
+*.log

Makefile

@@ -8,16 +8,28 @@ DEPS := $(OBJS:.o=.d)
 
 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"
 
-CPPFLAGS ?= $(INC_FLAGS) -MMD -MP
+CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g
+LDFLAGS := -lm
 
-$(TARGET): $(OBJS)
+$(TARGET): $(OBJS) Makefile
-	$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LOADLIBES) $(LDLIBS)
+	$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
+
+format:
+	indent $(INDENT_FLAGS) $(SRCS) src/*.h
+
+test:
+	bash ./unit-tests.sh
 
 .PHONY: clean
 clean:
-	$(RM) $(TARGET) $(OBJS) $(DEPS)
+	$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~
+
+repl:
+	$(TARGET) -p 2> psse.log
+
 
 -include $(DEPS)

include/licence-header.txt

@@ -0,0 +1,2 @@
+(c) 2017 Simon Brooke <simon@journeyman.cc>
+Licensed under GPL version 2.0, or, at your option, any later version.

src/conspage.c

@@ -19,8 +19,6 @@
 #include "consspaceobject.h"
 #include "conspage.h"
 
-
-
 /**
  * Flag indicating whether conspage initialisation has been done.
  */
@@ -42,7 +40,6 @@ struct cons_pointer freelist = NIL;
  */
 struct cons_page *conspages[NCONSPAGES];
 
-
 /**
  * Make a cons page whose serial number (i.e. index in the conspages directory) is pageno.
  * Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend
@@ -55,25 +52,34 @@ void make_cons_page() {
         conspages[initialised_cons_pages] = result;
 
         for ( int i = 0; i < CONSPAGESIZE; i++ ) {
-      struct cons_space_object * cell = &conspages[initialised_cons_pages]->cell[i];
+            struct cons_space_object *cell =
+                &conspages[initialised_cons_pages]->cell[i];
             if ( initialised_cons_pages == 0 && i < 2 ) {
                 if ( i == 0 ) {
-          /* initialise cell as NIL */
+                    /*
+                     * initialise cell as NIL 
+                     */
                     strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH );
                     cell->count = MAXREFERENCE;
                     cell->payload.free.car = NIL;
                     cell->payload.free.cdr = NIL;
-	  fprintf( stderr, "Allocated special cell NIL\n");
+                    fwprintf( stderr, L"Allocated special cell NIL\n" );
                 } else if ( i == 1 ) {
-          /* initialise cell as T */
+                    /*
+                     * 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.car = ( struct cons_pointer ) {
-          cell->payload.free.cdr = (struct cons_pointer){ 0, 1};
+                    0, 1};
-	  fprintf( stderr, "Allocated special cell T\n");
+                    cell->payload.free.cdr = ( struct cons_pointer ) {
+                    0, 1};
+                    fwprintf( stderr, L"Allocated special cell T\n" );
                 }
             } else {
-	/* otherwise, standard initialisation */
+                /*
+                 * otherwise, standard initialisation 
+                 */
                 strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
                 cell->payload.free.car = NIL;
                 cell->payload.free.cdr = freelist;
@@ -84,27 +90,28 @@ void make_cons_page() {
 
         initialised_cons_pages++;
     } else {
-    fprintf( stderr, "FATAL: Failed to allocate memory for cons page %d\n", initialised_cons_pages);
+        fwprintf( stderr,
+                  L"FATAL: Failed to allocate memory for cons page %d\n",
+                  initialised_cons_pages );
         exit( 1 );
     }
 
 }
 
-
 /**
  * dump the allocated pages to this output stream.
  */
 void dump_pages( FILE * output ) {
     for ( int i = 0; i < initialised_cons_pages; i++ ) {
-    fprintf( output, "\nDUMPING PAGE %d\n", i);
+        fwprintf( output, L"\nDUMPING PAGE %d\n", i );
 
         for ( int j = 0; j < CONSPAGESIZE; j++ ) {
-      dump_object( output, (struct cons_pointer){i, j});
+            dump_object( output, ( struct cons_pointer ) {
+                         i, j} );
         }
     }
 }
 
-
 /**
  * Frees the cell at the specified pointer. Dangerous, primitive, low
  * level.
@@ -116,23 +123,24 @@ void free_cell(struct cons_pointer pointer) {
 
     if ( !check_tag( pointer, FREETAG ) ) {
         if ( cell->count == 0 ) {
+            fwprintf( stderr, L"Freeing cell\n" );
+            dump_object( stderr, pointer );
             strncpy( &cell->tag.bytes[0], FREETAG, 4 );
             cell->payload.free.car = NIL;
             cell->payload.free.cdr = freelist;
             freelist = pointer;
         } else {
-        fprintf( stderr,
+            fwprintf( stderr,
-		 "Attempt to free cell with %d dangling references at page %d, offset %d\n",
+                      L"Attempt to free cell with %d dangling references at page %d, offset %d\n",
                       cell->count, pointer.page, pointer.offset );
         }
     } else {
-      fprintf( stderr,
+        fwprintf( stderr,
-	       "Attempt to free cell which is already FREE at page %d, offset %d\n",
+                  L"Attempt to free cell which is already FREE at page %d, offset %d\n",
                   pointer.page, pointer.offset );
     }
 }
 
-
 /**
  * Allocates a cell with the specified tag. Dangerous, primitive, low
  * level.
@@ -143,6 +151,7 @@ void free_cell(struct cons_pointer pointer) {
 struct cons_pointer allocate_cell( char *tag ) {
     struct cons_pointer result = freelist;
 
+
     if ( result.page == NIL.page && result.offset == NIL.offset ) {
         make_cons_page(  );
         result = allocate_cell( tag );
@@ -158,18 +167,19 @@ struct cons_pointer allocate_cell( char* tag) {
             cell->payload.cons.car = NIL;
             cell->payload.cons.cdr = NIL;
 
-      fprintf( stderr, "Allocated cell of type '%s' at %d, %d \n",
+#ifdef DEBUG
-	       tag, result.page, result.offset);
+            fwprintf( stderr,
-      dump_object( stderr, result);
+                      L"Allocated cell of type '%s' at %d, %d \n", tag,
+                      result.page, result.offset );
+#endif
         } else {
-      fprintf( stderr, "WARNING: Allocating non-free cell!");
+            fwprintf( stderr, L"WARNING: Allocating non-free cell!" );
         }
     }
 
     return result;
 }
 
-
 /**
  * initialise the cons page system; to be called exactly once during startup.
  */
@@ -182,6 +192,7 @@ void initialise_cons_pages() {
         make_cons_page(  );
         conspageinitihasbeencalled = true;
     } else {
-    fprintf( stderr, "WARNING: conspageinit() called a second or subsequent time\n");
+        fwprintf( stderr,
+                  L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
     }
 }

src/conspage.h

@@ -3,31 +3,40 @@
 #ifndef __conspage_h
 #define __conspage_h
 
-
 /**
- * the number of cons cells on a cons page. The maximum value this can be (and consequently,
+ * the number of cons cells on a cons page. The maximum value this can
- * the size which, by version 1, it will default to) is the maximum value of an unsigned 32
+ * be (and consequently, the size which, by version 1, it will default
- * bit integer, which is to say 4294967296. However, we'll start small.
+ * to) is the maximum value of an unsigned 32 bit integer, which is to
+ * say 4294967296. However, we'll start small.
  */
 #define CONSPAGESIZE 8
 
 /**
- * the number of cons pages we will initially allow for. For convenience we'll set up an array
+ * the number of cons pages we will initially allow for. For
- * of cons pages this big; however, later we will want a mechanism for this to be able to grow
+ * convenience we'll set up an array of cons pages this big; however,
- * dynamically to the maximum we can currently allow, which is 4294967296.
+ * later we will want a mechanism for this to be able to grow
+ * dynamically to the maximum we can currently allow, which is
+ * 4294967296.
+ *
+ * Note that this means the total number of addressable cons cells is
+ * 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are 
+ * up to a maximum of 4e9 of heap space objects, each of potentially
+ * 4e9 bytes. So we're talking about a potential total of 8e100 bytes
+ * of addressable memory, which is only slightly more than the
+ * number of atoms in the universe.
  */
 #define NCONSPAGES 8
 
 /**
- * a cons page is essentially just an array of cons space objects. It might later have a local
+ * a cons page is essentially just an array of cons space objects. It
- * free list (i.e. list of free cells on this page) and a pointer to the next cons page, but
+ * might later have a local free list (i.e. list of free cells on this
- * my current view is that that's probably unneccessary.
+ * page) and a pointer to the next cons page, but my current view is
+ * that that's probably unneccessary.
  */
 struct cons_page {
     struct cons_space_object cell[CONSPAGESIZE];
 };
 
-
 /**
  * The (global) pointer to the (global) freelist. Not sure whether this ultimately 
  * belongs in this file.
@@ -39,7 +48,6 @@ extern struct cons_pointer freelist;
  */
 extern struct cons_page *conspages[NCONSPAGES];
 
-
 /**
  * Frees the cell at the specified pointer. Dangerous, primitive, low
  * level.
@@ -48,7 +56,6 @@ extern struct cons_page* conspages[NCONSPAGES];
  */
 void free_cell( struct cons_pointer pointer );
 
-
 /**
  * Allocates a cell with the specified tag. Dangerous, primitive, low
  * level.
@@ -58,7 +65,6 @@ void free_cell(struct cons_pointer pointer);
  */
 struct cons_pointer allocate_cell( char *tag );
 
-
 /**
  * initialise the cons page system; to be called exactly once during startup.
  */

src/consspaceobject.c

@@ -11,12 +11,15 @@
 #include <stdint.h>
 #include <stdlib.h>
 #include <string.h>
-/* wide characters */
+/*
+ * wide characters 
+ */
 #include <wchar.h>
 #include <wctype.h>
 
 #include "conspage.h"
 #include "consspaceobject.h"
+#include "print.h"
 
 /**
  * Check that the tag on the cell at this pointer is this tag
@@ -26,7 +29,6 @@ int check_tag( struct cons_pointer pointer, char* tag) {
     return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0;
 }
 
-
 /**
  * increment the reference count of the object at this cons pointer.
  *
@@ -41,7 +43,6 @@ void inc_ref( struct cons_pointer pointer) {
     }
 }
 
-
 /**
  * Decrement the reference count of the object at this cons pointer.
  *
@@ -60,52 +61,75 @@ void dec_ref( struct cons_pointer pointer) {
     }
 }
 
-
 /**
  * dump the object at this cons_pointer to this output stream.
  */
 void dump_object( FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
-  fprintf( output,
+    fwprintf( output,
-	   "\tDumping object at page %d, offset %d with tag %c%c%c%c (%d), count %u\n",
+              L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
-	   pointer.page,
-	   pointer.offset,
               cell.tag.bytes[0],
               cell.tag.bytes[1],
               cell.tag.bytes[2],
               cell.tag.bytes[3],
-	   cell.tag.value,
+              cell.tag.value, pointer.page, pointer.offset, cell.count );
-	   cell.count);
 
-  if ( check_tag(pointer, CONSTAG)) {
+    switch ( cell.tag.value ) {
-    fprintf( output,
+    case CONSTV:
-	     "\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n",
+        fwprintf( output,
-	     cell.payload.cons.car.page, cell.payload.cons.car.offset,
+                  L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
+                  cell.payload.cons.car.page,
+                  cell.payload.cons.car.offset,
+                  cell.payload.cons.cdr.page,
+                  cell.payload.cons.cdr.offset, cell.count );
+        break;
+    case INTEGERTV:
+        fwprintf( output,
+                  L"\t\tInteger cell: value %ld, count %u\n",
+                  cell.payload.integer.value, cell.count );
+        break;
+    case FREETV:
+        fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
                   cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
-  } else if ( check_tag(pointer, INTEGERTAG)) {
+        break;
-    fprintf( output, "\t\tInteger cell: value %ld\n", cell.payload.integer.value);
+    case REALTV:
-  } else if ( check_tag( pointer, FREETAG)) {
+        fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
-    fprintf( output, "\t\tFree cell: next at page %d offset %d\n",
+                  cell.payload.real.value, cell.count );
-	     cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset);
+        break;
-  } else if ( check_tag(pointer, REALTAG)) {
+    case STRINGTV:
-    fprintf( output, "\t\tReal cell: value %Lf\n", cell.payload.real.value);
+        fwprintf( output,
-  } else if ( check_tag( pointer, STRINGTAG)) {
+                  L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n",
-    fwprintf( output, L"\t\tString cell: character '%C' next at page %d offset %d\n",
+                  cell.payload.string.character,
-	     cell.payload.string.character, cell.payload.string.cdr.page,
+                  cell.payload.string.cdr.page,
-	     cell.payload.string.cdr.offset);
+                  cell.payload.string.cdr.offset, cell.count );
-  };
+        fwprintf( output, L"\t\t value: " );
+        print( output, pointer );
+        fwprintf( output, L"\n" );
+        break;
+    case SYMBOLTV:
+        fwprintf( output,
+                  L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n",
+                  cell.payload.string.character,
+                  cell.payload.string.cdr.page,
+                  cell.payload.string.cdr.offset, cell.count );
+        fwprintf( output, L"\t\t value:" );
+        print( output, pointer );
+        fwprintf( output, L"\n" );
+        break;
+    }
 }
-
 
 /**
  * Construct a cons cell from this pair of pointers.
  */
-struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr) {
+struct cons_pointer make_cons( struct cons_pointer car,
+                               struct cons_pointer cdr ) {
     struct cons_pointer pointer = NIL;
 
     pointer = allocate_cell( CONSTAG );
 
-  struct cons_space_object* cell = &conspages[pointer.page]->cell[pointer.offset];
+    struct cons_space_object *cell =
+        &conspages[pointer.page]->cell[pointer.offset];
 
     inc_ref( car );
     inc_ref( cdr );
@@ -118,8 +142,8 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr)
 /**
  * Construct a cell which points to an executable Lisp special form.
  */
-struct cons_pointer make_function( struct cons_pointer src,
+struct cons_pointer
-				     struct cons_pointer (*executable)
+make_function( struct cons_pointer src, struct cons_pointer ( *executable )
                 ( struct stack_frame *, struct cons_pointer ) ) {
     struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
@@ -136,9 +160,8 @@ struct cons_pointer make_function( struct cons_pointer src,
  * has one character and a pointer to the next; in the last cell the 
  * pointer to next is NIL.
  */
-struct cons_pointer make_string_like_thing( wint_t c,
+struct cons_pointer
-					    struct cons_pointer tail,
+make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
-					    char* tag) {
     struct cons_pointer pointer = NIL;
 
     if ( check_tag( tail, tag ) || check_tag( tail, NILTAG ) ) {
@@ -148,9 +171,12 @@ struct cons_pointer make_string_like_thing( wint_t c,
         inc_ref( tail );
         cell->payload.string.character = c;
         cell->payload.string.cdr.page = tail.page;
+        /* TODO: There's a problem here. Sometimes the offsets on
+         * strings are quite massively off. */
         cell->payload.string.cdr.offset = tail.offset;
     } else {
-    fprintf( stderr, "Warning: only NIL and %s can be appended to %s\n",
+        fwprintf( stderr,
+                  L"Warning: only NIL and %s can be appended to %s\n",
                   tag, tag );
     }
 
@@ -177,11 +203,9 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail) {
 /**
  * Construct a cell which points to an executable Lisp special form.
  */
-struct cons_pointer make_special( struct cons_pointer src,
+struct cons_pointer
-				  struct cons_pointer (*executable)
+make_special( struct cons_pointer src, struct cons_pointer ( *executable )
-				  (struct cons_pointer s_expr,
+               ( struct stack_frame * frame, struct cons_pointer env ) ) {
-				   struct cons_pointer env,
-				   struct stack_frame* frame)) {
     struct cons_pointer pointer = allocate_cell( SPECIALTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 

src/consspaceobject.h

@@ -11,7 +11,9 @@
 #include <stdbool.h>
 #include <stdint.h>
 #include <stdio.h>
-/* wide characters */
+/*
+ * wide characters 
+ */
 #include <wchar.h>
 #include <wctype.h>
 
@@ -67,6 +69,7 @@
  * A real number.
  */
 #define REALTAG     "REAL"
+#define REALTV      1279346002
 
 /**
  * A special form - one whose arguments are not pre-evaluated but passed as a
@@ -153,7 +156,7 @@
 #define stringp(conspoint) (check_tag(conspoint,STRINGTAG))
 
 /**
- * true if conspointer points to a string cell, else false 
+ * true if conspointer points to a symbol cell, else false 
  */
 #define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG))
 
@@ -200,11 +203,14 @@
  * An indirect pointer to a cons cell
  */
 struct cons_pointer {
-  uint32_t page;               /* the index of the page on which this cell resides */
+    uint32_t page;              /* the index of the page on which this cell
+                                 * resides */
     uint32_t offset;            /* the index of the cell within the page */
 };
 
-/* number of arguments stored in a stack frame */
+/*
+ * number of arguments stored in a stack frame 
+ */
 #define args_in_frame 8
 
 /**
@@ -214,9 +220,10 @@ struct cons_pointer {
 struct stack_frame {
     struct stack_frame *previous; /* the previous frame */
     struct cons_pointer arg[args_in_frame];
-                                        /* first 8 arument bindings */
+    /*
-  struct cons_pointer more;             /* list of any further argument 
+     * first 8 arument bindings 
-					 * bindings */
+     */
+    struct cons_pointer more;   /* list of any further argument bindings */
     struct cons_pointer function; /* the function to be called */
 };
 
@@ -239,7 +246,8 @@ struct cons_payload {
  */
 struct function_payload {
     struct cons_pointer source;
-  struct cons_pointer (*executable)(struct stack_frame*, struct cons_pointer);
+    struct cons_pointer ( *executable ) ( struct stack_frame *,
+                                          struct cons_pointer );
 };
 
 /**
@@ -282,9 +290,8 @@ struct real_payload {
  */
 struct special_payload {
     struct cons_pointer source;
-  struct cons_pointer (*executable)(struct cons_pointer s_expr,
+    struct cons_pointer ( *executable ) ( struct stack_frame *,
-				      struct cons_pointer env,
+                                          struct cons_pointer );
-				      struct stack_frame* frame);
 };
 
 /**
@@ -308,10 +315,12 @@ struct string_payload {
 
 struct vectorp_payload {
     union {
-    char bytes[TAGLENGTH];     /* the tag (type) of the vector-space 
+        char bytes[TAGLENGTH];  /* the tag (type) of the
-				* object this cell points to, considered 
+                                 * vector-space object this cell
-				* as bytes. NOTE that the vector space
+                                 * points to, considered as bytes.
-				* object should itself have the identical tag. */
+                                 * NOTE that the vector space object 
+                                 * should itself have the identical
+                                 * tag. */
         uint32_t value;         /* the tag considered as a number */
     } tag;
     uint64_t address;           /* the address of the actual vector space
@@ -319,84 +328,105 @@ struct vectorp_payload {
                                  * implement vector space) */
 };
 
-
 /**
  * an object in cons space.
  */
 struct cons_space_object {
     union {
-    char bytes[TAGLENGTH];     /* the tag (type) of this cell, considered as bytes */
+        char bytes[TAGLENGTH];  /* the tag (type) of this cell,
+                                 * considered as bytes */
         uint32_t value;         /* the tag considered as a number */
     } tag;
-  uint32_t count;              /* the count of the number of references to this cell */
+    uint32_t count;             /* the count of the number of references to
-  struct cons_pointer access;  /* cons pointer to the access control list of this cell */
+                                 * this cell */
+    struct cons_pointer access; /* cons pointer to the access control list of
+                                 * this cell */
     union {
-    /* if tag == CONSTAG */
+        /*
+         * if tag == CONSTAG 
+         */
         struct cons_payload cons;
-    /* if tag == FREETAG */
+        /*
+         * 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;
 };
 
-
 /**
  * Check that the tag on the cell at this pointer is this tag
  */
 int check_tag( struct cons_pointer pointer, char *tag );
 
-
 /**
  * increment the reference count of the object at this cons pointer
  */
 void inc_ref( struct cons_pointer pointer );
 
-
 /**
  * decrement the reference count of the object at this cons pointer
  */
 void dec_ref( struct cons_pointer pointer );
 
-
 /**
  * dump the object at this cons_pointer to this output stream.
  */
 void dump_object( FILE * output, struct cons_pointer pointer );
 
-struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr);
+struct cons_pointer make_cons( struct cons_pointer car,
+                               struct cons_pointer cdr );
 
 /**
  * Construct a cell which points to an executable Lisp special form.
  */
 struct cons_pointer make_function( struct cons_pointer src,
                                    struct cons_pointer ( *executable )
-				   (struct stack_frame*, struct cons_pointer));
+                                    ( struct stack_frame *,
+                                      struct cons_pointer ) );
 
 /**
  * Construct a cell which points to an executable Lisp special form.
  */
 struct cons_pointer make_special( struct cons_pointer src,
                                   struct cons_pointer ( *executable )
-				  (struct cons_pointer s_expr,
+                                   ( struct stack_frame *,
-				   struct cons_pointer env,
+                                     struct cons_pointer ) );
-				   struct stack_frame* frame));
 
 /**
  * Construct a string from this character and this tail. A string is

src/equal.c

@@ -22,6 +22,20 @@ bool eq( struct cons_pointer a, struct cons_pointer b) {
     return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
 }
 
+/**
+ * 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, 
+ * else false.
+ */
+bool same_type( struct cons_pointer a, struct cons_pointer b ) {
+    struct cons_space_object *cell_a = &pointer2cell( a );
+    struct cons_space_object *cell_b = &pointer2cell( b );
+
+    return cell_a->tag.value == cell_b->tag.value;
+
+}
 
 /**
  * Deep, and thus expensive, equality: true if these two objects have
@@ -30,32 +44,56 @@ bool eq( struct cons_pointer a, struct cons_pointer b) {
 bool equal( struct cons_pointer a, struct cons_pointer b ) {
     bool result = eq( a, b );
 
-  if ( ! result) {
+    if ( !result && same_type( a, b ) ) {
         struct cons_space_object *cell_a = &pointer2cell( a );
         struct cons_space_object *cell_b = &pointer2cell( b );
 
-    if ( consp( a) && consp( b)) {
+        switch ( cell_a->tag.value ) {
-      result = equal( cell_a->payload.cons.car, cell_b->payload.cons.car) &&
+        case CONSTV:
-	equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr);
+            result =
-    } else if ( stringp( a) && stringp( b)) {
+                equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
-      /* slightly complex because a string may or may not have a '\0' cell
+                && equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr );
-       * at the end, but I'll ignore that for now. I think in practice only
+            break;
-       * the empty string will. */
+        case STRINGTV:
-      result = cell_a->payload.string.character == cell_b->payload.string.character &&
+        case SYMBOLTV:
-	equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr);
+            /*
-    } else if ( numberp( a) && numberp( b)) {
+             * slightly complex because a string may or may not have a '\0'
+             * cell at the end, but I'll ignore that for now. I think in
+             * practice only the empty string will. 
+             */
+            result =
+                cell_a->payload.string.character ==
+                cell_b->payload.string.character
+                && equal( cell_a->payload.string.cdr,
+                          cell_b->payload.string.cdr );
+            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);
+                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 */
+                /*
+                 * not more different than one part in a million - close enough 
+                 */
                 result = fabs( num_a - num_b ) < ( max / 1000000.0 );
             }
-    /* there's only supposed ever to be one T and one NIL cell, so each should
+            break;
-     * be caught by eq; equality of vector-space objects is a whole other ball
+        default:
-     * game so we won't deal with it now (and indeedmay never). I'm not certain
+            result = false;
-     * what equality means for read and write streams, so I'll ignore them, too,
+            break;
-     * for now.*/
+        }
+
+        /*
+         * there's only supposed ever to be one T and one NIL cell, so each
+         * should be caught by eq; equality of vector-space objects is a whole 
+         * other ball game so we won't deal with it now (and indeedmay never). 
+         * I'm not certain what equality means for read and write streams, so
+         * I'll ignore them, too, for now.
+         */
     }
 
     return result;

src/init.c

@@ -9,38 +9,75 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#include <stdbool.h>
 #include <stdio.h>
+#include <unistd.h>
+#include <wchar.h>
 
 #include "version.h"
 #include "conspage.h"
 #include "consspaceobject.h"
 #include "intern.h"
 #include "lispops.h"
+#include "peano.h"
 #include "print.h"
-#include "read.h"
+#include "repl.h"
 
 void bind_function( char *name, struct cons_pointer ( *executable )
                      ( struct stack_frame *, struct cons_pointer ) ) {
-  deep_bind( intern( c_string_to_lisp_symbol( name), oblist ),
+    deep_bind( c_string_to_lisp_symbol( name ),
                make_function( NIL, executable ) );
 }
 
 void bind_special( char *name, struct cons_pointer ( *executable )
-		   (struct cons_pointer s_expr, struct cons_pointer env,
+                    ( struct stack_frame * frame, struct cons_pointer env ) ) {
-		    struct stack_frame* frame)) {
+    deep_bind( c_string_to_lisp_symbol( name ),
-  deep_bind( intern( c_string_to_lisp_symbol( name), oblist ),
                make_special( NIL, executable ) );
 }
 
 int main( int argc, char *argv[] ) {
-  fprintf( stderr, "Post scarcity software environment version %s\n", VERSION);
+    /*
+     * attempt to set wide character acceptance on all streams 
+     */
+    fwide( stdin, 1 );
+    fwide( stdout, 1 );
+    fwide( stderr, 1 );
+    int option;
+    bool dump_at_end = false;
+    bool show_prompt = false;
+
+    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;
+        }
+    }
+
+    if ( show_prompt ) {
+        fwprintf( stdout,
+                  L"Post scarcity software environment version %s\n\n",
+                  VERSION );
+    }
+
     initialise_cons_pages(  );
 
-  /* privileged variables (keywords) */
+    /*
-  deep_bind( intern( c_string_to_lisp_string( "nil"), oblist), NIL);
+     * privileged variables (keywords) 
-  deep_bind( intern( c_string_to_lisp_string( "t"), oblist), TRUE);
+     */
 
-  /* primitive function operations */
+    deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
+    deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
+
+    /*
+     * primitive function operations 
+     */
     bind_function( "assoc", &lisp_assoc );
     bind_function( "car", &lisp_car );
     bind_function( "cdr", &lisp_cdr );
@@ -49,20 +86,32 @@ int main (int argc, char *argv[]) {
     bind_function( "equal", &lisp_equal );
     bind_function( "read", &lisp_read );
     bind_function( "print", &lisp_print );
+    bind_function( "type", &lisp_type );
 
-  /* primitive special forms */
+    bind_function( "add", &lisp_add );
-  bind_special( "apply", &lisp_apply);
+    bind_function( "+", &lisp_add );
+    bind_function( "multiply", &lisp_multiply );
+    bind_function( "*", &lisp_multiply );
+    bind_function( "subtract", &lisp_subtract );
+    bind_function( "-", &lisp_subtract );
+    bind_function( "apply", &lisp_apply );
+
+    /*
+     * primitive special forms 
+     */
     bind_special( "eval", &lisp_eval );
     bind_special( "quote", &lisp_quote );
 
-  fprintf( stderr, "\n:: ");
-  struct cons_pointer input = read( stdin);
-  fprintf( stderr, "\nread {%d,%d}=> ", input.page, input.offset);
-  print( stdout, input);
-  fprintf( stderr, "\neval {%d,%d}=> ", input.page, input.offset);
-  // print( stdout, lisp_eval( input, oblist, NULL));
 
-  dump_pages(stderr);
+    /* 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 ) {
+        dump_pages( stdout );
+    }
 
     return ( 0 );
 }

src/integer.c

@@ -9,6 +9,7 @@
 
 #define _GNU_SOURCE
 #include <math.h>
+#include <stdio.h>
 
 #include "conspage.h"
 #include "consspaceobject.h"
@@ -19,12 +20,12 @@
  * as a cons-space object. Cell may in principle be any kind of number,
  * but only integers and reals are so far implemented.
  */
-double numeric_value( struct cons_pointer pointer) {
+long double numeric_value( struct cons_pointer pointer ) {
     double result = NAN;
     struct cons_space_object *cell = &pointer2cell( pointer );
 
     if ( integerp( pointer ) ) {
-    result = (double) cell->payload.integer.value;
+        result = cell->payload.integer.value * 1.0;
     } else if ( realp( pointer ) ) {
         result = cell->payload.real.value;
     }
@@ -32,15 +33,15 @@ double numeric_value( struct cons_pointer pointer) {
     return result;
 }
 
-
 /**
  * Allocate an integer cell representing this value and return a cons pointer to it.
  */
-struct cons_pointer make_integer( int value) {
+struct cons_pointer make_integer( long int value ) {
     struct cons_pointer result = allocate_cell( INTEGERTAG );
     struct cons_space_object *cell = &pointer2cell( result );
     cell->payload.integer.value = value;
 
+    dump_object( stderr, result );
+
     return result;
 }
-  

src/integer.h

@@ -11,11 +11,11 @@
 #ifndef __integer_h
 #define __integer_h
 
-double numeric_value( struct cons_pointer pointer);
+long double numeric_value( struct cons_pointer pointer );
 
 /**
  * Allocate an integer cell representing this value and return a cons pointer to it.
  */
-struct cons_pointer make_integer( int value);
+struct cons_pointer make_integer( long int value );
 
 #endif

src/intern.c

@@ -43,7 +43,8 @@ struct cons_pointer oblist = NIL;
  * from the store (so that later when we want to retrieve a value, an eq test
  * will work); otherwise return NIL.
  */
-struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer store) {
+struct cons_pointer
+internedp( struct cons_pointer key, struct cons_pointer store ) {
     struct cons_pointer result = NIL;
 
     for ( struct cons_pointer next = store;
@@ -68,12 +69,12 @@ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer stor
  * If this key is lexically identical to a key in this store, return the value
  * of that key from the store; otherwise return NIL.
  */
-struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store) {
+struct cons_pointer c_assoc( struct cons_pointer key,
+                             struct cons_pointer store ) {
     struct cons_pointer result = NIL;
 
     for ( struct cons_pointer next = store;
-	consp( next);
+          consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
-	next = pointer2cell( next).payload.cons.cdr) {
         struct cons_space_object entry =
             pointer2cell( pointer2cell( next ).payload.cons.car );
 
@@ -86,40 +87,41 @@ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store)
     return result;
 }
 
-
 /**
  * Return a new key/value store containing all the key/value pairs in this store
  * with this key/value pair added to the front.
  */
-struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value,
+struct cons_pointer
+bind( struct cons_pointer key, struct cons_pointer value,
       struct cons_pointer store ) {
     return make_cons( make_cons( key, value ), store );
 }
 
-
 /**
  * Binds this key to this value in the global oblist, but doesn't affect the 
  * current environment. May not be useful except in bootstrapping (and even 
  * there it may not be especially useful).
  */
-struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value) {
+struct cons_pointer
+deep_bind( struct cons_pointer key, struct cons_pointer value ) {
     oblist = bind( key, value, oblist );
     return oblist;
 }
 
-
 /**
  * Ensure that a canonical copy of this key is bound in this environment, and
  * return that canonical copy. If there is currently no such binding, create one
  * with the value NIL.
  */
-struct cons_pointer intern( struct cons_pointer key,
+struct cons_pointer
-			    struct cons_pointer environment) {
+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 );
     }
 

src/intern.h

@@ -17,7 +17,6 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
-
 #ifndef __intern_h
 #define __intern_h
 
@@ -28,7 +27,8 @@ extern struct cons_pointer oblist;
  * implementation a store is just an assoc list, but in future it might be a
  * namespace, a regularity or a homogeneity.
  */
-struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store);
+struct cons_pointer c_assoc( struct cons_pointer key,
+                             struct cons_pointer store );
 
 /**
  * Return true if this key is present as a key in this enviroment, defaulting to
@@ -41,7 +41,8 @@ struct cons_pointer internedp( struct cons_pointer key,
  * Return a new key/value store containing all the key/value pairs in this store
  * with this key/value pair added to the front.
  */
-struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value,
+struct cons_pointer bind( struct cons_pointer key,
+                          struct cons_pointer value,
                           struct cons_pointer store );
 
 /**
@@ -49,7 +50,8 @@ struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value,
  * current environment. May not be useful except in bootstrapping (and even 
  * there it may not be especially useful).
  */
-struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value);
+struct cons_pointer deep_bind( struct cons_pointer key,
+                               struct cons_pointer value );
 
 /**
  * Ensure that a canonical copy of this key is bound in this environment, and

src/lispops.c

@@ -72,49 +72,44 @@ struct cons_pointer c_cdr( struct cons_pointer arg) {
     return result;
 }
 
+
 /**
- * (apply fn args...)
+ * Internal guts of apply.
- *
+ * @param frame the stack frame, expected to have only one argument, a list
- * I'm now confused about whether at this stage I actually need an apply special form,
+ * comprising something that evaluates to a function and its arguments.
- * and if so how it differs from eval.
+ * @param env The evaluation environment.
+ * @return the result of evaluating the function with its arguments.
  */
-struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env,
+struct cons_pointer
-			       struct stack_frame* frame) {
+c_apply( struct stack_frame *frame, struct cons_pointer env ) {
-  struct cons_pointer result = args;
-  
-  if ( consp( args)) {
-    lisp_eval( args, env, frame);
-  }
-
-  return result;
-}
-
-struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
-			       struct stack_frame* my_frame) {
     struct cons_pointer result = NIL;
-  struct cons_pointer fn_pointer = lisp_eval( c_car( s_expr), env, my_frame);
+
+    struct stack_frame *fn_frame = make_empty_frame( frame, env );
+    fn_frame->arg[0] = c_car( frame->arg[0] );
+    inc_ref( fn_frame->arg[0] );
+    struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
+    free_stack_frame( fn_frame );
+
     struct cons_space_object fn_cell = pointer2cell( fn_pointer );
-  struct cons_pointer args = c_cdr( s_expr);
+    struct cons_pointer args = c_cdr( frame->arg[0] );
 
     switch ( fn_cell.tag.value ) {
     case SPECIALTV:
         {
-      struct cons_space_object special = pointer2cell( fn_pointer);
+            struct stack_frame *next = make_special_frame( frame, args, env );
-      result = (*special.payload.special.executable)( args, env, my_frame);
+            result = ( *fn_cell.payload.special.executable ) ( next, env );
+            free_stack_frame( next );
         }
         break;
 
     case FUNCTIONTV:
-    /* actually, this is apply */
+        /*
+         * actually, this is apply 
+         */
         {
-      struct cons_space_object function = pointer2cell( fn_pointer);
+            struct stack_frame *next = make_stack_frame( frame, args, env );
-      struct stack_frame* frame = make_stack_frame( my_frame, args, env);
+            result = ( *fn_cell.payload.special.executable ) ( next, env );
-
+            free_stack_frame( next );
-      /* the trick: pass the remaining arguments and environment to
-	 the executable code which is the payload of the function
-	 object. */
-      result = (*function.payload.function.executable)( frame, env);
-      free_stack_frame( frame);
         }
         break;
 
@@ -124,11 +119,12 @@ struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer e
             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.value, fn_cell.tag.bytes[0],
-	       fn_cell.tag.bytes[2], fn_cell.tag.bytes[3]);
+                     fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
+                     fn_cell.tag.bytes[3] );
             struct cons_pointer message = c_string_to_lisp_string( buffer );
             free( buffer );
-      result = lisp_throw( message, my_frame);
+            result = lisp_throw( message, frame );
         }
     }
 
@@ -148,42 +144,75 @@ struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer e
  * passes them in a stack frame as arguments to the function.
  * If a special form, passes the cdr of s_expr to the special form as argument.
  */
-struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
+struct cons_pointer
-			       struct stack_frame* previous) {
+lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
-  struct cons_pointer result = s_expr;
+    struct cons_pointer result = frame->arg[0];
-  struct cons_space_object cell = pointer2cell( s_expr);
+    struct cons_space_object cell = pointer2cell( frame->arg[0] );
-  struct stack_frame* my_frame =
+
-    make_stack_frame( previous, make_cons( s_expr, NIL), env);
+    fputws( L"Eval: ", stderr );
+    dump_frame( stderr, frame );
 
     switch ( cell.tag.value ) {
     case CONSTV:
-    result = eval_cons( s_expr, env, my_frame);
+        result = c_apply( frame, env );
         break;
 
     case SYMBOLTV:
         {
-      struct cons_pointer canonical = internedp( s_expr, env);
+            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.");
+                    c_string_to_lisp_string
-	result = lisp_throw( message, my_frame);
+                    ( "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;
+         * the Clojure practice of having a map serve in the function place of 
-     * also if the object is a consp it could be interpretable
+         * an s-expression is a good one and I should adopt it; also if the
-     * source code but in the long run I don't want an interpreter,
+         * object is a consp it could be interpretable source code but in the
-     * and if I can get away without so much the better. */
+         * long run I don't want an interpreter, and if I can get away without 
+         * so much the better. 
+         */
     }
 
-  free_stack_frame( my_frame);
+    fputws( L"Eval returning ", stderr );
+    print( stderr, result );
+    fputws( L"\n", stderr );
 
     return result;
 }
 
+
+/**
+ * (apply fn args)
+ * 
+ * function. Apply the function which is the result of evaluating the
+ * first argoment to the list of arguments which is the result of evaluating
+ * the second argument
+ */
+struct cons_pointer
+lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
+    fputws( L"Apply: ", stderr );
+    dump_frame( stderr, frame );
+
+    frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] );
+    inc_ref( frame->arg[0] );
+    frame->arg[1] = NIL;
+
+    struct cons_pointer result = c_apply( frame, env );
+
+    fputws( L"Apply returning ", stderr );
+    print( stderr, result );
+    fputws( L"\n", stderr );
+
+    return result;
+}
+
+
 /**
  * (quote a)
  *
@@ -191,9 +220,9 @@ struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer e
  * Returns its argument (strictly first argument - only one is expected but
  * this isn't at this stage checked) unevaluated.
  */
-struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env,
+struct cons_pointer
-				struct stack_frame* frame) {
+lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
-  return c_car( args);
+    return frame->arg[0];
 }
 
 /**
@@ -204,7 +233,8 @@ struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer en
  * cdr is nill, and b is of type string, then returns a new string cell;
  * otherwise returns a new cons cell.
  */
-struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env) {
+struct cons_pointer
+lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer car = frame->arg[0];
     struct cons_pointer cdr = frame->arg[1];
     struct cons_pointer result;
@@ -213,7 +243,8 @@ struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env
         return NIL;
     } else if ( stringp( car ) && stringp( cdr ) &&
                 nilp( pointer2cell( car ).payload.string.cdr ) ) {
-    result = make_string( pointer2cell( car).payload.string.character, cdr);
+        result =
+            make_string( pointer2cell( car ).payload.string.character, cdr );
     } else {
         result = make_cons( car, cdr );
     }
@@ -226,7 +257,8 @@ struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env
  * Returns the first item (head) of a sequence. Valid for cons cells,
  * strings, and TODO read streams and other things which can be considered as sequences.
  */
-struct cons_pointer lisp_car(struct stack_frame* frame, struct cons_pointer env) {
+struct cons_pointer
+lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer result = NIL;
 
     if ( consp( frame->arg[0] ) ) {
@@ -237,31 +269,31 @@ struct cons_pointer lisp_car(struct stack_frame* frame, struct cons_pointer env)
         result = make_string( cell.payload.string.character, NIL );
     } else {
         struct cons_pointer message =
-      c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence");
+            c_string_to_lisp_string( "Attempt to take CAR of non sequence" );
         result = lisp_throw( message, frame );
     }
 
     return result;
 }
 
-
 /**
  * (cdr s_expr)
  * Returns the remainder of a sequence when the head is removed. Valid for cons cells,
  * strings, and TODO read streams and other things which can be considered as sequences.
  */
-struct cons_pointer lisp_cdr(struct stack_frame* frame, struct cons_pointer env) {
+struct cons_pointer
+lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer result = NIL;
 
     if ( consp( frame->arg[0] ) ) {
         struct cons_space_object cell = pointer2cell( frame->arg[0] );
-    result = cell.payload.cons.car;
+        result = cell.payload.cons.cdr;
     } else if ( stringp( frame->arg[0] ) ) {
         struct cons_space_object cell = pointer2cell( frame->arg[0] );
         result = cell.payload.string.cdr;
     } else {
         struct cons_pointer message =
-      c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence");
+            c_string_to_lisp_string( "Attempt to take CDR of non sequence" );
         result = lisp_throw( message, frame );
     }
 
@@ -272,7 +304,8 @@ struct cons_pointer lisp_cdr(struct stack_frame* frame, struct cons_pointer env)
  * (assoc key store)
  * Returns the value associated with key in store, or NIL if not found.
  */
-struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env) {
+struct cons_pointer
+lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
     return c_assoc( frame->arg[0], frame->arg[1] );
 }
 
@@ -280,7 +313,8 @@ struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer e
  * (eq a b)
  * Returns T if a and b are pointers to the same object, else NIL
  */
-struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env) {
+struct cons_pointer lisp_eq( struct stack_frame *frame,
+                             struct cons_pointer env ) {
     return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
 }
 
@@ -288,7 +322,8 @@ struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env)
  * (eq a b)
  * Returns T if a and b are pointers to structurally identical objects, else NIL
  */
-struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env) {
+struct cons_pointer
+lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
     return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
 }
 
@@ -298,7 +333,8 @@ struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer e
  * Read one complete lisp form and return it. If read-stream is specified and 
  * is a read stream, then read from that stream, else stdin.
  */
-struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env) {
+struct cons_pointer
+lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
     FILE *input = stdin;
 
     if ( readp( frame->arg[0] ) ) {
@@ -308,13 +344,15 @@ struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer en
     return read( input );
 }
 
+
 /**
  * (print expr)
  * (print expr write-stream)
  * Print one complete lisp form and return NIL. If write-stream is specified and 
  * is a write stream, then print to that stream, else stdout.
  */
-struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env) {
+struct cons_pointer
+lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
     FILE *output = stdout;
 
     if ( writep( frame->arg[1] ) ) {
@@ -327,14 +365,35 @@ struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer e
 }
 
 
+/**
+ * Get the Lisp type of the single argument.
+ * @param frame My stack frame.
+ * @param env My environment (ignored).
+ * @return As a Lisp string, the tag of the object which is the argument.
+ */
+struct cons_pointer
+lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
+    char *buffer = malloc( TAGLENGTH + 1 );
+    memset( buffer, 0, TAGLENGTH + 1 );
+    struct cons_space_object cell = pointer2cell( frame->arg[0] );
+    strncpy( buffer, cell.tag.bytes, TAGLENGTH );
+
+    struct cons_pointer result = c_string_to_lisp_string( buffer );
+    free( buffer );
+
+    return result;
+}
+
+
 /**
  * TODO: make this do something sensible somehow.
  */
-struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame) {
+struct cons_pointer
-  fprintf( stderr, "\nERROR: ");
+lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
+    fwprintf( stderr, L"\nERROR: " );
     print( stderr, message );
-  fprintf( stderr, "\n\nAn exception was thrown and I've no idea what to do now\n");
+    fwprintf( stderr,
+              L"\n\nAn exception was thrown and I've no idea what to do now\n" );
 
     exit( 1 );
 }
-

src/lispops.h

@@ -19,23 +19,46 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
-/* special forms */
+/*
-struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env,
+ * special forms 
-			       struct stack_frame* frame);
+ */
-struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env,
+struct cons_pointer lisp_eval( struct stack_frame *frame,
-				struct stack_frame* frame);
+                               struct cons_pointer env );
-struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env,
+struct cons_pointer lisp_apply( struct stack_frame *frame,
-				struct stack_frame* frame);
+                                struct cons_pointer env );
+struct cons_pointer lisp_quote( struct stack_frame *frame,
+                                struct cons_pointer env );
 
-/* functions */
+/*
-struct cons_pointer lisp_cons( struct stack_frame* frame, struct cons_pointer env);
+ * functions 
-struct cons_pointer lisp_car( struct stack_frame* frame, struct cons_pointer env);
+ */
-struct cons_pointer lisp_cdr( struct stack_frame* frame, struct cons_pointer env);
+struct cons_pointer lisp_cons( struct stack_frame *frame,
-struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env);
+                               struct cons_pointer env );
-struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env);
+struct cons_pointer lisp_car( struct stack_frame *frame,
-struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env);
+                              struct cons_pointer env );
-struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env);
+struct cons_pointer lisp_cdr( struct stack_frame *frame,
-struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env);
+                              struct cons_pointer env );
+struct cons_pointer lisp_assoc( struct stack_frame *frame,
+                                struct cons_pointer env );
+struct cons_pointer lisp_eq( struct stack_frame *frame,
+                             struct cons_pointer env );
+struct cons_pointer lisp_equal( struct stack_frame *frame,
+                                struct cons_pointer env );
+struct cons_pointer lisp_read( struct stack_frame *frame,
+                               struct cons_pointer env );
+struct cons_pointer lisp_print( struct stack_frame *frame,
+                                struct cons_pointer env );
+/**
+ * Get the Lisp type of the single argument.
+ * @param frame My stack frame.
+ * @param env My environment (ignored).
+ * @return As a Lisp string, the tag of the object which is the argument.
+ */
+struct cons_pointer
+lisp_type( struct stack_frame *frame, struct cons_pointer env );
 
-/* neither, at this stage, really */
+/*
-struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame);
+ * neither, at this stage, really 
+ */
+struct cons_pointer lisp_throw( struct cons_pointer message,
+                                struct stack_frame *frame );

src/peano.c

@@ -0,0 +1,151 @@
+/**
+ * peano.c
+ *
+ * Basic peano arithmetic
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <ctype.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+
+#include "consspaceobject.h"
+#include "conspage.h"
+#include "equal.h"
+#include "integer.h"
+#include "intern.h"
+#include "lispops.h"
+#include "print.h"
+#include "read.h"
+#include "real.h"
+#include "stack.h"
+
+/**
+ * Add an indefinite number of numbers together
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+struct cons_pointer
+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;
+
+    for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
+        struct cons_space_object current = pointer2cell( frame->arg[i] );
+
+        switch ( current.tag.value ) {
+        case INTEGERTV:
+            i_accumulator += current.payload.integer.value;
+            d_accumulator += numeric_value( frame->arg[i] );
+            break;
+        case REALTV:
+            d_accumulator += current.payload.real.value;
+            is_int = false;
+            break;
+        default:
+            lisp_throw( c_string_to_lisp_string( "Cannot add: not a number" ),
+                        frame );
+        }
+
+        if ( !nilp( frame->more ) ) {
+            lisp_throw( c_string_to_lisp_string
+                        ( "Cannot yet add more than 8 numbers" ), frame );
+        }
+
+        if ( is_int ) {
+            result = make_integer( i_accumulator );
+        } else {
+            result = make_real( d_accumulator );
+        }
+    }
+
+    return result;
+}
+
+/**
+ * Multiply an indefinite number of numbers together
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+struct cons_pointer
+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;
+
+    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 );
+        }
+
+        if ( !nilp( frame->more ) ) {
+            lisp_throw( c_string_to_lisp_string
+                        ( "Cannot yet multiply more than 8 numbers" ), frame );
+        }
+
+        if ( is_int ) {
+            result = make_integer( i_accumulator );
+        } else {
+            result = make_real( d_accumulator );
+        }
+    }
+
+    return result;
+}
+
+/**
+ * Subtract one number from another.
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+struct cons_pointer
+lisp_subtract( 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 ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
+        result =
+            make_integer( arg0.payload.integer.value -
+                          arg1.payload.integer.value );
+    } else if ( realp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
+        result =
+            make_real( arg0.payload.real.value - arg1.payload.real.value );
+    } else if ( integerp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
+        result =
+            make_real( numeric_value( frame->arg[0] ) -
+                       arg1.payload.real.value );
+    } 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!
+
+    // and if not nilp[frame->arg[2]) we also have an error.
+
+    return result;
+}

src/peano.h

@@ -0,0 +1,49 @@
+/**
+ * peano.h
+ *
+ * Basic peano arithmetic
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include "consspaceobject.h"
+
+#ifndef PEANO_H
+#define PEANO_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/**
+ * Add an indefinite number of numbers together
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+    struct cons_pointer
+     lisp_add( struct stack_frame *frame, struct cons_pointer env );
+
+/**
+ * Multiply an indefinite number of numbers together
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+    struct cons_pointer
+     lisp_multiply( struct stack_frame *frame, struct cons_pointer env );
+
+/**
+ * Subtract one number from another.
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+    struct cons_pointer
+     lisp_subtract( struct stack_frame *frame, struct cons_pointer env );
+
+#ifdef __cplusplus
+}
+#endif
+#endif                          /* PEANO_H */

src/print.c

@@ -11,7 +11,9 @@
 #include <ctype.h>
 #include <stdio.h>
 #include <string.h>
-/* wide characters */
+/*
+ * wide characters 
+ */
 #include <wchar.h>
 #include <wctype.h>
 
@@ -32,24 +34,24 @@ void print_string_contents( FILE* output, struct cons_pointer pointer) {
     }
 }
 
-
 void print_string( FILE * output, struct cons_pointer pointer ) {
-  fputc( '"', output);
+    fputwc( btowc( '"' ), output );
     print_string_contents( output, pointer );
-  fputc( '"', output);
+    fputwc( btowc( '"' ), output );
 }
 
 /**
- * Print a single list cell (cons cell). TODO: does not handle dotted pairs.
+ * Print a single list cell (cons cell).
  */
-void print_list_contents( FILE* output, struct cons_pointer pointer,
+void
+print_list_contents( FILE * output, struct cons_pointer pointer,
                      bool initial_space ) {
     struct cons_space_object *cell = &pointer2cell( pointer );
 
     switch ( cell->tag.value ) {
     case CONSTV:
         if ( initial_space ) {
-      fputc( ' ', output);
+            fputwc( btowc( ' ' ), output );
         }
         print( output, cell->payload.cons.car );
 
@@ -58,33 +60,36 @@ void print_list_contents( FILE* output, struct cons_pointer pointer,
     case NILTV:
         break;
     default:
-    fprintf( output, " . ");
+        fwprintf( output, L" . " );
         print( output, pointer );
     }
 }
 
-
 void print_list( FILE * output, struct cons_pointer pointer ) {
-  fputc( '(', output);
+    fputwc( btowc( '(' ), output );
     print_list_contents( output, pointer, false );
-  fputc( ')', output);
+    fputwc( btowc( ')' ), output );
 }
 
 void print( FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
 
-  /* Because tags have values as well as bytes, this if ... else if
+    /*
-   * statement can ultimately be replaced by a switch, which will
+     * Because tags have values as well as bytes, this if ... else if
-   * 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:
-    fprintf( output, "%ld", cell.payload.integer.value);
+        fwprintf( output, L"%ld", cell.payload.integer.value );
         break;
     case NILTV:
-    fprintf( output, "nil");
+        fwprintf( output, L"nil" );
+        break;
+    case REALTV:
+        fwprintf( output, L"%Lf", cell.payload.real.value );
         break;
     case STRINGTV:
         print_string( output, pointer );
@@ -93,11 +98,19 @@ void print( FILE* output, struct cons_pointer pointer) {
         print_string_contents( output, pointer );
         break;
     case TRUETV:
-    fprintf( output, "t");
+        fwprintf( output, L"t" );
+        break;
+    case FUNCTIONTV:
+        fwprintf( output, L"(Function)" );
+        break;
+    case SPECIALTV:
+        fwprintf( output, L"(Special form)" );
         break;
     default:
-    fprintf( stderr, "Error: Unrecognised tag value %d (%c%c%c%c)\n",
+        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;
     }
 }

src/read.c

@@ -8,22 +8,27 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#include <math.h>
 #include <stdbool.h>
 #include <stdio.h>
-/* wide characters */
+/*
+ * wide characters
+ */
 #include <wchar.h>
 #include <wctype.h>
 
 #include "consspaceobject.h"
 #include "integer.h"
 #include "intern.h"
+#include "print.h"
 #include "read.h"
+#include "real.h"
 
-/* for the time being things which may be read are:
+/*
-   strings
+ * for the time being things which may be read are: strings numbers - either
-   numbers - either integer or real, but not yet including ratios or bignums
+ * integer or real, but not yet including ratios or bignums lists Can't read
-   lists
+ * atoms because I don't yet know what an atom is or how it's stored.
-   Can't read atoms because I don't yet know what an atom is or how it's stored. */
+ */
 
 struct cons_pointer read_number( FILE * input, wint_t initial );
 struct cons_pointer read_list( FILE * input, wint_t initial );
@@ -49,8 +54,7 @@ struct cons_pointer read_continuation( FILE* input, wint_t initial) {
     wint_t c;
 
     for ( c = initial;
-       c == '\0' || iswblank( c) || iswcntrl(c); 
+          c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
-       c = fgetwc( input));
 
     switch ( c ) {
     case '\'':
@@ -63,48 +67,76 @@ struct cons_pointer read_continuation( FILE* input, wint_t initial) {
         result = read_string( input, fgetwc( input ) );
         break;
     default:
-    if ( iswdigit( c)) {
+        if ( c == '.' ) {
+            wint_t next = fgetwc( input );
+            if ( iswdigit( next ) ) {
+                ungetwc( next, input );
+                result = read_number( input, c );
+            } else if ( iswblank( next ) ) {
+                /* dotted pair. TODO: this isn't right, we
+                 * really need to backtrack up a level. */
+                result = read_continuation( input, fgetwc( input ) );
+            } else {
+                read_symbol( input, c );
+            }
+        } else if ( iswdigit( c ) ) {
             result = read_number( input, c );
         } else if ( iswprint( c ) ) {
             result = read_symbol( input, c );
         } else {
-      fprintf( stderr, "Unrecognised start of input character %c\n", c);
+            fwprintf( stderr, L"Unrecognised start of input character %c\n",
+                      c );
         }
     }
 
     return result;
 }
 
-
 /**
  * read a number from this input stream, given this initial character.
  */
 struct cons_pointer read_number( FILE * input, wint_t initial ) {
-  int accumulator = 0;
+    struct cons_pointer result = NIL;
+    long int accumulator = 0;
     int places_of_decimals = 0;
     bool seen_period = false;
     wint_t c;
 
-  fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial);
+    fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
 
-  for (c = initial; iswdigit( c); c = fgetwc( input)) {
+    for ( c = initial; iswdigit( c ) || c == btowc( '.' );
-    if ( c == '.') {
+          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 );
+
             if ( seen_period ) {
                 places_of_decimals++;
             }
         }
     }
 
-  /* push back the character read which was not a digit */
+    /*
+     * push back the character read which was not a digit
+     */
     ungetwc( c, input );
 
-  return make_integer( accumulator);
+    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 {
+        result = make_integer( accumulator );
     }
 
+    return result;
+}
 
 /**
  * Read a list from this input stream, which no longer contains the opening
@@ -114,17 +146,17 @@ struct cons_pointer read_list( FILE* input, wint_t initial) {
     struct cons_pointer result = NIL;
 
     if ( initial != ')' ) {
-    fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, 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 ) ) );
     } else {
-    fprintf( stderr, "End of list detected\n");
+        fwprintf( stderr, L"End of list detected\n" );
     }
 
     return result;
 }
 
-
 /**
  * Read a string. This means either a string delimited by double quotes
  * (is_quoted == true), in which case it may contain whitespace but may
@@ -136,9 +168,6 @@ struct cons_pointer read_string( FILE* input, wint_t initial) {
     struct cons_pointer cdr = NIL;
     struct cons_pointer result;
 
-  fwprintf( stderr, L"read_string starting '%C' (%d)\n",
-	    initial, initial);
-
     switch ( initial ) {
     case '\0':
         result = make_string( initial, NIL );
@@ -154,51 +183,54 @@ struct cons_pointer read_string( FILE* input, wint_t initial) {
     return result;
 }
 
-
 struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
     struct cons_pointer cdr = NIL;
     struct cons_pointer result;
 
-  fwprintf( stderr, L"read_symbol starting '%C' (%d)\n",
-	    initial, initial);
-
     switch ( initial ) {
     case '\0':
         result = make_symbol( initial, NIL );
         break;
     case '"':
-    /* THIS IS NOT A GOOD IDEA, but is legal */
+        /*
+         * 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 */
+        /*
+         * unquoted strings may not include right-parenthesis
+         */
         result = make_symbol( '\0', NIL );
-    /* push back the character read */
+        /*
+         * push back the character read
+         */
         ungetwc( initial, input );
         break;
     default:
-    if ( iswblank( initial) || !iswprint( initial)) {
+        if ( iswprint( initial ) && !iswblank( initial ) ) {
-      result = make_symbol( '\0', NIL);
+            result =
-      /* push back the character read */
+                make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
-      ungetwc( initial, input);
         } else {
-      result = make_symbol( initial, read_symbol( input, fgetwc( input)));
+            result = NIL;
+            /*
+             * push back the character read
+             */
+            ungetwc( initial, input );
         }
         break;
     }
 
+    fputws( L"Read symbol '", stderr );
+    print( stderr, result );
+    fputws( L"'\n", stderr );
+
     return result;
 }
 
-
 /**
  * Read the next object on this input stream and return a cons_pointer to it.
  */
 struct cons_pointer read( FILE * input ) {
     return read_continuation( input, fgetwc( input ) );
 }
-
-    
-
-
-    

src/real.c

@@ -0,0 +1,23 @@
+/*
+ * To change this license header, choose License Headers in Project Properties.
+ * To change this template file, choose Tools | Templates
+ * and open the template in the editor.
+ */
+
+#include "conspage.h"
+#include "consspaceobject.h"
+#include "read.h"
+
+/**
+ * Allocate a real number cell representing this value and return a cons 
+ * pointer to it.
+ * @param value the value to wrap;
+ * @return a real number cell wrapping this value.
+ */
+struct cons_pointer make_real( long double value ) {
+    struct cons_pointer result = allocate_cell( REALTAG );
+    struct cons_space_object *cell = &pointer2cell( result );
+    cell->payload.real.value = value;
+
+    return result;
+}

src/real.h

@@ -0,0 +1,32 @@
+/*
+ * To change this license header, choose License Headers in Project Properties.
+ * To change this template file, choose Tools | Templates
+ * and open the template in the editor.
+ */
+
+/*
+ * File:   real.h
+ * Author: simon
+ *
+ * Created on 14 August 2017, 17:25
+ */
+
+#ifndef REAL_H
+#define REAL_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/**
+ * Allocate a real number cell representing this value and return a cons 
+ * pointer to it.
+ * @param value the value to wrap;
+ * @return a real number cell wrapping this value.
+ */
+    struct cons_pointer make_real( long double value );
+
+#ifdef __cplusplus
+}
+#endif
+#endif                          /* REAL_H */

src/repl.c

@@ -0,0 +1,47 @@
+/*
+ * To change this license header, choose License Headers in Project Properties.
+ * To change this template file, choose Tools | Templates
+ * and open the template in the editor.
+ */
+#include <stdbool.h>
+#include <stdio.h>
+#include <wchar.h>
+
+#include "conspage.h"
+#include "consspaceobject.h"
+#include "intern.h"
+#include "lispops.h"
+#include "read.h"
+#include "print.h"
+#include "stack.h"
+
+/**
+ * The read/eval/print loop
+ * @param in_stream the stream to read from;
+ * @param out_stream the stream to write to;
+ * @param err_stream the stream to send errors to;
+ * @param show_prompt true if prompts should be shown.
+ */
+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 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 );
+    }
+}

src/repl.h

@@ -0,0 +1,34 @@
+/*
+ * To change this license header, choose License Headers in Project Properties.
+ * To change this template file, choose Tools | Templates
+ * and open the template in the editor.
+ */
+
+/*
+ * File:   repl.h
+ * Author: simon
+ *
+ * Created on 14 August 2017, 14:40
+ */
+
+#ifndef REPL_H
+#define REPL_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/**
+ * The read/eval/print loop
+ * @param in_stream the stream to read from;
+ * @param out_stream the stream to write to;
+ * @param err_stream the stream to send errors to;
+ * @param show_prompt true if prompts should be shown.
+ */
+    void repl( FILE * in_stream, FILE * out_stream,
+               FILE * error_stream, bool show_prompt );
+
+#ifdef __cplusplus
+}
+#endif
+#endif                          /* REPL_H */

src/stack.c

@@ -23,22 +23,28 @@
 #include "consspaceobject.h"
 #include "conspage.h"
 #include "lispops.h"
+#include "print.h"
 #include "stack.h"
 
 /**
- * Allocate a new stack frame with its previous pointer set to this value,
+ * Make an empty stack frame, and return it.
- * its arguments set up from these args, evaluated in this env.
+ * @param previous the current top-of-stack;
+ * @param env the environment in which evaluation happens.
+ * @return the new frame.
  */
-struct stack_frame* make_stack_frame( struct stack_frame* previous,
+struct stack_frame *make_empty_frame( struct stack_frame *previous,
-				      struct cons_pointer args,
                                       struct cons_pointer env ) {
-  /* TODO: later, pop a frame off a free-list of stack frames */
     struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
+    /*
+     * TODO: later, pop a frame off a free-list of stack frames
+     */
 
     result->previous = previous;
 
-  /* clearing the frame with memset would probably be slightly quicker, but
+    /*
-   * this is clear. */
+     * clearing the frame with memset would probably be slightly quicker, but
+     * this is clear.
+     */
     result->more = NIL;
     result->function = NIL;
 
@@ -46,31 +52,79 @@ struct stack_frame* make_stack_frame( struct stack_frame* previous,
         result->arg[i] = NIL;
     }
 
-  int i = 0;                            /* still an index into args, so same
+    return result;
-					 * name will do */
+}
 
-  while ( ! nilp( args)) {              /* iterate down the arg list filling in
+
-					 * the arg slots in the frame. When there
+/**
-					 * are no more slots, if there are still
+ * Allocate a new stack frame with its previous pointer set to this value,
-					 * args, stash them on more */
+ * its arguments set up from these args, evaluated in this env.
+ * @param previous the current top-of-stack;
+ * @args the arguments to load into this frame;
+ * @param env the environment in which evaluation happens.
+ * @return the new frame.
+ */
+struct stack_frame *make_stack_frame( struct stack_frame *previous,
+                                      struct cons_pointer args,
+                                      struct cons_pointer env ) {
+    struct stack_frame *result = make_empty_frame( previous, env );
+
+    for ( int i = 0; i < args_in_frame && !nilp( 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 */
         struct cons_space_object cell = pointer2cell( args );
 
-    if ( i < args_in_frame) {
+        /*
-      /* TODO: if we were running on real massively parallel hardware, each
+         * TODO: if we were running on real massively parallel hardware,
-       * arg except the first should be handed off to another processor to
+         * each arg except the first should be handed off to another
-       * be evaled in parallel */
+         * processor to be evaled in parallel; but see notes here:
-      result->arg[i] = lisp_eval( cell.payload.cons.car, env, result);
+         * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
+         */
+        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] );
+        free_stack_frame( arg_frame );
 
         args = cell.payload.cons.cdr;
-    } else {
+    }
-      /* TODO: this isn't right. These args should also each be evaled. */
+    /*
+     * TODO: this isn't right. These args should also each be evaled.
+     */
     result->more = args;
     inc_ref( result->more );
 
-      args = NIL;
+    return result;
 }
+
+/**
+ * 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;
+ * @param env the execution environment;
+ * @return a new special frame.
+ */
+struct stack_frame *make_special_frame( struct stack_frame *previous,
+                                        struct cons_pointer args,
+                                        struct cons_pointer env ) {
+    struct stack_frame *result = make_empty_frame( previous, env );
+
+    for ( int i = 0; i < args_in_frame && !nilp( 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 */
+        struct cons_space_object cell = pointer2cell( args );
+
+        result->arg[i] = cell.payload.cons.car;
+        inc_ref( result->arg[i] );
+
+        args = cell.payload.cons.cdr;
     }
+    result->more = args;
+    inc_ref( args );
 
     return result;
 }
@@ -79,7 +133,9 @@ struct stack_frame* make_stack_frame( struct stack_frame* previous,
  * Free this stack frame.
  */
 void free_stack_frame( struct stack_frame *frame ) {
-  /* TODO: later, push it back on the stack-frame freelist */
+    /*
+     * TODO: later, push it back on the stack-frame freelist
+     */
     for ( int i = 0; i < args_in_frame; i++ ) {
         dec_ref( frame->arg[i] );
     }
@@ -88,6 +144,22 @@ void free_stack_frame( struct stack_frame* frame) {
     free( frame );
 }
 
+
+/**
+ * Dump a stackframe to this stream for debugging
+ * @param output the stream
+ * @param frame the frame
+ */
+void dump_frame( FILE * output, struct stack_frame *frame ) {
+    fputws( L"Dumping stack frame\n", output );
+    for ( int arg = 0; arg < args_in_frame; arg++ ) {
+        fwprintf( output, L"Arg %d:", arg );
+        print( output, frame->arg[arg] );
+        fputws( L"\n", output );
+    }
+}
+
+
 /**
  * Fetch a pointer to the value of the local variable at this index.
  */

src/stack.h

@@ -24,13 +24,44 @@
 #ifndef __stack_h
 #define __stack_h
 
+/**
+ * Make an empty stack frame, and return it.
+ * @param previous the current top-of-stack;
+ * @param env the environment in which evaluation happens.
+ * @return the new frame.
+ */
+struct stack_frame *make_empty_frame( struct stack_frame *previous,
+                                      struct cons_pointer env );
+
 struct stack_frame *make_stack_frame( struct stack_frame *previous,
                                       struct cons_pointer args,
                                       struct cons_pointer env );
 void free_stack_frame( struct stack_frame *frame );
+
+/**
+ * Dump a stackframe to this stream for debugging
+ * @param output the stream
+ * @param frame the frame
+ */
+void dump_frame( FILE * output, struct stack_frame *frame );
+
 struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
 
-/* struct stack_frame is defined in consspaceobject.h to break circularity
+/**
- * TODO: refactor. */
+ * 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;
+ * @param env the execution environment;
+ * @return a new special frame.
+ */
+struct stack_frame *make_special_frame( struct stack_frame *previous,
+                                        struct cons_pointer args,
+                                        struct cons_pointer env );
+
+/*
+ * struct stack_frame is defined in consspaceobject.h to break circularity
+ * TODO: refactor. 
+ */
 
 #endif

src/version.h

@@ -8,5 +8,4 @@
  *  Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
-
+#define VERSION "0.0.1"
-#define VERSION "0.0.0"

unit-tests/add.sh

@@ -0,0 +1,26 @@
+#!/bin/bash
+
+expected='5'
+actual=`echo "(add 2 3)" | 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
+
+expected='5.5000'
+actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    exit 0
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+

unit-tests/apply.sh

@@ -0,0 +1,13 @@
+#!/bin/bash
+
+expected='1'
+actual=`echo "(apply 'add '(1))"| 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

unit-tests/complex-list.sh

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

unit-tests/empty-list.sh.bash

@@ -0,0 +1,19 @@
+#!/bin/bash
+# 
+# File:   empty-list.sh.bash
+# Author: simon
+#
+# Created on 14-Aug-2017, 15:06:40
+#
+
+expected=nil
+actual=`echo "'()" | 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

unit-tests/empty-string.sh

@@ -1,7 +1,7 @@
 #!/bin/bash
 
 expected="\"\""
-actual=`echo '""' | target/psse 2> /dev/null`
+actual=`echo '""' | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "$expected" = "$actual" ]
 then

unit-tests/fred.sh

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

unit-tests/integer-allocation.sh

@@ -2,7 +2,7 @@
 
 value=354
 expected="Integer cell: value ${value}"
-echo ${value} | target/psse 2>&1 | grep "${expected}" > /dev/null
+echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null
 
 if [ $? -eq 0 ]
 then

unit-tests/integer.sh

@@ -1,7 +1,7 @@
 #!/bin/bash
 
 expected="354"
-actual=`echo ${expected} | target/psse 2> /dev/null`
+actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "${expected}" = "${actual}" ]
 then

unit-tests/nil.sh

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

unit-tests/quote.sh

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

unit-tests/quoted-list.sh

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

unit-tests/simple-list.sh

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

unit-tests/string-allocation.sh

@@ -2,7 +2,7 @@
 
 value='"Fred"'
 expected="String cell: character 'F'"
-echo ${value} | target/psse 2>&1 | grep "${expected}" > /dev/null
+echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null
 
 if [ $? -eq 0 ]
 then

unit-tests/string-with-spaces.sh

@@ -1,7 +1,7 @@
 #!/bin/bash
 
 expected='"Strings should be able to include spaces (and other stuff)!"'
-actual=`echo ${expected} | target/psse 2> /dev/null`
+actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "${expected}" = "${actual}" ]
 then