Tactical commit before trying adventurous change in peano

src/conspage.c

@@ -129,7 +129,7 @@ void free_cell( struct cons_pointer pointer ) {
 
     if ( !check_tag( pointer, FREETAG ) ) {
         if ( cell->count == 0 ) {
-            fwprintf( stderr, L"Freeing cell\n" );
+            fwprintf( stderr, L"Freeing cell " );
             dump_object( stderr, pointer );
             strncpy( &cell->tag.bytes[0], FREETAG, 4 );
             cell->payload.free.car = NIL;

src/consspaceobject.c

@@ -92,7 +92,7 @@ void dump_string_cell( FILE * output, wchar_t *prefix,
 void dump_object( FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
     fwprintf( output,
-              L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
+              L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
               cell.tag.bytes[0],
               cell.tag.bytes[1],
               cell.tag.bytes[2],
@@ -112,7 +112,6 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
             fwprintf( output, L"\t\tException cell: " );
             print( output, cell.payload.exception.message );
             fwprintf( output, L"\n" );
-            /* TODO: dump the stack trace */
             for ( struct stack_frame * frame = cell.payload.exception.frame;
                   frame != NULL; frame = frame->previous ) {
                 dump_frame( output, frame );

src/equal.c

@@ -60,6 +60,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
 
         switch ( cell_a->tag.value ) {
             case CONSTV:
+            case LAMBDATV:
+            case NLAMBDATV:
                 result =
                     equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
                     && equal( cell_a->payload.cons.cdr,
@@ -78,10 +80,14 @@ 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.string.
+                              && end_of_string( cell_b->payload.
-                                                cdr ) ) );
+                                                string.cdr ) ) );
                 break;
             case INTEGERTV:
+                result =
+                    cell_a->payload.integer.value ==
+                    cell_b->payload.integer.value;
+                break;
             case REALTV:
                 {
                     double num_a = numeric_value( a );

src/lispops.c

@@ -91,11 +91,34 @@ struct cons_pointer eval_form( struct stack_frame *parent,
     next->arg[0] = form;
     inc_ref( next->arg[0] );
     result = lisp_eval( 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
+     * should free all the frames it's holding on to. */
     free_stack_frame( next );
+  }
 
     return result;
 }
 
+/**
+ * eval all the forms in this `list` in the context of this stack `frame`
+ * and this `env`, and return a list of their values. If the arg passed as
+ * `list` is not in fact a list, return nil.
+ */
+struct cons_pointer eval_forms( struct stack_frame *frame,
+                                struct cons_pointer list,
+                                struct cons_pointer env ) {
+    return consp( list ) ?
+      make_cons( eval_form( frame, c_car( list ), env ), eval_forms( frame, c_cdr( list), env)) :
+      NIL;
+}
+
+
+/**
+ * used to construct the body for `lambda` and `nlambda` expressions.
+ */
 struct cons_pointer compose_body( struct stack_frame *frame ) {
     struct cons_pointer body =
         !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
@@ -131,7 +154,17 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) {
     return make_nlambda( frame->arg[0], compose_body( frame ) );
 }
 
+void log_binding( struct cons_pointer name, struct cons_pointer val ) {
+    print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
+    print( stderr, name );
+    print( stderr, c_string_to_lisp_string( " to " ) );
+    print( stderr, val );
+    fputws( L"\"\n", stderr );
+}
 
+/**
+ * Evaluate a lambda or nlambda expression.
+ */
 struct cons_pointer
 eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
              struct cons_pointer env ) {
@@ -139,20 +172,36 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
     fwprintf( stderr, L"eval_lambda called" );
 
     struct cons_pointer new_env = env;
-    struct cons_pointer args = cell.payload.lambda.args;
+    struct cons_pointer names = cell.payload.lambda.args;
     struct cons_pointer body = cell.payload.lambda.body;
 
-    for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
+    if ( consp( names ) ) {
-        struct cons_pointer arg = c_car( args );
+        /* if `names` is a list, bind successive items from that list
+         * to values of arguments */
+        for ( int i = 0; i < args_in_frame && consp( names ); i++ ) {
+            struct cons_pointer name = c_car( names );
             struct cons_pointer val = frame->arg[i];
-        print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
-        print( stderr, arg );
-        print( stderr, c_string_to_lisp_string( " to " ) );
-        print( stderr, val );
-        fputws( L"\"\n", stderr );
 
-        new_env = make_cons( make_cons( arg, val ), new_env );
+            new_env = bind( name, val, new_env );
-        args = c_cdr( args );
+            log_binding( name, val );
+
+            names = c_cdr( names );
+        }
+    } else if ( symbolp( names ) ) {
+        /* if `names` is a symbol, rather than a list of symbols,
+         * then bind a list of the values of args to that symbol. */
+        struct cons_pointer vals = frame->more;
+
+        for ( int i = args_in_frame - 1; i >= 0; i-- ) {
+            struct cons_pointer val = eval_form( frame, frame->arg[i], env );
+
+            if ( nilp( val ) && nilp( vals ) ) {  /* nothing */
+            } else {
+                vals = make_cons( val, vals );
+            }
+        }
+
+        new_env = bind( names, vals, new_env );
     }
 
     while ( !nilp( body ) ) {
@@ -181,7 +230,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer 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 );
+
+  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. */
     free_stack_frame( fn_frame );
+  }
 
     struct cons_space_object fn_cell = pointer2cell( fn_pointer );
     struct cons_pointer args = c_cdr( frame->arg[0] );
@@ -196,7 +251,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 struct stack_frame *next =
                     make_stack_frame( frame, args, env );
                 result = ( *fn_cell.payload.special.executable ) ( 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
+     * should free all the frames it's holding on to. */
     free_stack_frame( next );
+  }
             }
             break;
         case LAMBDATV:
@@ -206,7 +266,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 fputws( L"Stack frame for lambda\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
+     * should free all the frames it's holding on to. */
     free_stack_frame( next );
+  }
             }
             break;
         case NLAMBDATV:
@@ -214,7 +279,12 @@ 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 );
+  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. */
     free_stack_frame( next );
+  }
             }
             break;
         case SPECIALTV:
@@ -222,7 +292,12 @@ 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 );
+  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. */
     free_stack_frame( next );
+  }
             }
             break;
         default:

src/lispops.h

@@ -30,6 +30,39 @@
  */
 struct cons_pointer c_type( struct cons_pointer pointer );
 
+/**
+ * Implementation of car in C. If arg is not a cons, does not error but returns nil.
+ */
+struct cons_pointer c_car( struct cons_pointer arg );
+
+/**
+ * Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
+ */
+struct cons_pointer c_cdr( struct cons_pointer arg );
+
+
+/**
+ * Useful building block; evaluate this single form in the context of this
+ * parent stack frame and this environment.
+ * @param parent the parent stack frame.
+ * @param form the form to be evaluated.
+ * @param env the evaluation environment.
+ * @return the result of evaluating the form.
+ */
+struct cons_pointer eval_form( struct stack_frame *parent,
+                               struct cons_pointer form,
+                               struct cons_pointer env );
+
+/**
+ * eval all the forms in this `list` in the context of this stack `frame`
+ * and this `env`, and return a list of their values. If the arg passed as
+ * `list` is not in fact a list, return nil.
+ */
+struct cons_pointer eval_forms( struct stack_frame *frame,
+                                struct cons_pointer list,
+                                struct cons_pointer env );
+
+
 /*
  * special forms
  */

src/peano.c

@@ -54,10 +54,28 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
                 lisp_throw( c_string_to_lisp_string
                             ( "Cannot add: not a number" ), frame );
         }
+    }
 
-        if ( !nilp( frame->more ) ) {
+    struct cons_pointer more = frame->more;
+
+    while ( consp( more ) ) {
+        struct cons_pointer pointer = c_car( more );
+        more = c_cdr( more);
+        struct cons_space_object current = pointer2cell( pointer );
+
+        switch ( current.tag.value ) {
+            case INTEGERTV:
+                i_accumulator += current.payload.integer.value;
+                d_accumulator += numeric_value( pointer );
+                break;
+            case REALTV:
+                d_accumulator += current.payload.real.value;
+                is_int = false;
+                break;
+            default:
                 lisp_throw( c_string_to_lisp_string
-                        ( "Cannot yet add more than 8 numbers" ), frame );
+                            ( "Cannot add: not a number" ), frame );
+        }
     }
 
     if ( is_int ) {
@@ -65,7 +83,6 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
     } else {
         result = make_real( d_accumulator );
     }
-    }
 
     return result;
 }
@@ -99,10 +116,28 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
                 lisp_throw( c_string_to_lisp_string
                             ( "Cannot multiply: not a number" ), frame );
         }
+    }
 
-        if ( !nilp( frame->more ) ) {
+    struct cons_pointer more = frame->more;
+
+    while ( consp( more ) ) {
+        struct cons_pointer pointer = c_car( more );
+        more = c_cdr( more);
+        struct cons_space_object current = pointer2cell( pointer );
+
+        switch ( current.tag.value ) {
+            case INTEGERTV:
+                i_accumulator *= current.payload.integer.value;
+                d_accumulator *= numeric_value( pointer );
+                break;
+            case REALTV:
+                d_accumulator *= current.payload.real.value;
+                is_int = false;
+                break;
+            default:
                 lisp_throw( c_string_to_lisp_string
-                        ( "Cannot yet multiply more than 8 numbers" ), frame );
+                            ( "Cannot add: not a number" ), frame );
+        }
     }
 
         if ( is_int ) {
@@ -110,7 +145,6 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
         } else {
             result = make_real( d_accumulator );
         }
-    }
 
     return result;
 }

src/print.c

@@ -119,21 +119,18 @@ void print( FILE * output, struct cons_pointer pointer ) {
             fwprintf( output, L"\n%sException: ",
                       print_use_colours ? "\x1B[31m" : "" );
             print_string_contents( output, cell.payload.exception.message );
-            fputws( L"\x1B[39m", output );
             break;
         case INTEGERTV:
             if ( print_use_colours ) {
                 fputws( L"\x1B[34m", output );
             }
             fwprintf( output, L"%ld%", cell.payload.integer.value );
-            if ( print_use_colours ) {
-                fputws( L"\x1B[39m", output );
-            }
             break;
         case LAMBDATV:
             print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
                                       make_cons( cell.payload.lambda.args,
-                                               cell.payload.lambda.body ) ) );
+                                                 cell.payload.lambda.
+                                                 body ) ) );
             break;
         case NILTV:
             fwprintf( output, L"nil" );
@@ -141,7 +138,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.body ) ) );
+                                                 cell.payload.lambda.
+                                                 body ) ) );
             break;
         case REALTV:
             /* TODO: using the C heap is a bad plan because it will fragment.
@@ -160,9 +158,6 @@ void print( FILE * output, struct cons_pointer pointer ) {
                 fputws( L"\x1B[34m", output );
             }
             fwprintf( output, L"%s", buffer );
-            if ( print_use_colours ) {
-                fputws( L"\x1B[39m", output );
-            }
             free( buffer );
             break;
         case STRINGTV:
@@ -170,16 +165,11 @@ void print( FILE * output, struct cons_pointer pointer ) {
                 fputws( L"\x1B[36m", output );
             }
             print_string( output, pointer );
-            if ( print_use_colours ) {
-                fputws( L"\x1B[39m", output );
-            }
             break;
         case SYMBOLTV:
             if ( print_use_colours )
                 fputws( L"\x1B[1;33m", output );
             print_string_contents( output, pointer );
-            if ( print_use_colours )
-                fputws( L"\x1B[0;39m", output );
             break;
         case TRUETV:
             fwprintf( output, L"t" );
@@ -198,4 +188,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
                       cell.tag.bytes[2], cell.tag.bytes[3], "\x1B[39m" );
             break;
     }
+
+    if ( print_use_colours ) {
+        fputws( L"\x1B[39m", output );
+    }
 }

src/stack.c

@@ -98,14 +98,14 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
 
         args = cell.payload.cons.cdr;
     }
-    if ( !nilp( args ) ) {
+    if ( consp( args ) ) {
-        /*
+        /* if we still have args, eval them and stick the values on `more` */
-         * TODO: this isn't right. These args should also each be evaled.
+        struct cons_pointer more = eval_forms( previous, args, env );
-         */
+        result->more = more;
-        result->more = args;
+        inc_ref( more );
-        inc_ref( result->more );
     }
 
+  dump_frame( stderr, result );
     return result;
 }
 
@@ -133,8 +133,10 @@ struct stack_frame *make_special_frame( struct stack_frame *previous,
 
         args = cell.payload.cons.cdr;
     }
+    if ( consp( args ) ) {
         result->more = args;
         inc_ref( args );
+    }
 
     return result;
 }
@@ -174,6 +176,9 @@ void dump_frame( FILE * output, struct stack_frame *frame ) {
         print( output, frame->arg[arg] );
         fputws( L"\n", output );
     }
+    fputws( L"More: \t", output);
+    print( output, frame->more);
+        fputws( L"\n", output );
 }