Interpreter working!

src/conspage.c

@@ -54,7 +54,7 @@ void make_cons_page(  ) {
         for ( int i = 0; i < CONSPAGESIZE; i++ ) {
             struct cons_space_object *cell =
                 &conspages[initialised_cons_pages]->cell[i];
-            if ( initialised_cons_pages == 0 && i < 3 ) {
+            if ( initialised_cons_pages == 0 && i < 2 ) {
                 switch ( i ) {
                     case 0:
                         /*
@@ -78,16 +78,6 @@ void make_cons_page(  ) {
                         0, 1};
                         fwprintf( stderr, L"Allocated special cell T\n" );
                         break;
-                    case 2:
-                        /*
-                         * initialise cell as λ
-                         */
-                        strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH );
-                        cell->count = MAXREFERENCE;
-                        cell->payload.string.character = ( wint_t ) L'λ';
-                        cell->payload.free.cdr = NIL;
-                        fwprintf( stderr, L"Allocated special cell LAMBDA\n" );
-                        break;
                 }
             } else {
                 /*

src/consspaceobject.c

@@ -128,6 +128,12 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
                       L"\t\tInteger cell: value %ld, count %u\n",
                       cell.payload.integer.value, cell.count );
             break;
+        case LAMBDATV:
+            fwprintf( output, L"Lambda cell; args: " );
+            print( output, cell.payload.lambda.args );
+            fwprintf( output, L";\n\t\t\tbody: " );
+            print( output, cell.payload.lambda.args );
+            break;
         case READTV:
             fwprintf( output, L"\t\tInput stream\n" );
         case REALTV:
@@ -152,8 +158,7 @@ struct cons_pointer make_cons( struct cons_pointer car,
 
     pointer = allocate_cell( CONSTAG );
 
-    struct cons_space_object *cell =
+    struct cons_space_object *cell = &pointer2cell( pointer );
-        &conspages[pointer.page]->cell[pointer.offset];
 
     inc_ref( car );
     inc_ref( cdr );
@@ -195,6 +200,21 @@ make_function( struct cons_pointer src, struct cons_pointer ( *executable )
     return pointer;
 }
 
+/**
+ * Construct a lambda (interpretable source) cell
+ */
+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( args );
+    inc_ref( body );
+    cell->payload.lambda.args = args;
+    cell->payload.lambda.body = body;
+
+    return pointer;
+}
+
 /**
  * Construct a string from this character (which later will be UTF) and
  * this tail. A string is implemented as a flat list of cells each of which

src/consspaceobject.h

@@ -61,8 +61,7 @@
 #define INTEGERTV   1381256777
 
 /**
- * Lambda is very special, and, like NIL and TRUE, we need to identify it
+ * A lambda cell.
- * quickly and cheaply. So we will give it, too, a special cons cell at {0,2}
  */
 #define LAMBDATAG  "LMDA"
 #define LAMBDATV   1094995276
@@ -134,11 +133,6 @@
  */
 #define TRUE (struct cons_pointer){ 0, 1}
 
-/**
- * a cons pointer which points to the special λ cell
- */
-#define LAMBDA (struct cons_pointer){ 0,2}
-
 /**
  * the maximum possible value of a reference count
  */
@@ -173,7 +167,7 @@
 #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG))
 
 /**
- * true if conspointer points to the special Lambda cell, else false
+ * true if conspointer points to a special Lambda cell, else false
  */
 #define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG))
 
@@ -309,11 +303,15 @@ struct integer_payload {
     long int value;
 };
 
+struct lambda_payload {
+    struct cons_pointer args;
+    struct cons_pointer body;
+};
+
 /**
  * payload for a real number cell. Internals of this liable to change to give 128 bits
  * precision, but I'm not sure of the detail.
- */
+ */ struct real_payload {
-struct real_payload {
     long double value;
 };
 
@@ -403,6 +401,10 @@ struct cons_space_object {
          * if tag == INTEGERTAG
          */
         struct integer_payload integer;
+        /*
+         * if tag == LAMBDATAG 
+         */
+        struct lambda_payload lambda;
         /*
          * if tag == NILTAG; we'll treat the special cell NIL as just a cons
          */
@@ -472,6 +474,12 @@ struct cons_pointer make_function( struct cons_pointer src,
                                     ( struct stack_frame *,
                                       struct cons_pointer ) );
 
+/**
+ * Construct a lambda (interpretable source) cell
+ */
+struct cons_pointer make_lambda( struct cons_pointer args,
+                                 struct cons_pointer body );
+
 /**
  * Construct a cell which points to an executable Lisp special form.
  */

src/equal.c

@@ -78,8 +78,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:
             case REALTV:

src/init.c

@@ -74,8 +74,6 @@ int main( int argc, char *argv[] ) {
      */
     deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
     deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
-    /* lambda is even more privileged than a special form */
-    deep_bind( c_string_to_lisp_symbol( "lambda" ), LAMBDA );
 
     /*
      * primitive function operations
@@ -106,6 +104,7 @@ int main( int argc, char *argv[] ) {
      * primitive special forms
      */
     bind_special( "cond", &lisp_cond );
+    bind_special( "lambda", &lisp_lambda );
     bind_special( "quote", &lisp_quote );
 
 

src/lispops.c

@@ -100,58 +100,58 @@ struct cons_pointer eval_form( struct stack_frame *parent,
  * The Lisp interpreter.
  *
  * @param frame the stack frame in which the expression is to be interpreted;
- * @param lexpr the lambda expression to be interpreted;
  * @param env the environment in which it is to be intepreted.
  */
 struct cons_pointer
 lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
-    struct cons_pointer result = NIL;
-    struct cons_pointer lexpr = frame->arg[0];
-    struct cons_pointer should_be_lambda =
-        eval_form( frame, c_car( lexpr ), env );
-
     dump_frame( stderr, 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-- ) {
+        if ( !nilp( frame->arg[i] ) ) {
+            body = make_cons( frame->arg[i], body );
+        }
+
+    }
+
+    return make_lambda( frame->arg[0], body );
+}
+
+
+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" );
 
-    if ( lambdap( should_be_lambda ) ) {
     struct cons_pointer new_env = env;
-        struct cons_pointer args = c_car( c_cdr( lexpr ) );
+    struct cons_pointer args = cell.payload.lambda.args;
-        struct cons_pointer body = c_cdr( c_cdr( lexpr ) );
+    struct cons_pointer body = cell.payload.lambda.body;
+    struct cons_pointer vals = frame->arg[0];
 
-        for ( int i = 1; i < args_in_frame && consp( args ); i++ ) {
+    while ( consp( args ) && consp( vals ) ) {
-            args = c_cdr( args );
         struct cons_pointer arg = c_car( args );
+        struct cons_pointer val = c_car( vals );
         print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
         print( stderr, arg );
         print( stderr, c_string_to_lisp_string( " to " ) );
-            print( stderr, frame->arg[i] );
+        print( stderr, val );
+        fputws( L"\"\n", stderr );
+
+        new_env = make_cons( make_cons( arg, val ), new_env );
+        args = c_cdr( args );
+        vals = c_cdr( vals );
 
-            new_env = make_cons( make_cons( arg, frame->arg[i] ), new_env );
     }
 
     while ( !nilp( body ) ) {
         struct cons_pointer sexpr = c_car( body );
         body = c_cdr( body );
-
+        fputws( L"In lambda: ", stderr );
         result = eval_form( frame, sexpr, new_env );
     }
-    } else {
+
-        if ( exceptionp( should_be_lambda ) ) {
-            result = should_be_lambda;
-        } else {
-            char *buffer = malloc( 1024 );
-            struct cons_space_object not_lambda =
-                pointer2cell( should_be_lambda );
-            memset( buffer, '\0', 1024 );
-            sprintf( buffer,
-                     "Expected lambda, but found cell with tag %d (%c%c%c%c)",
-                     not_lambda.tag.value, not_lambda.tag.bytes[0],
-                     not_lambda.tag.bytes[1], not_lambda.tag.bytes[2],
-                     not_lambda.tag.bytes[3] );
-            struct cons_pointer message = c_string_to_lisp_string( buffer );
-            free( buffer );
-            result = lisp_throw( message, frame );
-        }
-    }
     return result;
 }
 
@@ -178,13 +178,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
     struct cons_pointer args = c_cdr( frame->arg[0] );
 
     switch ( fn_cell.tag.value ) {
-        case SPECIALTV:
+        case EXCEPTIONTV:
-            {
+            /* just pass exceptions straight back */
-                struct stack_frame *next =
+            result = fn_pointer;
-                    make_special_frame( frame, args, env );
-                result = ( *fn_cell.payload.special.executable ) ( next, env );
-                free_stack_frame( next );
-            }
             break;
         case FUNCTIONTV:
             {
@@ -194,16 +190,21 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
                 free_stack_frame( next );
             }
             break;
-        case CONSTV:
+        case LAMBDATV:
             {
-                fwprintf( stdout,
+                struct stack_frame *next =
-                          L"Treating cons as lambda expression (apply)\n" );
+                    make_stack_frame( frame, args, env );
-                result = lisp_lambda( frame, env );
+                result = eval_lambda( fn_cell, next, env );
+                free_stack_frame( next );
             }
             break;
-        case EXCEPTIONTV:
+        case SPECIALTV:
-            /* just pass exceptions straight back */
+            {
-            result = fn_pointer;
+                struct stack_frame *next =
+                    make_special_frame( frame, args, env );
+                result = ( *fn_cell.payload.special.executable ) ( next, env );
+                free_stack_frame( next );
+            }
             break;
         default:
             {
@@ -266,12 +267,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
 
     switch ( cell.tag.value ) {
         case CONSTV:
-            print( stderr, frame->arg[0] );
+            {
-            if ( lambdap( c_car( frame->arg[0] ) ) ) {
-                fwprintf( stdout,
-                          L"Treating cons as lambda expression (eval)\n" );
-                result = lisp_lambda( frame, env );
-            } else {
                 result = c_apply( frame, env );
             }
             break;

src/print.c

@@ -131,7 +131,11 @@ void print( FILE * output, struct cons_pointer pointer ) {
             }
             break;
         case LAMBDATV:
-            fwprintf( output, L"lambda" /* "λ" */  );
+            fputws( L"(lambda ", output );
+            print( output, cell.payload.lambda.args );
+            fputws( L" ", output );
+            print( output, cell.payload.lambda.body );
+            fputws( L")", output );
             break;
         case NILTV:
             fwprintf( output, L"nil" );