COND working

src/consspaceobject.c

@@ -98,7 +98,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
         break;
     case STRINGTV:
         fwprintf( output,
-                  L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n",
+                  L"\t\tString cell: character '%c' (%d) next at page %d offset %d, count %u\n",
+                  cell.payload.string.character,
                   cell.payload.string.character,
                   cell.payload.string.cdr.page,
                   cell.payload.string.cdr.offset, cell.count );
@@ -108,7 +109,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
         break;
     case SYMBOLTV:
         fwprintf( output,
-                  L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n",
+                  L"\t\tSymbol cell: character '%c' (%d) next at page %d offset %d, count %u\n",
+                  cell.payload.string.character,
                   cell.payload.string.character,
                   cell.payload.string.cdr.page,
                   cell.payload.string.cdr.offset, cell.count );

src/equal.c

@@ -37,6 +37,16 @@ bool same_type( struct cons_pointer a, struct cons_pointer b ) {
 
 }
 
+/**
+ * Some string will be null terminated and some will be NIL terminated... ooops!
+ * @param string the string to test
+ * @return true if it's the end of a string.
+ */
+bool end_of_string( struct cons_pointer string) {
+    return nilp( string) ||
+            pointer2cell(string).payload.string.character == '\0';
+}
+
 /**
  * Deep, and thus expensive, equality: true if these two objects have
  * identical structure, else false.
@@ -64,8 +74,10 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
             result =
                 cell_a->payload.string.character ==
                 cell_b->payload.string.character
-                && equal( cell_a->payload.string.cdr,
-                          cell_b->payload.string.cdr );
+                && (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.cdr)));
             break;
         case INTEGERTV:
         case REALTV:

src/init.c

@@ -100,6 +100,7 @@ int main( int argc, char *argv[] ) {
     /*
      * primitive special forms 
      */
+    bind_special( "cond", &lisp_cond );
     bind_special( "eval", &lisp_eval );
     bind_special( "quote", &lisp_quote );
 

src/intern.c

@@ -19,9 +19,11 @@
 
 #include <stdbool.h>
 
-#include "equal.h"
 #include "conspage.h"
 #include "consspaceobject.h"
+#include "equal.h"
+#include "lispops.h"
+#include "print.h"
 
 /**
  * The object list. What is added to this during system setup is 'global', that is, 
@@ -47,15 +49,29 @@ struct cons_pointer
 internedp( struct cons_pointer key, struct cons_pointer store ) {
     struct cons_pointer result = NIL;
 
-    for ( struct cons_pointer next = store;
-          nilp( result ) && consp( next );
-          next = pointer2cell( next ).payload.cons.cdr ) {
-        struct cons_space_object entry =
-            pointer2cell( pointer2cell( next ).payload.cons.car );
+    if (symbolp(key)) {
+        for ( struct cons_pointer next = store;
+              nilp( result ) && consp( next );
+              next = pointer2cell( next ).payload.cons.cdr ) {
+            struct cons_space_object entry =
+                pointer2cell( pointer2cell( next ).payload.cons.car );
 
-        if ( equal( key, entry.payload.cons.car ) ) {
-            result = entry.payload.cons.car;
+            fputws( L"Internedp: checking whether `", stderr);
+            print(stderr, key);
+            fputws( L"` equals `", stderr);
+            print( stderr, entry.payload.cons.car);
+            fputws( L"`\n", stderr);
+            
+            if ( equal( key, entry.payload.cons.car ) ) {
+                result = entry.payload.cons.car;
+            }
         }
+    } else {
+        fputws(L"`", stderr);
+        print( stderr, key );
+        fputws( L"` is a ", stderr);
+        print( stderr, c_type( key));
+        fputws( L", not a SYMB", stderr);
     }
 
     return result;

src/lispops.c

@@ -73,6 +73,30 @@ 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) {
+    fputws(L"eval_form: ", stderr);
+    print( stderr, form);
+    fputws(L"\n", stderr);
+    
+    struct cons_pointer result = NIL;
+    struct stack_frame * next = make_empty_frame(parent, env);
+    next->arg[0] = form;
+    inc_ref( next->arg[0] );
+    result = lisp_eval(next, env);        
+    free_stack_frame( next);
+
+    return result;
+}
+
+
 /**
  * Internal guts of apply.
  * @param frame the stack frame, expected to have only one argument, a list
@@ -131,6 +155,26 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
     return result;
 }
 
+
+/**
+ * Get the Lisp type of the single argument.
+ * @param pointer a pointer to the object whose type is requested.
+ * @return As a Lisp string, the tag of the object which is at that pointer.
+ */
+struct cons_pointer
+c_type( struct cons_pointer pointer) {
+    char *buffer = malloc( TAGLENGTH + 1 );
+    memset( buffer, 0, TAGLENGTH + 1 );
+    struct cons_space_object cell = pointer2cell( pointer );
+    strncpy( buffer, cell.tag.bytes, TAGLENGTH );
+
+    struct cons_pointer result = c_string_to_lisp_string( buffer );
+    free( buffer );
+
+    return result;
+}
+
+
 /**
  * (eval s_expr)
  *
@@ -373,17 +417,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
  */
 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;
+    return c_type( frame->arg[0] );
 }
 
+
 /**
  * Function; evaluate the forms which are listed in my single argument 
  * sequentially and return the value of the last. This function is called 'do'
@@ -401,11 +438,7 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
     
     while ( consp(remaining)) {
         struct cons_space_object cell = pointer2cell( remaining );
-        struct stack_frame * next = make_empty_frame(frame, env);
-        next->arg[0] = cell.payload.cons.car;
-        inc_ref( next->arg[0] );
-        result = lisp_eval(next, env);        
-        free_stack_frame( next);
+        result = eval_form(frame, cell.payload.cons.car, env);
         
         remaining = cell.payload.cons.cdr;
     }
@@ -413,6 +446,48 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
     return result;
 }
 
+/**
+ * Special form: conditional. Each arg is expected to be a list; if the first 
+ * item in such a list evaluates to non-NIL, the remaining items in that list 
+ * are evaluated in turn and the value of the last returned. If no arg (clause) 
+ * has a first element which evaluates to non NIL, then NIL is returned.
+ * @param frame My stack frame.
+ * @param env My environment (ignored).
+ * @return the value of the last form of the first successful clause.
+ */
+struct cons_pointer
+lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+    bool done = false;
+    
+    for (int i = 0; i < args_in_frame && !done; i++) {
+        struct cons_pointer clause_pointer = frame->arg[i];
+        fputws(L"Cond clause: ", stderr);
+        print( stderr, clause_pointer);
+        
+        if (consp(clause_pointer)) {
+            struct cons_space_object cell = pointer2cell( clause_pointer );
+
+            if (!nilp( eval_form(frame, cell.payload.cons.car, env))) {
+                struct stack_frame * next = make_empty_frame(frame, env);
+                next->arg[0] = cell.payload.cons.cdr;
+                inc_ref(next->arg[0]);
+                result = lisp_progn( next, env);
+                done = true;
+            }
+        } else if (nilp(clause_pointer)) {
+            done = true;
+        } else {
+            lisp_throw( 
+                    c_string_to_lisp_string( "Arguments to `cond` must be lists"), 
+                       frame);
+        }
+    }
+    /* TODO: if there are more than 8 caluses we need to continue into the
+     * remainder */
+    
+    return result;
+}
 
 /**
  * TODO: make this do something sensible somehow.

src/lispops.h

@@ -19,6 +19,18 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+/*
+ * utilities
+ */
+
+/**
+ * Get the Lisp type of the single argument.
+ * @param pointer a pointer to the object whose type is requested.
+ * @return As a Lisp string, the tag of the object which is at that pointer.
+ */
+struct cons_pointer
+c_type( struct cons_pointer pointer);
+
 /*
  * special forms 
  */
@@ -71,6 +83,18 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env );
 struct cons_pointer 
 lisp_progn( struct stack_frame *frame, struct cons_pointer env );
 
+/**
+ * Special form: conditional. Each arg is expected to be a list; if the first 
+ * item in such a list evaluates to non-NIL, the remaining items in that list 
+ * are evaluated in turn and the value of the last returned. If no arg (clause) 
+ * has a first element which evaluates to non NIL, then NIL is returned.
+ * @param frame My stack frame.
+ * @param env My environment (ignored).
+ * @return the value of the last form of the first successful clause.
+ */
+struct cons_pointer
+lisp_cond( struct stack_frame *frame, struct cons_pointer env );
+
 /*
  * neither, at this stage, really 
  */

unit-tests/cond.sh

@@ -0,0 +1,24 @@
+#!/bin/bash
+
+expected='5'
+actual=`echo "(cond ((equal 2 2) 5))" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+  echo "OK"
+else
+  echo "Fail: expected '${expected}', got '${actual}'"
+  exit 1
+fi
+
+expected='"should"'
+actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2> /dev/null | head -2 | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    exit 0
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

unit-tests/progn.sh

@@ -6,13 +6,13 @@ actual=`echo "(progn '((add 2 3)))" | target/psse 2> /dev/null | head -2 | tail
 if [ "${expected}" = "${actual}" ]
 then
     echo "OK"
-    exit 0
 else
     echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
 fi
 
 expected='"foo"'
-actual=`echo "(progn '((add 2.5 3) \"foo\"))" | target/psse 2> /dev/null | head -1`
+actual=`echo "(progn '((add 2.5 3) \"foo\"))" | target/psse 2> /dev/null | head -2 | tail -1`
 
 if [ "${expected}" = "${actual}" ]
 then