Much work, all I think positive, but defun still doesn't work.

lisp/defun.lisp

@@ -4,8 +4,8 @@
       (nlambda
        form
        (cond ((symbolp (car form))
-         (set! (car form) (apply lambda (cdr form)))))
+         (set (car form) (apply lambda (cdr form))))
-       (t nil)))
+         (t nil))))
 
 (defun! square (x) (* x x))
 

src/conspage.c

@@ -127,6 +127,33 @@ void dump_pages( FILE * output ) {
 void free_cell( struct cons_pointer pointer ) {
     struct cons_space_object *cell = &pointer2cell( pointer );
 
+    switch ( cell->tag.value ) {
+            /* for all the types of cons-space object which point to other
+             * cons-space objects, cascade the decrement. */
+        case CONSTV:
+            dec_ref( cell->payload.cons.car );
+            dec_ref( cell->payload.cons.cdr );
+            break;
+        case EXCEPTIONTV:
+            dec_ref( cell->payload.exception.message );
+            break;
+        case FUNCTIONTV:
+            dec_ref( cell->payload.function.source );
+            break;
+        case LAMBDATV:
+        case NLAMBDATV:
+            dec_ref( cell->payload.lambda.args );
+            dec_ref( cell->payload.lambda.body );
+            break;
+        case SPECIALTV:
+            dec_ref( cell->payload.special.source );
+            break;
+        case STRINGTV:
+        case SYMBOLTV:
+            dec_ref( cell->payload.string.cdr );
+            break;
+    }
+
     if ( !check_tag( pointer, FREETAG ) ) {
         if ( cell->count == 0 ) {
             fwprintf( stderr, L"Freeing cell " );

src/consspaceobject.c

@@ -177,6 +177,9 @@ struct cons_pointer make_exception( struct cons_pointer message,
     struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
+    inc_ref( pointer );         /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
+
+    inc_ref( message );
     cell->payload.exception.message = message;
     cell->payload.exception.frame = frame;
 
@@ -206,6 +209,9 @@ struct cons_pointer make_lambda( struct cons_pointer args,
                                  struct cons_pointer body ) {
     struct cons_pointer pointer = allocate_cell( LAMBDATAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
+
+    inc_ref( pointer );         /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
+
     inc_ref( args );
     inc_ref( body );
     cell->payload.lambda.args = args;
@@ -221,6 +227,9 @@ struct cons_pointer make_lambda( struct cons_pointer args,
 struct cons_pointer make_nlambda( struct cons_pointer args,
                                   struct cons_pointer body ) {
     struct cons_pointer pointer = allocate_cell( NLAMBDATAG );
+
+    inc_ref( pointer );         /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
+
     struct cons_space_object *cell = &pointer2cell( pointer );
     inc_ref( args );
     inc_ref( body );

src/equal.c

@@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && ( equal( cell_a->payload.string.cdr,
                                 cell_b->payload.string.cdr )
                          || ( end_of_string( cell_a->payload.string.cdr )
-                              && end_of_string( cell_b->payload.
+                              && end_of_string( cell_b->payload.string.
-                                                string.cdr ) ) );
+                                                cdr ) ) );
                 break;
             case INTEGERTV:
                 result =

src/init.c

@@ -92,8 +92,10 @@ int main( int argc, char *argv[] ) {
     bind_function( "eval", &lisp_eval );
     bind_function( "multiply", &lisp_multiply );
     bind_function( "read", &lisp_read );
+    bind_function( "oblist", &lisp_oblist );
     bind_function( "print", &lisp_print );
     bind_function( "progn", &lisp_progn );
+    bind_function( "set", &lisp_set );
     bind_function( "subtract", &lisp_subtract );
     bind_function( "type", &lisp_type );
 
@@ -112,11 +114,6 @@ int main( int argc, char *argv[] ) {
     bind_special( "quote", &lisp_quote );
     bind_special( "set!", &lisp_set_shriek );
 
-
-    /* bind the oblist last, at this stage. Something clever needs to be done
-     * here and I'm not sure what it is. */
-    deep_bind( c_string_to_lisp_symbol( "oblist" ), oblist );
-
     repl( stdin, stdout, stderr, show_prompt );
 
     if ( dump_at_end ) {

src/intern.c

@@ -4,11 +4,11 @@
  * For now this implements an oblist and shallow binding; local environments can
  * be consed onto the front of the oblist. Later, this won't do; bindings will happen
  * in namespaces, which will probably be implemented as hash tables.
- * 
+ *
  * Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
  * so when a symbol is rebound in the master oblist, what in fact we do is construct
  * a new oblist without the previous binding but with the new binding. Anything which,
- * prior to this action, held a pointer to the old oblist (as all current threads' 
+ * prior to this action, held a pointer to the old oblist (as all current threads'
  * environments must do) continues to hold a pointer to the old oblist, and consequently
  * doesn't see the change. This is probably good but does mean you cannot use bindings
  * on the oblist to signal between threads.
@@ -26,12 +26,12 @@
 #include "print.h"
 
 /**
- * The object list. What is added to this during system setup is 'global', that is, 
+ * The object list. What is added to this during system setup is 'global', that is,
  * visible to all sessions/threads. What is added during a session/thread is local to
  * that session/thread (because shallow binding). There must be some way for a user to
  * make the contents of their own environment persistent between threads but I don't
  * know what it is yet. At some stage there must be a way to rebind deep values so
- * they're visible to all users/threads, but again I don't yet have any idea how 
+ * they're visible to all users/threads, but again I don't yet have any idea how
  * that will work.
  */
 struct cons_pointer oblist = NIL;
@@ -114,8 +114,8 @@ bind( struct cons_pointer key, struct cons_pointer value,
 }
 
 /**
- * Binds this key to this value in the global oblist, but doesn't affect the 
+ * 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 
+ * current environment. May not be useful except in bootstrapping (and even
  * there it may not be especially useful).
  */
 struct cons_pointer
@@ -133,10 +133,9 @@ struct cons_pointer
 intern( struct cons_pointer key, struct cons_pointer environment ) {
     struct cons_pointer result = environment;
     struct cons_pointer canonical = internedp( key, environment );
-
     if ( nilp( canonical ) ) {
         /*
-         * not currently bound 
+         * not currently bound
          */
         result = bind( key, NIL, environment );
     }

src/lispops.c

@@ -63,7 +63,7 @@ struct cons_pointer c_car( struct cons_pointer arg ) {
 struct cons_pointer c_cdr( struct cons_pointer arg ) {
     struct cons_pointer result = NIL;
 
-    if ( consp( arg ) ) {
+    if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) {
         result = pointer2cell( arg ).payload.cons.cdr;
     }
 
@@ -115,6 +115,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
                    eval_forms( frame, c_cdr( list ), env ) ) : NIL;
 }
 
+/**
+ * Return the object list (root namespace).
+ *
+ * (oblist)
+ */
+struct cons_pointer
+lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) {
+    return oblist;
+}
+
 
 /**
  * used to construct the body for `lambda` and `nlambda` expressions.
@@ -123,12 +133,18 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
     struct cons_pointer body =
         !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
 
-    for ( int i = args_in_frame - 1; i >= 0; i-- ) {
+    for ( int i = args_in_frame - 1; i > 0; i-- ) {
-        if ( !nilp( frame->arg[i] ) ) {
+        if ( !nilp( body ) ) {
+            body = make_cons( frame->arg[i], body );
+        } else if ( !nilp( frame->arg[i] ) ) {
             body = make_cons( frame->arg[i], body );
         }
     }
 
+    fputws( L"compose_body returning ", stderr );
+    print( stderr, body );
+    fputws( L"\n", stderr );
+
     return body;
 }
 
@@ -169,7 +185,7 @@ struct cons_pointer
 eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
              struct cons_pointer env ) {
     struct cons_pointer result = NIL;
-    fwprintf( stderr, L"eval_lambda called" );
+    fwprintf( stderr, L"eval_lambda called\n" );
 
     struct cons_pointer new_env = env;
     struct cons_pointer names = cell.payload.lambda.args;
@@ -278,7 +294,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
             {
                 struct stack_frame *next =
                     make_special_frame( frame, args, env );
-                result = ( *fn_cell.payload.special.executable ) ( next, env );
+                fputws( L"Stack frame for nlambda\n", stderr );
+                dump_frame( stderr, next );
+                result = eval_lambda( fn_cell, next, env );
                 if ( !exceptionp( result ) ) {
                     /* if we're returning an exception, we should NOT free the
                      * stack frame. Corollary is, when we free an exception, we
@@ -440,13 +458,45 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
     return frame->arg[0];
 }
 
+
+/**
+ * (set name value)
+ * (set name value namespace)
+ *
+ * Function.
+ * `namespace` defaults to the oblist.
+ * Binds the value of `name` in the `namespace` to value of `value`, altering
+ * the namespace in so doing. `namespace` defaults to the value of `oblist`.
+ */
+struct cons_pointer
+lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+    struct cons_pointer namespace =
+        nilp( frame->arg[2] ) ? oblist : frame->arg[2];
+
+    if ( symbolp( frame->arg[0] ) ) {
+        deep_bind( frame->arg[0], frame->arg[1] );
+        result = frame->arg[1];
+    } else {
+        result =
+            make_exception( make_cons
+                            ( c_string_to_lisp_string
+                              ( "The first argument to `set!` is not a symbol: " ),
+                              make_cons( frame->arg[0], NIL ) ), frame );
+    }
+
+    return result;
+}
+
+
 /**
  * (set! symbol value)
  * (set! symbol value namespace)
  *
  * Special form.
  * `namespace` defaults to the oblist.
- * Binds `symbol` to `value` in the namespace, altering the namespace in so doing.
+ * Binds `symbol` in the `namespace` to value of `value`, altering
+ * the namespace in so doing. `namespace` defaults to the value of `oblist`.
  */
 struct cons_pointer
 lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
@@ -455,13 +505,15 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
         nilp( frame->arg[2] ) ? oblist : frame->arg[2];
 
     if ( symbolp( frame->arg[0] ) ) {
-        deep_bind( frame->arg[0], eval_form( frame, frame->arg[1], env ) );
+        struct cons_pointer val = eval_form( frame, frame->arg[1], env );
-        result = frame->arg[1];
+        deep_bind( frame->arg[0], val );
+        result = val;
     } else {
         result =
-            make_exception( c_string_to_lisp_string
+            make_exception( make_cons
-                            ( "The first argument to `set!` is not a symbol" ),
+                            ( c_string_to_lisp_string
-                            frame );
+                              ( "The first argument to `set!` is not a symbol: " ),
+                              make_cons( frame->arg[0], NIL ) ), frame );
     }
 
     return result;
@@ -670,15 +722,16 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
 
         if ( consp( clause_pointer ) ) {
             struct cons_space_object cell = pointer2cell( clause_pointer );
-          result = eval_form( frame, c_car( clause_pointer ), env);
+            result = eval_form( frame, c_car( clause_pointer ), env );
 
             if ( !nilp( result ) ) {
-                struct cons_pointer vals = eval_forms( frame, c_cdr( clause_pointer ), env );
+                struct cons_pointer vals =
+                    eval_forms( frame, c_cdr( clause_pointer ), env );
 
-              while (consp( vals)) {
+                while ( consp( vals ) ) {
-                result = c_car(vals);
+                    result = c_car( vals );
-                vals = c_cdr(vals);
+                    vals = c_cdr( vals );
-              }
+                }
 
                 done = true;
             }
@@ -698,6 +751,11 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
 
 /**
  * TODO: make this do something sensible somehow.
+ * This requires that a frame be a heap-space object with a cons-space
+ * object pointing to it. Then this should become a normal lisp function
+ * which expects a normally bound frame and environment, such that
+ * frame->arg[0] is the message, and frame->arg[1] is the cons-space
+ * pointer to the frame in which the exception occurred.
  */
 struct cons_pointer
 lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {

src/lispops.h

@@ -71,6 +71,12 @@ struct cons_pointer lisp_eval( struct stack_frame *frame,
 struct cons_pointer lisp_apply( struct stack_frame *frame,
                                 struct cons_pointer env );
 
+struct cons_pointer
+lisp_oblist( struct stack_frame *frame, struct cons_pointer env );
+
+struct cons_pointer
+lisp_set( struct stack_frame *frame, struct cons_pointer env );
+
 struct cons_pointer
 lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
 

src/print.c

@@ -132,8 +132,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case LAMBDATV:
             print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.lambda.
+                                                 cell.payload.
-                                                 body ) ) );
+                                                 lambda.body ) ) );
             break;
         case NILTV:
             fwprintf( output, L"nil" );
@@ -141,8 +141,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
         case NLAMBDATV:
             print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                                 cell.payload.lambda.
+                                                 cell.payload.
-                                                 body ) ) );
+                                                 lambda.body ) ) );
             break;
         case READTV:
             fwprintf( output, L"(Input stream)" );
@@ -173,8 +173,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
             print_string( output, pointer );
             break;
         case SYMBOLTV:
-            if ( print_use_colours )
+            if ( print_use_colours ) {
                 fputws( L"\x1B[1;33m", output );
+            }
             print_string_contents( output, pointer );
             break;
         case SPECIALTV:
@@ -185,10 +186,10 @@ void print( FILE * output, struct cons_pointer pointer ) {
             break;
         default:
             fwprintf( stderr,
-                      L"%sError: Unrecognised tag value %d (%c%c%c%c)%s\n",
+                      L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",
-                      "\x1B[31m",
+                      print_use_colours ? "\x1B[31m" : "",
                       cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
-                      cell.tag.bytes[2], cell.tag.bytes[3], "\x1B[39m" );
+                      cell.tag.bytes[2], cell.tag.bytes[3] );
             break;
     }
 

src/repl.c

@@ -97,10 +97,12 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
 
             struct cons_pointer val = repl_eval( input );
 
-            /* suppress the 'end of stream' exception */
+            if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
-            if ( !exceptionp( val ) &&
+                /* suppress the 'end of stream' exception */
-                 !feof( pointer2cell( input_stream ).payload.stream.
+                if ( !exceptionp( val ) ) {
-                        stream ) ) {
+                    repl_print( output_stream, val );
+                }
+            } else {
                 repl_print( output_stream, val );
             }
         }

src/stack.c

@@ -169,9 +169,10 @@ void dump_frame( FILE * output, struct stack_frame *frame ) {
     for ( int arg = 0; arg < args_in_frame; arg++ ) {
         struct cons_space_object cell = pointer2cell( frame->arg[arg] );
 
-        fwprintf( output, L"Arg %d:\t%c%c%c%c\t", arg,
+        fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
                   cell.tag.bytes[0],
-                  cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3] );
+                  cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
+                  cell.count );
 
         print( output, frame->arg[arg] );
         fputws( L"\n", output );

unit-tests/lambda.sh

@@ -0,0 +1,16 @@
+#!/bin/bash
+
+expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)'
+actual=`target/psse 2>/dev/null <<EOF
+(set! list (lambda (l) l))
+(list '(1 2 3 4 5 6 7 8 9 10))
+EOF`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    exit 0
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi