Good news: only one test failing. Bad news: it's nlambda.

src/debug.c

@@ -42,6 +42,21 @@ void debug_print( wchar_t *message, int level ) {
 #endif
 }
 
+/**
+ * print a line feed to stderr, if `verbosity` matches `level`.
+ * `verbosity is a set of flags, see debug_print.h; so you can
+ * turn debugging on for only one part of the system.
+ */
+void debug_println( int level ) {
+#ifdef DEBUG
+    if ( level & verbosity ) {
+        fwide( stderr, 1 );
+        fputws( L"\n", stderr );
+    }
+#endif
+}
+
+
 /**
  * `wprintf` adapted for the debug logging system. Print to stderr only
  * `verbosity` matches `level`. All other arguments as for `wprintf`.

src/debug.h

@@ -25,6 +25,7 @@
 extern int verbosity;
 
 void debug_print( wchar_t *message, int level );
+void debug_println( int level );
 void debug_printf( int level, wchar_t * format, ...);
 void debug_print_object( struct cons_pointer pointer, int level );
 void debug_dump_object( struct cons_pointer pointer, int level );

src/memory/dump.c

@@ -62,11 +62,13 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
     switch ( cell.tag.value ) {
         case CONSTV:
             fwprintf( output,
-                      L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
+                      L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :",
                       cell.payload.cons.car.page,
                       cell.payload.cons.car.offset,
                       cell.payload.cons.cdr.page,
                       cell.payload.cons.cdr.offset, cell.count );
+            print( output, pointer);
+            fputws( L"\n", output);
             break;
         case EXCEPTIONTV:
             fwprintf( output, L"\t\tException cell: " );

src/memory/stack.c

@@ -26,6 +26,18 @@
 #include "stack.h"
 #include "vectorspace.h"
 
+void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) {
+  debug_printf(DEBUG_STACK, L"Setting register %d to ", reg);
+  debug_print_object(value, DEBUG_STACK);
+  debug_println(DEBUG_STACK);
+  frame->arg[reg++] = value;
+  inc_ref(value);
+  if (reg > frame->args) {
+    frame->args = reg;
+  }
+}
+
+
 /**
  * get the actual stackframe object from this `pointer`, or NULL if
  * `pointer` is not a stackframe pointer.
@@ -53,32 +65,24 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
  * @return the new frame, or NULL if memory is exhausted.
  */
 struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
-    debug_print( L"Entering make_empty_frame\n", DEBUG_STACK );
+    debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
     struct cons_pointer result =
         make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
 
-    debug_dump_object( result, DEBUG_STACK );
+    debug_dump_object( result, DEBUG_ALLOC );
 
-    debug_printf( DEBUG_STACK,
+//    debug_printf( DEBUG_STACK,
-              L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
+//              L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
-              pointer_to_vso( result )->header.size,
+//              pointer_to_vso( result )->header.size,
-              &pointer_to_vso( result )->header.tag.bytes );
+//              &pointer_to_vso( result )->header.tag.bytes );
 
     if ( !nilp( result ) ) {
-        debug_print( L"make_empty_frame: about to call get_stack_frame\n",
-                     DEBUG_STACK );
         struct stack_frame *frame = get_stack_frame( result );
         /*
          * TODO: later, pop a frame off a free-list of stack frames
          */
 
-        debug_printf( DEBUG_STACK,
-                  L"make_empty_frame: about to set previous to %4.4s\n",
-                  &pointer2cell( previous ).tag.bytes );
         frame->previous = previous;
-        debug_print( L"make_empty_frame: about to call inc_ref\n",
-                     DEBUG_STACK );
-        inc_ref( previous );
 
         /*
          * clearing the frame with memset would probably be slightly quicker, but
@@ -88,13 +92,12 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
         frame->function = NIL;
         frame->args = 0;
 
-        debug_print( L"make_empty_frame: about to initialise arg registers\n",
-                     DEBUG_STACK );
         for ( int i = 0; i < args_in_frame; i++ ) {
-            set_reg( frame, i, NIL );
+            frame->arg[i] = NIL;
         }
     }
-    debug_print( L"Leaving make_empty_frame\n", DEBUG_STACK );
+    debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
+    debug_dump_object( result, DEBUG_ALLOC);
 
     return result;
 }
@@ -121,8 +124,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
     } else {
         struct stack_frame *frame = get_stack_frame( result );
 
-        for ( frame->args = 0; frame->args < args_in_frame && consp( args );
+        while ( frame->args < args_in_frame && consp( args )) {
-              frame->args++ ) {
             /* iterate down the arg list filling in the arg slots in the
              * frame. When there are no more slots, if there are still args,
              * stash them on more */
@@ -134,23 +136,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
              * processor to be evaled in parallel; but see notes here:
              * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
              */
-            struct cons_pointer arg_frame_pointer = make_empty_frame( result );
+                struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env);
-            inc_ref( arg_frame_pointer );
-
-            if ( nilp( arg_frame_pointer ) ) {
-                result =
-                    make_exception( c_string_to_lisp_string
-                                    ( L"Memory exhausted." ), previous );
-                break;
-            } else {
-                struct stack_frame *arg_frame =
-                    get_stack_frame( arg_frame_pointer );
-                    debug_print( L"Setting argument 0 of arg_frame to ", DEBUG_STACK);
-                    debug_print_object(cell.payload.cons.car, DEBUG_STACK);
-                set_reg( arg_frame, 0, cell.payload.cons.car );
-
-                struct cons_pointer val =
-                    lisp_eval( arg_frame, arg_frame_pointer, env );
                 if ( exceptionp( val ) ) {
                     result = val;
                     break;
@@ -160,11 +146,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
                     set_reg( frame, frame->args, val );
                 }
 
-                dec_ref( arg_frame_pointer );
-
                 args = cell.payload.cons.cdr;
             }
-        }
+
         if ( !exceptionp( result ) ) {
             if ( consp( args ) ) {
                 /* if we still have args, eval them and stick the values on `more` */
@@ -175,10 +159,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
                 inc_ref( more );
             }
 
+        }
+    }
+    debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
     debug_dump_object( result, DEBUG_STACK );
-        }
-    }
-    debug_print( L"Leaving make_stack_frame\n", DEBUG_STACK );
 
     return result;
 }
@@ -206,8 +190,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
     } else {
         struct stack_frame *frame = get_stack_frame( result );
 
-        for ( frame->args = 0; frame->args < args_in_frame && !nilp( args );
+        while ( frame->args < args_in_frame && !nilp( args )) {
-              frame->args++ ) {
             /* iterate down the arg list filling in the arg slots in the
              * frame. When there are no more slots, if there are still args,
              * stash them on more */
@@ -222,11 +205,10 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
                 frame->more = args;
                 inc_ref( args );
             }
-
+        }
+    }
+    debug_print( L"make_special_frame: returning\n", DEBUG_STACK );
     debug_dump_object( result, DEBUG_STACK );
-        }
-    }
-    debug_print( L"Leaving make_special_frame\n", DEBUG_STACK );
 
     return result;
 }

src/memory/stack.h

@@ -39,7 +39,9 @@
  * set a register in a stack frame. Alwaye use this macro to do so,
  • because that way we can be sure the inc_ref happens!
  */
-#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);}
+//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);}
+
+void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value);
 
 struct stack_frame *get_stack_frame( struct cons_pointer pointer );
 

src/ops/intern.c

@@ -111,6 +111,12 @@ struct cons_pointer c_assoc( struct cons_pointer key,
 struct cons_pointer
 bind( struct cons_pointer key, struct cons_pointer value,
       struct cons_pointer store ) {
+  debug_print(L"Binding ", DEBUG_ALLOC);
+  debug_print_object(key, DEBUG_ALLOC);
+  debug_print(L" to ", DEBUG_ALLOC);
+  debug_print_object(value, DEBUG_ALLOC);
+  debug_println(DEBUG_ALLOC);
+
     return make_cons( make_cons( key, value ), store );
 }
 

src/ops/lispops.c

@@ -94,6 +94,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
 
     struct stack_frame *next = get_stack_frame( next_pointer );
     set_reg( next, 0, form );
+    next->args = 1;
 
     result = lisp_eval( next, next_pointer, env );
 
@@ -253,25 +254,15 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
 struct cons_pointer
 c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
          struct cons_pointer env ) {
+  debug_print(L"Entering c_apply\n", DEBUG_EVAL);
   struct cons_pointer result = NIL;
 
-    /* construct a child frame and within it evaluate the first argument - the
-     * argument in the function position. */
-    struct cons_pointer fn_frame_pointer = make_empty_frame( frame_pointer );
-    inc_ref( fn_frame_pointer );
-    struct stack_frame *fn_frame = get_stack_frame( fn_frame_pointer );
-
-    set_reg( fn_frame, 0, c_car( frame->arg[0] ) );
     struct cons_pointer fn_pointer =
-        lisp_eval( fn_frame, fn_frame_pointer, env );
+        eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env );
-
-    if ( !exceptionp( result ) ) {
-        /* if we're returning an exception, we should NOT free the
-         * stack frame. Corollary is, when we free an exception, we
-         * should free all the frames it's holding on to. */
-        dec_ref( fn_frame_pointer );
-    }
 
+    if ( exceptionp( fn_pointer ) ) {
+        result = fn_pointer;
+    } else {
     struct cons_space_object fn_cell = pointer2cell( fn_pointer );
     struct cons_pointer args = c_cdr( frame->arg[0] );
 
@@ -327,11 +318,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                     struct stack_frame *next =
                         get_stack_frame( frame_pointer );
                     result = eval_lambda( fn_cell, next, next_pointer, env );
-                    if ( !exceptionp( result ) ) {
                         dec_ref( next_pointer );
                 }
             }
-            }
             break;
         case SPECIALTV:
             {
@@ -341,17 +330,16 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                 if ( exceptionp( next_pointer ) ) {
                     result = next_pointer;
                 } else {
-                    struct stack_frame *next =
-                        get_stack_frame( frame_pointer );
                     result =
-                        ( *fn_cell.payload.special.executable ) ( next,
+                        ( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ),
                                                                   next_pointer,
                                                                   env );
-                    if ( !exceptionp( result ) ) {
+                   debug_print(L"Special form returning: ", DEBUG_EVAL);
+                  debug_print_object(result, DEBUG_EVAL);
+                  debug_println(DEBUG_EVAL);
                     dec_ref( next_pointer );
                 }
             }
-            }
             break;
         default:
             {
@@ -367,7 +355,11 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                 result = throw_exception( message, frame_pointer );
             }
     }
-    dec_ref( fn_frame_pointer );
+    }
+
+    debug_print(L"c_apply: returning: ", DEBUG_EVAL);
+    debug_print_object(result, DEBUG_EVAL);
+    debug_println(DEBUG_EVAL);
 
     return result;
 }

src/repl.c

@@ -54,14 +54,9 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
 struct cons_pointer repl_eval( struct cons_pointer input ) {
     debug_print( L"Entered repl_eval\n",  DEBUG_REPL );
     struct cons_pointer result = NIL;
-    struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( input, NIL ), oblist);
 
-    if ( !nilp( frame_pointer ) ) {
+    result = eval_form( NULL, NIL, input, oblist );
-    inc_ref(frame_pointer);
-            result = lisp_eval( get_stack_frame( frame_pointer ), frame_pointer, oblist );
 
-        dec_ref( frame_pointer );
-    }
     debug_print( L"repl_eval: returning\n",  DEBUG_REPL );
     debug_dump_object( result, DEBUG_REPL );
 
@@ -75,13 +70,8 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
                                 struct cons_pointer value ) {
     debug_print( L"Entered repl_print\n",  DEBUG_REPL );
     debug_dump_object( value, DEBUG_REPL );
-    struct cons_pointer result = NIL;
+    struct cons_pointer result =
-    struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( value, NIL ), oblist);
+      print( pointer2cell( stream_pointer ).payload.stream.stream, value );
-    if ( !nilp( frame_pointer ) ) {
-    inc_ref(frame_pointer);
-        result = lisp_print( get_stack_frame( frame_pointer ), frame_pointer, oblist );
-        dec_ref( frame_pointer );
-    }
     debug_print( L"repl_print: returning\n",  DEBUG_REPL );
     debug_dump_object( result, DEBUG_REPL );