Added proper argument number checking to lambdas, a bunch more builtins,

a few misc optimizations.

ruamoko/scheme/Boolean.r

@@ -8,9 +8,9 @@ Boolean falseConstant;
 + (void) initialize
 {
     trueConstant = [Boolean new];
-    [trueConstant makeRootCell];
+    [trueConstant retain];
     falseConstant = [Boolean new];
-    [falseConstant makeRootCell];
+    [falseConstant retain];
     
 }
 

ruamoko/scheme/CompiledCode.h

@@ -20,6 +20,7 @@ typedef struct lineinfo_s lineinfo_t;
     Array constants;
     instruction_t [] code;
     lineinfo_t [] lineinfo;
+    integer minargs, size;
 }
 - (void) addInstruction: (Instruction) inst;
 - (integer) addConstant: (SchemeObject) c;
@@ -27,6 +28,9 @@ typedef struct lineinfo_s lineinfo_t;
 - (instruction_t []) code;
 - (lineinfo_t []) lineinfo;
 - (Frame) literals;
+- (integer) minimumArguments;
+- (void) minimumArguments: (integer) min;
+    
 @end
 
 #endif //__CompiledCode_h

ruamoko/scheme/CompiledCode.r

@@ -56,6 +56,7 @@
             lineinfo[index].sourcefile = symbol([inst source]);
             [lineinfo[index].sourcefile retain];
     }
+    size = [instructions count];
     [instructions release];
     [constants release];
     instructions = constants = NIL;
@@ -94,7 +95,25 @@
     if (code) {
             obj_free (code);
     }
+
+    if (lineinfo) {
+            local integer i;
+            for (i = 0; i < size; i++) {
+                    [lineinfo[i].sourcefile release];
+            }
+            obj_free (lineinfo);
+    }
     [super dealloc];
 }
 
+- (integer) minimumArguments
+{
+    return minargs;
+}
+
+- (void) minimumArguments: (integer) min
+{
+    minargs = min;
+}
+
 @end

ruamoko/scheme/Compiler.r

@@ -16,15 +16,15 @@ Symbol letrecSym;
 + (void) initialize
 {
     lambdaSym = [Symbol forString: "lambda"];
-    [lambdaSym makeRootCell];
+    [lambdaSym retain];
     quoteSym = [Symbol forString: "quote"];
-    [quoteSym makeRootCell];
+    [quoteSym retain];
     defineSym = [Symbol forString: "define"];
-    [defineSym makeRootCell];
+    [defineSym retain];
     ifSym = [Symbol forString: "if"];
-    [ifSym makeRootCell];
+    [ifSym retain];
     letrecSym = symbol("letrec");
-    [letrecSym makeRootCell];
+    [letrecSym retain];
 }
 
 + (id) newWithLambda: (SchemeObject) xp scope: (Scope) sc
@@ -52,6 +52,7 @@ Symbol letrecSym;
     for (cur = arguments; [cur isKindOfClass: [Cons class]]; cur = [cur cdr]) {
             count++;
     }
+    [code minimumArguments: count];
     if (cur != [Nil nil]) {
             count++;
     }
@@ -130,7 +131,7 @@ Symbol letrecSym;
             if (err) return;
     } else if ([[expression car] isKindOfClass: [Symbol class]]) {
             index = [code addConstant: [expression car]];
-            [self emitExpression: [[expression cdr] car]];
+            [self emitExpression: [[expression cdr] car] flags: 0];
             if (err) return;
     } else {
             err = [Error type: "syntax"

ruamoko/scheme/Cons.h

@@ -16,5 +16,6 @@
 
 @extern Cons cons (SchemeObject car, SchemeObject cdr);
 @extern BOOL isList (SchemeObject ls);
+@extern integer length (SchemeObject foo);
 
 #endif //__Cons_h

ruamoko/scheme/Cons.r

@@ -8,6 +8,17 @@ Cons cons (SchemeObject car, SchemeObject cdr)
     return [Cons newWithCar: car cdr: cdr];
 }
 
+integer length (SchemeObject foo)
+{
+    local integer len;
+
+    for (len = 0; [foo isKindOfClass: [Cons class]]; foo = [foo cdr]) {
+            len++;
+    }
+
+    return len;
+}
+
 BOOL isList (SchemeObject ls)
 {
     return ls == [Nil nil] ||

ruamoko/scheme/Lambda.r

@@ -2,7 +2,10 @@
 #include "Nil.h"
 #include "Symbol.h"
 #include "string.h"
+#include "Cons.h"
 #include "defs.h"
+#include "Error.h"
+#include "Machine.h"
 
 @implementation Lambda
 + (id) newWithCode: (CompiledCode) c environment: (Frame) e
@@ -21,6 +24,13 @@
 - (void) invokeOnMachine: (Machine) m
 {
     [super invokeOnMachine: m];
+    if (length([m stack]) < [code minimumArguments]) {
+            [m value: [Error type: "call"
+                             message: sprintf("expected at least %i arguments, received %i",
+                                              [code minimumArguments], length([m stack]))
+                             by: m]];
+            return;
+    }
     [m loadCode: code];
     [m environment: env];
     [m procedure: self];

ruamoko/scheme/Nil.r

@@ -8,7 +8,7 @@ Nil one_nil_to_rule_them_all;
 + (void) initialize
 {
     one_nil_to_rule_them_all = [Nil new];
-    [one_nil_to_rule_them_all makeRootCell];
+    [one_nil_to_rule_them_all retain];
 }
 
 + (id) nil

ruamoko/scheme/SchemeObject.r

@@ -92,7 +92,6 @@ integer checkpoint;
                     queue_pos = queue_pos.next;
                         //if (++amount == GC_AMOUNT) return;
                     }
-            dprintf("Alloced: %i  Freed: %i\n", alloced, freed);
             maybe_garbage = not_garbage;
             not_garbage_end.next = wait_list;
             if (wait_list) {

ruamoko/scheme/Symbol.r

@@ -35,10 +35,10 @@ Symbol symbol (string str)
     rparen = [Symbol forString: ")"];
     quote = [Symbol forString: "'"];
     dot = symbol(".");
-    [lparen makeRootCell];
-    [rparen makeRootCell];
-    [quote makeRootCell];
-    [dot makeRootCell];
+    [lparen retain];
+    [rparen retain];
+    [quote retain];
+    [dot retain];
 }
 
 + (Symbol) forString: (string) s

ruamoko/scheme/builtins.r

@@ -58,6 +58,102 @@ SchemeObject bi_add (SchemeObject args, Machine m)
     return [Number newFromInt: sum];
 }
 
+SchemeObject bi_sub (SchemeObject args, Machine m)
+{
+    local integer diff = 0;
+    local SchemeObject cur;
+
+    if (args == [Nil nil]) {
+            return [Error type: "-"
+                          message: sprintf("expected at least 1 argument")
+                          by: m];
+    }
+
+    cur = [args car];
+    
+    if (![cur isKindOfClass: [Number class]]) {
+            return [Error type: "-"
+                          message: sprintf("non-number argument: %s\n",
+                                           [cur printForm])
+                          by: m];
+    }
+
+    diff = [(Number) cur intValue];
+    
+    if ([args cdr] == [Nil nil]) {
+            return [Number newFromInt: -diff];
+    }
+    
+    for (cur = [args cdr]; cur != [Nil nil]; cur = [cur cdr]) {
+            if (![[cur car] isKindOfClass: [Number class]]) {
+                    return [Error type: "-"
+                                  message: sprintf("non-number argument: %s\n",
+                                                   [[cur car] printForm])
+                                  by: m];
+            }                     
+            diff -= [(Number) [cur car] intValue];
+    }
+
+    return [Number newFromInt: diff];
+}
+
+SchemeObject bi_mult (SchemeObject args, Machine m)
+{
+    local integer prod = 1;
+    local SchemeObject cur;
+
+    for (cur = args; cur != [Nil nil]; cur = [cur cdr]) {
+            if (![[cur car] isKindOfClass: [Number class]]) {
+                    return [Error type: "*"
+                                  message: sprintf("non-number argument: %s\n",
+                                                   [[cur car] printForm])
+                                  by: m];
+            }                     
+            prod *= [(Number) [cur car] intValue];
+    }
+
+    return [Number newFromInt: prod];
+}
+
+SchemeObject bi_div (SchemeObject args, Machine m)
+{
+    local integer frac = 0;
+    local SchemeObject cur;
+
+    if (args == [Nil nil]) {
+            return [Error type: "/"
+                          message: sprintf("expected at least 1 argument")
+                          by: m];
+    }
+
+    cur = [args car];
+    
+    if (![cur isKindOfClass: [Number class]]) {
+            return [Error type: "/"
+                          message: sprintf("non-number argument: %s\n",
+                                           [cur printForm])
+                          by: m];
+    }
+
+    frac = [(Number) cur intValue];
+    
+    if ([args cdr] == [Nil nil]) {
+            return [Number newFromInt: 1/frac];
+    }
+    
+    for (cur = [args cdr]; cur != [Nil nil]; cur = [cur cdr]) {
+            if (![[cur car] isKindOfClass: [Number class]]) {
+                    return [Error type: "/"
+                                  message: sprintf("non-number argument: %s\n",
+                                                   [[cur car] printForm])
+                                  by: m];
+            }                     
+            frac /= [(Number) [cur car] intValue];
+    }
+
+    return [Number newFromInt: frac];
+}
+
 SchemeObject bi_cons (SchemeObject args, Machine m)
 {
     if (!num_args(args, 2)) {
@@ -157,25 +253,93 @@ SchemeObject bi_callcc (SchemeObject args, Machine m)
     return NIL;
 }
 
+SchemeObject bi_eq (SchemeObject args, Machine m)
+{
+    if (!num_args(args, 2)) {
+            return [Error type: "eq?"
+                          message: "expected 2 arguments"
+                          by: m];
+    }
+    return
+        [args car] == [[args cdr] car] ?
+        [Boolean trueConstant] :
+        [Boolean falseConstant];
+}
+
+SchemeObject bi_numeq (SchemeObject args, Machine m)
+{
+    local SchemeObject num1, num2;
+    if (!num_args(args, 2)) {
+            return [Error type: "="
+                          message: "expected 2 arguments"
+                          by: m];
+    }
+    num1 = [args car];
+    num2 = [[args cdr] car];
+    if (![num1 isKindOfClass: [Number class]]) {
+            return [Error type: "="
+                          message: sprintf("expected number argument, got: %s",
+                                           [num1 printform])
+                          by: m];
+    } else if (![num2 isKindOfClass: [Number class]]) {
+            return [Error type: "="
+                          message: sprintf("expected number argument, got: %s",
+                                           [num2 printform])
+                          by: m];
+    }
+
+    return
+        [num1 intValue] == [num2 intValue] ?
+        [Boolean trueConstant] :
+        [Boolean falseConstant];
+}
+
+SchemeObject bi_islist (SchemeObject args, Machine m)
+{
+    if (!num_args(args, 1)) {
+            return [Error type: "list?"
+                          message: "expected 1 argument"
+                          by: m];
+    }
+
+    return
+        isList (args) ?
+        [Boolean trueConstant] :
+        [Boolean falseConstant];
+}
+
+SchemeObject bi_ispair (SchemeObject args, Machine m)
+{
+    if (!num_args(args, 1)) {
+            return [Error type: "pair?"
+                          message: "expected 1 argument"
+                          by: m];
+    }
+
+    return
+        [[args car] isKindOfClass: [Cons class]] ?
+        [Boolean trueConstant] :
+        [Boolean falseConstant];
+}
+
+#define builtin(name, func) [m addGlobal: symbol(#name) value: [Primitive newFromFunc: (func)]]
 
 void builtin_addtomachine (Machine m)
 {
-    [m addGlobal: symbol("display")
-       value: [Primitive newFromFunc: bi_display]];
-    [m addGlobal: symbol("newline")
-       value: [Primitive newFromFunc: bi_newline]];
-    [m addGlobal: symbol("+")
-       value: [Primitive newFromFunc: bi_add]];
-    [m addGlobal: symbol("cons")
-       value: [Primitive newFromFunc: bi_cons]];
-    [m addGlobal: symbol("null?")
-       value: [Primitive newFromFunc: bi_null]];
-    [m addGlobal: symbol("car")
-       value: [Primitive newFromFunc: bi_car]];
-    [m addGlobal: symbol("cdr")
-       value: [Primitive newFromFunc: bi_cdr]];
-    [m addGlobal: symbol("apply")
-       value: [Primitive newFromFunc: bi_apply]];
-    [m addGlobal: symbol("call-with-current-continuation")
-       value: [Primitive newFromFunc: bi_callcc]];
+    builtin(display, bi_display);
+    builtin(newline, bi_newline);
+    builtin(+, bi_add);
+    builtin(-, bi_sub);
+    builtin(*, bi_mult);
+    builtin(/, bi_div);
+    builtin(cons, bi_cons);
+    builtin(null?, bi_null);
+    builtin(car, bi_car);
+    builtin(cdr, bi_cdr);
+    builtin(apply, bi_apply);
+    builtin(call-with-current-continuation, bi_callcc);
+    builtin(eq?, bi_eq);
+    builtin(=, bi_numeq);
+    builtin(list?, bi_islist);
+    builtin(pair?, bi_ispair);
 }