Merge branch 'feature/exp2' into develop

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

@@ -164,11 +164,12 @@ struct cons_pointer allocate_cell( char *tag ) {
             cell->payload.cons.car = NIL;
             cell->payload.cons.cdr = NIL;
 
+#ifdef DEBUG
             fprintf( stderr,
                      "Allocated cell of type '%s' at %d, %d \n", tag,
                      result.page, result.offset );
-            // dump_object( stderr, result );
+#endif
-        } else {
+         } else {
             fprintf( stderr, "WARNING: Allocating non-free cell!" );
         }
     }
@@ -188,7 +189,7 @@ void initialise_cons_pages(  ) {
         make_cons_page(  );
         conspageinitihasbeencalled = true;
     } else {
-        fprintf( stderr,
+        fwprintf( stderr,
-                 "WARNING: conspageinit() called a second or subsequent time\n" );
+                 L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
     }
 }

src/conspage.h

@@ -4,23 +4,27 @@
 #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.
  */
 #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];

src/consspaceobject.c

@@ -19,6 +19,7 @@
 
 #include "conspage.h"
 #include "consspaceobject.h"
+#include "print.h"
 
 /**
  * Check that the tag on the cell at this pointer is this tag
@@ -73,28 +74,47 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
               cell.tag.bytes[3],
               cell.tag.value, pointer.page, pointer.offset, cell.count );
 
-    if ( check_tag( pointer, CONSTAG ) ) {
+    switch ( cell.tag.value) {
+    case CONSTV:
         fwprintf( output,
                   L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n",
                   cell.payload.cons.car.page,
                   cell.payload.cons.car.offset,
                   cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
-    } else if ( check_tag( pointer, INTEGERTAG ) ) {
+        break;
+    case INTEGERTV:
         fwprintf( output,
                   L"\t\tInteger cell: value %ld\n",
                   cell.payload.integer.value );
-    } else if ( check_tag( pointer, FREETAG ) ) {
+        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, REALTAG ) ) {
+        break;
+    case REALTV:
         fwprintf( output, L"\t\tReal cell: value %Lf\n",
                   cell.payload.real.value );
-    } else if ( check_tag( pointer, STRINGTAG ) ) {
+        break;
+    case STRINGTV:
         fwprintf( output,
                   L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d\n",
                   cell.payload.string.character,
                   cell.payload.string.cdr.page,
                   cell.payload.string.cdr.offset );
+        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\n",
+                  cell.payload.string.character,
+                  cell.payload.string.cdr.page,
+                  cell.payload.string.cdr.offset );
+        fwprintf( output, L"\t\t value:");
+        print(output, pointer);
+        fwprintf( output, L"\n");
+        break;
     }
 }
 
@@ -150,7 +170,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
         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
+        /* TODO: There's a problem here. Sometimes the offsets on
          * strings are quite massively off. */
         cell->payload.string.cdr.offset = tail.offset;
     } else {

src/consspaceobject.h

@@ -156,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))
 
@@ -418,14 +418,6 @@ struct cons_pointer make_cons( struct cons_pointer car,
  */
 struct cons_pointer make_function( struct cons_pointer src,
                                    struct cons_pointer ( *executable )
-
-
-
-
-
-
-
-
                                     ( struct stack_frame *,
                                       struct cons_pointer ) );
 
@@ -434,14 +426,6 @@ struct cons_pointer make_function( struct cons_pointer src,
  */
 struct cons_pointer make_special( struct cons_pointer src,
                                   struct cons_pointer ( *executable )
-
-
-
-
-
-
-
-
                                    ( struct cons_pointer s_expr,
                                      struct cons_pointer env,
                                      struct stack_frame * frame ) );

src/equal.c

@@ -22,6 +22,21 @@ 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
  * identical structure, else false.
@@ -29,15 +44,18 @@ 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 ) {
+        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 );
-        } else if ( stringp( a ) && stringp( b ) ) {
+            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
@@ -48,17 +66,27 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                 cell_b->payload.string.character
                 && equal( cell_a->payload.string.cdr,
                           cell_b->payload.string.cdr );
-        } else if ( numberp( a ) && numberp( b ) ) {
+            break;
-            double num_a = numeric_value( a );
+        case INTEGERTV:
-            double num_b = numeric_value( b );
+        case REALTV:
-            double max =
+            {
-                fabs( num_a ) > fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
+                double num_a = numeric_value( a );
+                double num_b = numeric_value( b );
+                double max =
+                    fabs( num_a ) >
+                    fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
 
-            /*
+                /*
-             * not more different than one part in a million - close enough 
+                 * not more different than one part in a million - close enough 
-             */
+                 */
-            result = fabs( num_a - num_b ) < ( max / 1000000.0 );
+                result = fabs( num_a - num_b ) < ( max / 1000000.0 );
+            }
+            break;
+        default:
+            result = false;
+            break;
         }
+
         /*
          * 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 

src/init.c

@@ -19,19 +19,21 @@
 #include "consspaceobject.h"
 #include "intern.h"
 #include "lispops.h"
+#include "peano.h"
+#include "print.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 ) );
+               make_function( NIL, executable ));
 }
 
 void bind_special( char *name, struct cons_pointer ( *executable )
                     ( struct cons_pointer s_expr, struct cons_pointer env,
                       struct stack_frame * frame ) ) {
-    deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ),
+    deep_bind( c_string_to_lisp_symbol( name ),
-               make_special( NIL, executable ) );
+               make_special( NIL, executable ));
 }
 
 int main( int argc, char *argv[] ) {
@@ -54,14 +56,14 @@ int main( int argc, char *argv[] ) {
             show_prompt = true;
             break;
         default:
-            fprintf( stderr, "Unexpected option %c\n", option );
+            fwprintf( stderr, L"Unexpected option %c\n", option );
             break;
         }
     }
 
     if ( show_prompt ) {
-        fprintf( stdout,
+        fwprintf( stdout,
-                 "Post scarcity software environment version %s\n\n",
+                 L"Post scarcity software environment version %s\n\n",
                  VERSION );
     }
 
@@ -70,8 +72,9 @@ int main( int argc, char *argv[] ) {
     /*
      * privileged variables (keywords) 
      */
-    deep_bind( intern( c_string_to_lisp_string( "nil" ), oblist ), NIL );
+    
-    deep_bind( intern( c_string_to_lisp_string( "t" ), oblist ), TRUE );
+    deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
+    deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
 
     /*
      * primitive function operations 
@@ -84,6 +87,10 @@ int main( int argc, char *argv[] ) {
     bind_function( "equal", &lisp_equal );
     bind_function( "read", &lisp_read );
     bind_function( "print", &lisp_print );
+    
+    bind_function( "add", &lisp_add);
+    bind_function( "multiply", &lisp_multiply);
+    bind_function( "subtract", &lisp_subtract);
 
     /*
      * primitive special forms 
@@ -91,7 +98,12 @@ int main( int argc, char *argv[] ) {
     bind_special( "apply", &lisp_apply );
     bind_special( "eval", &lisp_eval );
     bind_special( "quote", &lisp_quote );
-
+    
+    
+    /* 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 ) {

src/integer.c

@@ -20,7 +20,7 @@
  * 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 );
 
@@ -41,7 +41,7 @@ struct cons_pointer make_integer( long int value ) {
     struct cons_space_object *cell = &pointer2cell( result );
     cell->payload.integer.value = value;
 
-    dump_object( stderr, result);
+    dump_object( stderr, result );
 
     return result;
 }

src/integer.h

@@ -11,7 +11,7 @@
 #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.

src/intern.c

@@ -91,7 +91,7 @@ struct cons_pointer c_assoc( 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
+struct cons_pointer 
 bind( struct cons_pointer key, struct cons_pointer value,
       struct cons_pointer store ) {
     return make_cons( make_cons( key, value ), store );

src/lispops.c

@@ -102,10 +102,10 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
     switch ( fn_cell.tag.value ) {
     case SPECIALTV:
         {
-            struct cons_space_object special = pointer2cell( fn_pointer );
+            struct stack_frame *frame =
+                make_special_frame( my_frame, args, env );
             result =
-                ( *special.payload.special.executable ) ( args, env,
+                ( *fn_cell.payload.special.executable ) ( args, env, frame );
-                                                          my_frame );
         }
         break;
 
@@ -122,7 +122,7 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
              * the trick: pass the remaining arguments and environment to the
              * executable code which is the payload of the function object. 
              */
-            result = ( *function.payload.function.executable ) ( frame, env );
+            result = ( *fn_cell.payload.function.executable ) ( frame, env );
             free_stack_frame( frame );
         }
         break;
@@ -164,15 +164,9 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
     struct cons_pointer result = s_expr;
     struct cons_space_object cell = pointer2cell( s_expr );
 
-    fprintf( stderr, "In eval; about to make stack frame" );
-
-    struct stack_frame *frame = make_stack_frame( previous, s_expr, env );
-
-    fprintf( stderr, "In eval; stack frame made" );
-
     switch ( cell.tag.value ) {
     case CONSTV:
-        result = eval_cons( s_expr, env, frame );
+        result = eval_cons( s_expr, env, previous);
         break;
 
     case SYMBOLTV:
@@ -182,7 +176,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
                 struct cons_pointer message =
                     c_string_to_lisp_string
                     ( "Attempt to take value of unbound symbol." );
-                result = lisp_throw( message, frame );
+                result = lisp_throw( message, previous );
             } else {
                 result = c_assoc( canonical, env );
             }
@@ -197,8 +191,6 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
          */
     }
 
-    free_stack_frame( frame );
-
     return result;
 }
 
@@ -212,7 +204,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
 struct cons_pointer
 lisp_quote( struct cons_pointer args, struct cons_pointer env,
             struct stack_frame *frame ) {
-    return c_car( args );
+    return frame->arg[0];
 }
 
 /**
@@ -360,10 +352,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
  */
 struct cons_pointer
 lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
-    fprintf( stderr, "\nERROR: " );
+    fwprintf( stderr, L"\nERROR: " );
     print( stderr, message );
-    fprintf( stderr,
+    fwprintf( stderr,
-             "\n\nAn exception was thrown and I've no idea what to do now\n" );
+             L"\n\nAn exception was thrown and I've no idea what to do now\n" );
 
     exit( 1 );
 }

src/peano.c

@@ -0,0 +1,149 @@
+/**
+ * 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 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;
+        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;
+        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,51 @@
+/**
+ * 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

@@ -89,7 +89,7 @@ void print( FILE * output, struct cons_pointer pointer ) {
         fwprintf( output, L"nil" );
         break;
     case REALTV:
-        fwprintf( output, L"%lf", cell.payload.real.value );
+        fwprintf( output, L"%Lf", cell.payload.real.value );
         break;
     case STRINGTV:
         print_string( output, pointer );
@@ -100,6 +100,12 @@ void print( FILE * output, struct cons_pointer pointer ) {
     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",

src/read.c

@@ -82,6 +82,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) {
  * read a number from this input stream, given this initial character.
  */
 struct cons_pointer read_number( FILE * input, wint_t initial ) {
+  struct cons_pointer result = NIL;
     long int accumulator = 0;
     int places_of_decimals = 0;
     bool seen_period = false;
@@ -96,7 +97,8 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
         } else {
             accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
 
-            fprintf( stderr, "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++;
@@ -110,10 +112,16 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
     ungetwc( c, input );
 
     if ( seen_period ) {
-        return make_real( accumulator / pow( 10, places_of_decimals ) );
+      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 {
-        return make_integer( accumulator );
+        result = make_integer( accumulator );
     }
+
+    return result;
 }
 
 /**
@@ -146,8 +154,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 );
@@ -167,8 +173,6 @@ 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 );
@@ -190,16 +194,16 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
         ungetwc( initial, input );
         break;
     default:
-        if ( iswblank( initial ) || !iswprint( initial ) ) {
+        if ( iswalnum( initial ) ) {
-            result = make_symbol( '\0', NIL );
+            result =
+                make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
+        } else {
+            result = NIL;
             /*
              * push back the character read
              */
             ungetwc( initial, input );
-        } else {
+        } 
-            result =
-                make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
-        }
         break;
     }
 

src/real.h

@@ -24,7 +24,7 @@ extern "C" {
  * @param value the value to wrap;
  * @return a real number cell wrapping this value.
  */
-    struct cons_pointer make_real( double value );
+struct cons_pointer make_real( double value );
 
 #ifdef __cplusplus
 }

src/repl.c

@@ -31,19 +31,13 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
         struct cons_pointer input = read( in_stream );
         fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page,
                   input.offset );
-        if ( show_prompt ) {
+        print( error_stream, input);
-            fwprintf( out_stream, L"\n-> " );
-        }
 
-	/* OK, I think what's going wrong here is we're passing by 
+        struct cons_pointer value = lisp_eval( input, oblist, NULL );
-	 * value and I think we should be passing by reference.
+        // print( out_stream, input );
-         * I'm not certain about that, and as it will be a really
-         * major change I'm going to think some more before making
-	 * in */
-        // print( out_stream, lisp_eval(input, oblist, NULL));
-        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/stack.c

@@ -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. 
+ * 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, 
+ * But such a stack would be costly to search. The design sketched here,
- * with stack frames as special objects, SHOULD be substantially more 
+ * 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.
  *
@@ -23,6 +23,7 @@
 #include "consspaceobject.h"
 #include "conspage.h"
 #include "lispops.h"
+#include "print.h"
 #include "stack.h"
 
 /**
@@ -33,7 +34,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
                                       struct cons_pointer args,
                                       struct cons_pointer env ) {
     /*
-     * TODO: later, pop a frame off a free-list of stack frames 
+     * TODO: later, pop a frame off a free-list of stack frames
      */
     struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
 
@@ -41,7 +42,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
 
     /*
      * clearing the frame with memset would probably be slightly quicker, but
-     * this is clear. 
+     * this is clear.
      */
     result->more = NIL;
     result->function = NIL;
@@ -50,36 +51,74 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
         result->arg[i] = NIL;
     }
 
-    int i = 0;                  /* still an index into args, so same name will 
+    for (int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
-                                 * do */
+      /* iterate down the arg list filling in the arg slots in the
-
+       * frame. When there are no more slots, if there are still args,
-    while ( !nilp( args ) ) {   /* iterate down the arg list filling in the
+       * stash them on more */
-                                 * arg slots in the frame. When there are no
-                                 * more slots, if there are still args, stash
-                                 * them on more */
         struct cons_space_object cell = pointer2cell( args );
 
-        if ( i < args_in_frame ) {
             /*
              * TODO: if we were running on real massively parallel hardware,
              * each arg except the first should be handed off to another
-             * processor to be evaled in parallel 
+             * processor to be evaled in parallel
              */
             result->arg[i] = lisp_eval( cell.payload.cons.car, env, result );
             inc_ref( result->arg[i] );
 
             args = cell.payload.cons.cdr;
-        } else {
+        }
             /*
-             * TODO: this isn't right. These args should also each be evaled. 
+             * 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 ) {
+    /*
+     * TODO: later, pop a frame off a free-list of stack frames
+     */
+    struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
+
+    result->previous = previous;
+
+    /*
+     * clearing the frame with memset would probably be slightly quicker, but
+     * this is clear.
+     */
+    result->more = NIL;
+    result->function = NIL;
+
+    for ( int i = 0; i < args_in_frame; i++ ) {
+        result->arg[i] = NIL;
     }
 
+    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;
 }
 
@@ -88,7 +127,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
  */
 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] );

src/stack.h

@@ -30,6 +30,18 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
 void free_stack_frame( 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 
+ * 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. 

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 | head -1`
+actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -1`
 
 if [ "${expected}" = "${actual}" ]
 then

unit-tests/quote.sh

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

unit-tests/quoted-list.sh

@@ -1,6 +1,6 @@
 #!/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 | head -1`
 
 if [ "${expected}" = "${actual}" ]

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 | head -1`
+actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -1`
 
 if [ "${expected}" = "${actual}" ]
 then