All tests passing except 'apply', which is genuinely broken; I'm not yet sure

what's wrong.

src/conspage.c

@@ -90,9 +90,9 @@ void make_cons_page(  ) {
 
         initialised_cons_pages++;
     } else {
-        fprintf( stderr,
+        fwprintf( stderr,
-                 "FATAL: Failed to allocate memory for cons page %d\n",
+                  L"FATAL: Failed to allocate memory for cons page %d\n",
-                 initialised_cons_pages );
+                  initialised_cons_pages );
         exit( 1 );
     }
 
@@ -103,7 +103,7 @@ void make_cons_page(  ) {
  */
 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 ) {
@@ -123,19 +123,21 @@ 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 );
+                      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 );
+                  pointer.page, pointer.offset );
     }
 }
 
@@ -166,12 +168,12 @@ struct cons_pointer allocate_cell( char *tag ) {
             cell->payload.cons.cdr = NIL;
 
 #ifdef DEBUG
-            fprintf( stderr,
+            fwprintf( stderr,
-                     "Allocated cell of type '%s' at %d, %d \n", tag,
+                      L"Allocated cell of type '%s' at %d, %d \n", tag,
-                     result.page, result.offset );
+                      result.page, result.offset );
 #endif
         } else {
-            fprintf( stderr, "WARNING: Allocating non-free cell!" );
+            fwprintf( stderr, L"WARNING: Allocating non-free cell!" );
         }
     }
 

src/consspaceobject.c

@@ -80,9 +80,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
                   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.page,
-                 cell.payload.cons.cdr.offset,
+                  cell.payload.cons.cdr.offset, cell.count );
-                 cell.count);
         break;
     case INTEGERTV:
         fwprintf( output,
@@ -102,8 +101,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
                   L"\t\tString 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.payload.string.cdr.offset, cell.count );
-                  cell.count );
         fwprintf( output, L"\t\t value: " );
         print( output, pointer );
         fwprintf( output, L"\n" );
@@ -113,8 +111,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
                   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.payload.string.cdr.offset, cell.count );
-                  cell.count );
         fwprintf( output, L"\t\t value:" );
         print( output, pointer );
         fwprintf( output, L"\n" );
@@ -208,8 +205,7 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
  */
 struct cons_pointer
 make_special( struct cons_pointer src, struct cons_pointer ( *executable )
-               ( struct stack_frame * frame,
+               ( struct stack_frame * frame, struct cons_pointer env ) ) {
-                 struct cons_pointer env  ) ) {
     struct cons_pointer pointer = allocate_cell( SPECIALTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 

src/init.c

@@ -30,8 +30,7 @@ void bind_function( char *name, struct cons_pointer ( *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 ),
                make_special( NIL, executable ) );
 }
@@ -87,6 +86,7 @@ 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 );
 
     bind_function( "add", &lisp_add );
     bind_function( "multiply", &lisp_multiply );

src/lispops.c

@@ -80,6 +80,7 @@ eval_cons( struct stack_frame *frame, struct cons_pointer env ) {
 
     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 );
 
@@ -187,6 +188,7 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
 
     struct stack_frame *fn_frame = make_empty_frame( frame, env );
     fn_frame->arg[0] = frame->arg[0];
+    inc_ref( fn_frame->arg[0] );
     struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
     free_stack_frame( fn_frame );
 
@@ -256,8 +258,7 @@ 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
+            c_string_to_lisp_string( "Attempt to take CAR of non sequence" );
-            ( "Attempt to take CAR of non sequence" );
         result = lisp_throw( message, frame );
     }
 
@@ -281,8 +282,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
         result = cell.payload.string.cdr;
     } else {
         struct cons_pointer message =
-            c_string_to_lisp_string
+            c_string_to_lisp_string( "Attempt to take CDR of non sequence" );
-            ( "Attempt to take CDR of non sequence" );
         result = lisp_throw( message, frame );
     }
 
@@ -333,6 +333,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
     return read( input );
 }
 
+
 /**
  * (print expr)
  * (print expr write-stream)
@@ -352,6 +353,27 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
     return NIL;
 }
 
+
+/**
+ * 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.
  */

src/lispops.h

@@ -48,6 +48,14 @@ 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 

src/stack.c

@@ -84,8 +84,8 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
         struct stack_frame *arg_frame = make_empty_frame( previous, env );
         arg_frame->arg[0] = cell.payload.cons.car;
         result->arg[i] = lisp_eval( arg_frame, env );
-        free_stack_frame( arg_frame );
         inc_ref( result->arg[i] );
+        free_stack_frame( arg_frame );
 
         args = cell.payload.cons.cdr;
     }

unit-tests/apply.sh

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