Huge progress. Now actually working.

src/consspaceobject.h

@@ -418,14 +418,6 @@ struct cons_pointer make_cons( struct cons_pointer car,
  */
 struct cons_pointer make_function( struct cons_pointer src,
                                    struct cons_pointer ( *executable )
-
-
-
-
-
-
-
-
                                     ( struct stack_frame *,
                                       struct cons_pointer ) );
 
@@ -434,14 +426,6 @@ struct cons_pointer make_function( struct cons_pointer src,
  */
 struct cons_pointer make_special( struct cons_pointer src,
                                   struct cons_pointer ( *executable )
-
-
-
-
-
-
-
-
                                    ( struct cons_pointer s_expr,
                                      struct cons_pointer env,
                                      struct stack_frame * frame ) );

src/init.c

@@ -19,19 +19,21 @@
 #include "consspaceobject.h"
 #include "intern.h"
 #include "lispops.h"
+#include "peano.h"
+#include "print.h"
 #include "repl.h"
 
 void bind_function( char *name, struct cons_pointer ( *executable )
                      ( struct stack_frame *, struct cons_pointer ) ) {
-    deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ),
-               make_function( NIL, executable ) );
+    deep_bind( c_string_to_lisp_symbol( name ), 
+               make_function( NIL, executable ));
 }
 
 void bind_special( char *name, struct cons_pointer ( *executable )
                     ( struct cons_pointer s_expr, struct cons_pointer env,
                       struct stack_frame * frame ) ) {
-    deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ),
-               make_special( NIL, executable ) );
+    deep_bind( c_string_to_lisp_symbol( name ),
+               make_special( NIL, executable ));
 }
 
 int main( int argc, char *argv[] ) {
@@ -70,17 +72,13 @@ int main( int argc, char *argv[] ) {
     /*
      * privileged variables (keywords) 
      */
-    /*
-    deep_bind( intern( c_string_to_lisp_string( "nil" ), oblist ), NIL );
-    deep_bind( intern( c_string_to_lisp_string( "t" ), oblist ), TRUE );
-     */
-    struct cons_pointer lisp_symbol = c_string_to_lisp_symbol( "oblist");
-    deep_bind( lisp_symbol, &oblist);
+    
+    deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
+    deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
 
     /*
      * primitive function operations 
      */
-    /*
     bind_function( "assoc", &lisp_assoc );
     bind_function( "car", &lisp_car );
     bind_function( "cdr", &lisp_cdr );
@@ -89,19 +87,20 @@ int main( int argc, char *argv[] ) {
     bind_function( "equal", &lisp_equal );
     bind_function( "read", &lisp_read );
     bind_function( "print", &lisp_print );
-*/
+    
+    bind_function( "plus", &lisp_plus);
+
     /*
      * primitive special forms 
      */
-    /*
     bind_special( "apply", &lisp_apply );
     bind_special( "eval", &lisp_eval );
     bind_special( "quote", &lisp_quote );
-    */
-    if ( show_prompt) {
-        fwprintf( stderr, L"Oblist: ");
-        print(stderr, *oblist);
-    }
+    
+    
+    /* 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 );
 

src/integer.c

@@ -20,7 +20,7 @@
  * as a cons-space object. Cell may in principle be any kind of number,
  * but only integers and reals are so far implemented.
  */
-double numeric_value( struct cons_pointer pointer ) {
+long double numeric_value( struct cons_pointer pointer ) {
     double result = NAN;
     struct cons_space_object *cell = &pointer2cell( pointer );
 

src/integer.h

@@ -11,7 +11,7 @@
 #ifndef __integer_h
 #define __integer_h
 
-double numeric_value( struct cons_pointer pointer );
+long double numeric_value( struct cons_pointer pointer );
 
 /**
  * Allocate an integer cell representing this value and return a cons pointer to it.

src/intern.c

@@ -32,7 +32,7 @@
  * 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;
+struct cons_pointer oblist = NIL;
 
 /**
  * Implementation of interned? in C. The final implementation if interned? will
@@ -104,7 +104,7 @@ bind( struct cons_pointer key, struct cons_pointer value,
  */
 struct cons_pointer
 deep_bind( struct cons_pointer key, struct cons_pointer value ) {
-    oblist = &bind( key, value, *oblist );
+    oblist = bind( key, value, oblist );
     return oblist;
 }
 

src/intern.h

@@ -20,7 +20,7 @@
 #ifndef __intern_h
 #define __intern_h
 
-extern struct cons_pointer * oblist;
+extern struct cons_pointer oblist;
 
 /**
  * return the value associated with this key in this store. In the current 

src/lispops.c

@@ -102,9 +102,10 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
     switch ( fn_cell.tag.value ) {
     case SPECIALTV:
         {
-            struct cons_space_object special = pointer2cell( fn_pointer );
+            struct stack_frame *frame =
+                make_special_frame( my_frame, args, env );
             result =
-                ( *special.payload.special.executable ) ( args, env, my_frame );
+                ( *fn_cell.payload.special.executable ) ( args, env, frame );
         }
         break;
 
@@ -121,7 +122,7 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
              * the trick: pass the remaining arguments and environment to the
              * executable code which is the payload of the function object. 
              */
-            result = ( *function.payload.function.executable ) ( frame, env );
+            result = ( *fn_cell.payload.function.executable ) ( frame, env );
             free_stack_frame( frame );
         }
         break;
@@ -165,13 +166,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
 
     switch ( cell.tag.value ) {
     case CONSTV:
-        fwprintf( stderr, L"In eval; about to make stack frame" );
-        struct stack_frame *frame = make_stack_frame( previous, s_expr, env );
-        fwprintf( stderr, L"In eval; stack frame made" );
-
-        result = eval_cons( s_expr, env, frame );
-
-        free_stack_frame( frame );
+        result = eval_cons( s_expr, env, previous);
         break;
 
     case SYMBOLTV:
@@ -181,7 +176,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
                 struct cons_pointer message =
                     c_string_to_lisp_string
                     ( "Attempt to take value of unbound symbol." );
-                result = lisp_throw( message, frame );
+                result = lisp_throw( message, previous );
             } else {
                 result = c_assoc( canonical, env );
             }

src/peano.c

@@ -12,6 +12,7 @@
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
+#include <math.h>
 
 #include "consspaceobject.h"
 #include "conspage.h"
@@ -21,15 +22,52 @@
 #include "lispops.h"
 #include "print.h"
 #include "read.h"
+#include "real.h"
 #include "stack.h"
 
-/*
+/**
+ * Add an indefinite number of numbers together
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
 struct cons_pointer
-lisp_plus( struct cons_pointer s_expr, struct cons_pointer env,
-           struct stack_frame *frame ) {
-    struct cons_space_object cell = pointer2cell( s_expr );
-    struct cons_space_object result = NIL;
+lisp_plus(struct stack_frame *frame, struct cons_pointer env) {
+    struct cons_pointer result = NIL;
+    long int i_accumulator = 0;
+    long double d_accumulator = 0;
+    bool is_int = true;
     
+    for (int i = 0; i < args_in_frame && !nilp(frame->arg[i]); i++) {
+        struct cons_space_object arg = pointer2cell(frame->arg[i]);
         
+        switch (arg.tag.value) {
+        case INTEGERTV:
+            i_accumulator += arg.payload.integer.value;
+            d_accumulator += numeric_value( frame->arg[i]);
+            break;
+        case REALTV:
+            d_accumulator += arg.payload.real.value;
+            is_int = false;
+        default:
+            lisp_throw(
+                    c_string_to_lisp_string("Cannot add: not a number"), 
+                                            frame);
+        }
+        
+        if (! nilp(frame->more)) {
+            lisp_throw(
+                    c_string_to_lisp_string("Cannot yet add more than 8 numbers"), 
+                                            frame);
+        }
+
+        if ( is_int) {
+            result = make_integer( i_accumulator);
+        } else {
+            result = make_real( d_accumulator);
+        }
+    }
+    
+    return result;    
 }
-*/
+

src/peano.h

@@ -0,0 +1,35 @@
+/**
+ * peano.h
+ *
+ * Basic peano arithmetic
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include "consspaceobject.h"
+
+#ifndef PEANO_H
+#define PEANO_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/**
+ * Add an indefinite number of numbers together
+ * @param env the evaluation environment - ignored;
+ * @param frame the stack frame.
+ * @return a pointer to an integer or real.
+ */
+struct cons_pointer
+lisp_plus(struct stack_frame *frame, struct cons_pointer env);
+
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* PEANO_H */
+

src/read.c

@@ -147,8 +147,6 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
     struct cons_pointer cdr = NIL;
     struct cons_pointer result;
 
-    fwprintf( stderr, L"read_string starting '%C' (%d)\n", initial, initial );
-
     switch ( initial ) {
     case '\0':
         result = make_string( initial, NIL );
@@ -168,8 +166,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
     struct cons_pointer cdr = NIL;
     struct cons_pointer result;
 
-    fwprintf( stderr, L"read_symbol starting '%C' (%d)\n", initial, initial );
-
     switch ( initial ) {
     case '\0':
         result = make_symbol( initial, NIL );
@@ -191,15 +187,15 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
         ungetwc( initial, input );
         break;
     default:
-        if ( iswblank( initial ) || !iswprint( initial ) ) {
-            result = make_symbol( '\0', NIL );
+        if ( iswalnum( initial ) ) {
+            result =
+                make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
+        } else {
+            result = NIL;
             /*
              * push back the character read
              */
             ungetwc( initial, input );
-        } else {
-            result =
-                make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
         } 
         break;
     }

src/real.h

@@ -24,7 +24,7 @@ extern "C" {
  * @param value the value to wrap;
  * @return a real number cell wrapping this value.
  */
-    struct cons_pointer make_real( double value );
+struct cons_pointer make_real( double value );
 
 #ifdef __cplusplus
 }

src/repl.c

@@ -31,19 +31,13 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
         struct cons_pointer input = read( in_stream );
         fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page,
                   input.offset );
-        if ( show_prompt ) {
-            fwprintf( out_stream, L"\n-> " );
-        }
+        print( error_stream, input);
 
-        /* OK, I think what's going wrong here is we're passing by 
-         * value and I think we should be passing by reference.
-         * I'm not certain about that, and as it will be a really
-         * major change I'm going to think some more before making
-         * in */
-        print( out_stream, lisp_eval( input, oblist, NULL ) );
+        struct cons_pointer value = lisp_eval( input, oblist, NULL );
         // print( out_stream, input );
         fwprintf( out_stream, L"\n" );
         fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page,
                   input.offset );
+        print( out_stream,  value);
     }
 }

src/stack.c

@@ -23,6 +23,7 @@
 #include "consspaceobject.h"
 #include "conspage.h"
 #include "lispops.h"
+#include "print.h"
 #include "stack.h"
 
 /**
@@ -60,6 +61,8 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
         struct cons_space_object cell = pointer2cell( args );
 
         if ( i < args_in_frame ) {
+            fwprintf(stderr, L"Making frame; arg %d: ", i);
+            print(stderr, cell.payload.cons.car);
             /*
              * TODO: if we were running on real massively parallel hardware,
              * each arg except the first should be handed off to another
@@ -69,6 +72,65 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
             inc_ref( result->arg[i] );
 
             args = cell.payload.cons.cdr;
+            i++;
+        } else {
+            /*
+             * TODO: this isn't right. These args should also each be evaled.
+             */
+            result->more = args;
+            inc_ref( result->more );
+
+            args = NIL;
+        }
+    }
+
+    return result;
+}
+
+/**
+ * A 'special' frame is exactly like a normal stack frame except that the
+ * arguments are unevaluated.
+ * @param previous the previous stack frame;
+ * @param args a list of the arguments to be stored in this stack frame;
+ * @param env the execution environment;
+ * @return a new special frame.
+ */
+struct stack_frame *make_special_frame( struct stack_frame *previous,
+                                      struct cons_pointer args,
+                                      struct cons_pointer env ) {
+    /*
+     * TODO: later, pop a frame off a free-list of stack frames
+     */
+    struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
+
+    result->previous = previous;
+
+    /*
+     * clearing the frame with memset would probably be slightly quicker, but
+     * this is clear.
+     */
+    result->more = NIL;
+    result->function = NIL;
+
+    for ( int i = 0; i < args_in_frame; i++ ) {
+        result->arg[i] = NIL;
+    }
+
+    int i = 0;                  /* still an index into args, so same name will
+                                 * do */
+
+    while ( !nilp( 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 */
+        struct cons_space_object cell = pointer2cell( args );
+
+        if ( i < args_in_frame ) {
+            result->arg[i] = cell.payload.cons.car;
+            inc_ref( result->arg[i] );
+
+            args = cell.payload.cons.cdr;
+            i++;
         } else {
             /*
              * TODO: this isn't right. These args should also each be evaled.

src/stack.h

@@ -30,6 +30,18 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
 void free_stack_frame( struct stack_frame *frame );
 struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
 
+/**
+ * A 'special' frame is exactly like a normal stack frame except that the 
+ * arguments are unevaluated.
+ * @param previous the previous stack frame;
+ * @param args a list of the arguments to be stored in this stack frame;
+ * @param env the execution environment;
+ * @return a new special frame.
+ */
+struct stack_frame *make_special_frame( struct stack_frame *previous,
+                                      struct cons_pointer args,
+                                      struct cons_pointer env );
+
 /*
  * struct stack_frame is defined in consspaceobject.h to break circularity
  * TODO: refactor. 

unit-tests/complex-list.sh

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

unit-tests/quote.sh

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

unit-tests/quoted-list.sh

@@ -1,6 +1,6 @@
 #!/bin/bash
 
-expected='(quote (123 (4 (5 nil)) Fred))'
+expected='(123 (4 (5 nil)) Fred)'
 actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -1`
 
 if [ "${expected}" = "${actual}" ]

unit-tests/simple-list.sh

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