Added runtime error checking and line number tracking. Seems to catch most

Scheme program errors without making Rua abort now, although there are a
few things that still need to actually report errors instead of failing
in weird ways.

ruamoko/scheme/CompiledCode.h

@@ -4,6 +4,14 @@
 #include "Array.h"
 #include "Instruction.h"
 #include "Frame.h"
+#include "String.h"
+
+struct lineinfo_s {
+    integer linenumber;
+    String sourcefile;
+};
+    
+typedef struct lineinfo_s lineinfo_t;
 
 @interface CompiledCode: SchemeObject
 {
@@ -11,11 +19,13 @@
     Array instructions;
     Array constants;
     instruction_t [] code;
+    lineinfo_t [] lineinfo;
 }
 - (void) addInstruction: (Instruction) inst;
 - (integer) addConstant: (SchemeObject) c;
 - (void) compile;
 - (instruction_t []) code;
+- (lineinfo_t []) lineinfo;
 - (Frame) literals;
 @end
 

ruamoko/scheme/CompiledCode.r

@@ -1,4 +1,5 @@
 #include "CompiledCode.h"
+#include "Symbol.h"
 #include "defs.h"
 
 @implementation CompiledCode
@@ -10,6 +11,8 @@
     return self;
 }
 
+
+
 - (void) markReachable
 {
     [literals mark];
@@ -21,6 +24,8 @@
 
 - (void) addInstruction: (Instruction) inst
 {
+    [inst line: [self line]];
+    [inst source: [self source]];
     [inst offset: [instructions count]];
     if ([inst opcode] != LABEL) {
             [instructions addItem: inst];
@@ -40,12 +45,16 @@
     local Instruction inst;
     literals = [Frame newWithSize: [constants count] link: NIL];
     code = obj_malloc (@sizeof(instruction_t) * [instructions count]);
+    lineinfo = obj_malloc(@sizeof(lineinfo_t) * [instructions count]);
     for (index = 0; index < [constants count]; index++) {
             [literals set: index to: (SchemeObject) [constants getItemAt: index]];
     }
     for (index = 0; index < [instructions count]; index++) {
             inst = [instructions getItemAt: index];
             [inst emitStruct: code];
+            lineinfo[index].linenumber = [inst line];
+            lineinfo[index].sourcefile = symbol([inst source]);
+            [lineinfo[index].sourcefile retain];
     }
     [instructions release];
     [constants release];
@@ -57,6 +66,11 @@
     return code;
 }
 
+- (lineinfo_t []) lineinfo
+{
+    return lineinfo;
+}
+
 - (Frame) literals
 {
     return literals;

ruamoko/scheme/Compiler.r

@@ -185,6 +185,14 @@ Symbol letrecSym;
     local SchemeObject bindings;
     local integer count;
 
+    if (!isList(expression) ||
+        !isList([expression car]) ||
+        ![[expression cdr] isKindOfClass: [Cons class]]) {
+            err = [Error type: "syntax"
+                         message: "Malformed letrec expression"
+                         by: expression];
+    }
+    
     scope = [Scope newWithOuter: scope];
     
     count = 0;
@@ -214,6 +222,9 @@ Symbol letrecSym;
 - (void) emitExpression: (SchemeObject) expression flags: (integer) fl
 {
     if ([expression isKindOfClass: [Cons class]]) {
+            [code source: [expression source]];
+            [code line: [expression line]];
+            
             if ([expression car] == lambdaSym) {
                     [self emitLambda: expression];
             } else if ([expression car] == quoteSym) {

ruamoko/scheme/Cons.h

@@ -15,5 +15,6 @@
 @end
 
 @extern Cons cons (SchemeObject car, SchemeObject cdr);
+@extern BOOL isList (SchemeObject ls);
 
 #endif //__Cons_h

ruamoko/scheme/Cons.r

@@ -8,6 +8,13 @@ Cons cons (SchemeObject car, SchemeObject cdr)
     return [Cons newWithCar: car cdr: cdr];
 }
 
+BOOL isList (SchemeObject ls)
+{
+    return ls == [Nil nil] ||
+        ([ls isKindOfClass: [Cons class]] &&
+         isList([ls cdr]));
+}
+
 @implementation Cons
 
 + (id) newWithCar: (SchemeObject) a cdr: (SchemeObject) d

ruamoko/scheme/Continuation.r

@@ -15,6 +15,8 @@
     state.stack = st.stack;
     state.cont = st.cont;
     state.env = st.env;
+    state.proc = st.proc;
+    state.lineinfo = st.lineinfo;
     return self;
 }
 

ruamoko/scheme/Lambda.r

@@ -23,6 +23,7 @@
     [super invokeOnMachine: m];
     [m loadCode: code];
     [m environment: env];
+    [m procedure: self];
 }
 
 - (void) markReachable

ruamoko/scheme/Machine.h

@@ -25,6 +25,7 @@
 - (void) stack: (SchemeObject) o;
 - (state_t []) state;
 - (void) state: (state_t []) st;
+- (void) reset;
 @end
 
 #endif //__Machine_h

ruamoko/scheme/Machine.r

@@ -4,6 +4,9 @@
 #include "Boolean.h"
 #include "Nil.h"
 #include "defs.h"
+#include "string.h"
+#include "Error.h"
+//#include "debug.h"
 
 string GlobalGetKey (void []ele, void []data)
 {
@@ -26,7 +29,9 @@ void GlobalFree (void []ele, void []data)
     state.cont = NIL;
     state.env = NIL;
     state.literals = NIL;
+    state.proc = NIL;
     state.stack = [Nil nil];
+    state.lineinfo = NIL;
     globals = Hash_NewTable(1024, GlobalGetKey, GlobalFree, NIL);
     all_globals = [Nil nil];
     return self;
@@ -43,6 +48,7 @@ void GlobalFree (void []ele, void []data)
 {
     state.program = [code code];
     state.literals = [code literals];
+    state.lineinfo = [code lineinfo];
     state.pc = 0;
 }
 
@@ -95,6 +101,7 @@ void GlobalFree (void []ele, void []data)
     state.cont = st[0].cont;
     state.env = st[0].env;
     state.proc = st[0].proc;
+    state.lineinfo = st[0].lineinfo;
 }
 
 - (void) procedure: (Procedure) pr
@@ -106,7 +113,12 @@ void GlobalFree (void []ele, void []data)
 {
     local integer opcode;
     local integer operand;
+    local SchemeObject res;
     while (1) {
+            if (value && [value isError]) {
+                    dprintf("Error: %s[%s]\n", [value description], [value printForm]);
+                    return value;
+            }
             opcode = state.program[state.pc].opcode;
             operand = state.program[state.pc].operand;
             state.pc = state.pc + 1;
@@ -180,7 +192,14 @@ void GlobalFree (void []ele, void []data)
                     break;
                 case GETGLOBAL:
                     dprintf("Getglobal: %s\n", [value printForm]);
-                    value = [((Cons) Hash_Find(globals, [value printForm])) cdr];
+                    res = [((Cons) Hash_Find(globals, [value printForm])) cdr];
+                    if (!res) {
+                            return [Error type: "binding"
+                                          message: sprintf("Undefined binding: %s",
+                                                           [value printForm])
+                                          by: self];
+                    }
+                    value = res;
                     dprintf(" --> %s\n", [value printForm]);
                     break;
                 case SETGLOBAL:
@@ -191,6 +210,13 @@ void GlobalFree (void []ele, void []data)
                 case CALL:
                     dprintf("Call\n");
                     [SchemeObject collectCheckPoint];
+                    if (![value isKindOfClass: [Procedure class]]) {
+                            return [Error type: "call"
+                                          message:
+                                              sprintf("Attempted to apply non-procedure: %s. Arguments were: %s",
+                                                      [value printForm], [state.stack printForm])
+                                          by: self];
+                    }
                     [value invokeOnMachine: self];
                     break;
                 case RETURN:
@@ -215,6 +241,24 @@ void GlobalFree (void []ele, void []data)
     }
 }
 
+- (string) source
+{
+    if (state.lineinfo) {
+            return [state.lineinfo[state.pc-1].sourcefile stringValue];
+    } else {
+            return [super source];
+    }
+}
+
+- (integer) line
+{
+    if (state.lineinfo) {
+            return state.lineinfo[state.pc-1].linenumber;
+    } else {
+            return [super line];
+    }
+}
+
 - (void) markReachable
 {
     [state.literals mark];
@@ -225,5 +269,10 @@ void GlobalFree (void []ele, void []data)
     [value mark];
     [all_globals mark];
 }
+
+- (void) reset
+{
+    state.stack = [Nil nil];
+}
 @end
 

ruamoko/scheme/SchemeObject.r

@@ -165,6 +165,8 @@ integer checkpoint;
 
 - (void) makeRootCell
 {
+    if (root)
+            return;
     if (gc_state) {
             dprintf("Root cell made during collection!\n");
             [SchemeObject finishCollecting];

ruamoko/scheme/builtins.r

@@ -8,15 +8,34 @@
 #include "Continuation.h"
 #include "BaseContinuation.h"
 #include "Boolean.h"
+#include "Error.h"
+
+BOOL num_args (SchemeObject list, integer num)
+{
+    for (; [list isKindOfClass: [Cons class]]; list = [list cdr]) {
+            num--;
+    }
+    return num == 0;
+}
 
 SchemeObject bi_display (SchemeObject args, Machine m)
 {
+    if (!num_args(args, 1)) {
+            return [Error type: "display"
+                          message: "expected 1 argument"
+                          by: m];
+    }
     print([[args car] printForm]);
     return [Void voidConstant];
 }
 
 SchemeObject bi_newline (SchemeObject args, Machine m)
 {
+    if (!num_args(args, 0)) {
+            return [Error type: "newline"
+                          message: "expected no arguments"
+                          by: m];
+    }
     print("\n");
     return [Void voidConstant];
 }
@@ -27,6 +46,12 @@ SchemeObject bi_add (SchemeObject args, Machine m)
     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];
+            }                     
             sum += [(Number) [cur car] intValue];
     }
 
@@ -35,12 +60,22 @@ SchemeObject bi_add (SchemeObject args, Machine m)
 
 SchemeObject bi_cons (SchemeObject args, Machine m)
 {
+    if (!num_args(args, 2)) {
+            return [Error type: "cons"
+                          message: "expected 2 arguments"
+                          by: m];
+    }
     [args cdr: [[args cdr] car]];
     return args;
 }
 
 SchemeObject bi_null (SchemeObject args, Machine m)
 {
+    if (!num_args(args, 1)) {
+            return [Error type: "null?"
+                          message: "expected 1 argument"
+                          by: m];
+    }
     return [args car] == [Nil nil]
         ?
         [Boolean trueConstant] :
@@ -49,16 +84,51 @@ SchemeObject bi_null (SchemeObject args, Machine m)
 
 SchemeObject bi_car (SchemeObject args, Machine m)
 {
+    if (!num_args(args, 1)) {
+            return [Error type: "car"
+                          message: "expected 1 argument"
+                          by: m];
+    }
+    if (![[args car] isKindOfClass: [Cons class]]) {
+            return [Error type: "car"
+                          message: sprintf("expected pair, got: %s",
+                                           [[args car] printForm])
+                          by: m];
+    }
+                
     return [[args car] car];
 }
 
 SchemeObject bi_cdr (SchemeObject args, Machine m)
 {
+    if (!num_args(args, 1)) {
+            return [Error type: "cdr"
+                          message: "expected 1 argument"
+                          by: m];
+    }
+    if (![[args car] isKindOfClass: [Cons class]]) {
+            return [Error type: "cdr"
+                          message: sprintf("expected pair, got: %s",
+                                           [[args car] printForm])
+                          by: m];
+    }
     return [[args car] cdr];
 }
 
 SchemeObject bi_apply (SchemeObject args, Machine m)
 {
+    if (args == [Nil nil]) {
+            return [Error type: "apply"
+                          message: "expected at least 1 argument"
+                          by: m];
+    } else if (![[args car] isKindOfClass: [Procedure class]]) {
+            return [Error type: "apply"
+                          message:
+                              sprintf("expected procedure as 1st argument, got: %s",
+                                      [[args car] printForm])
+                          by: m];
+    }
+    
     [m stack: [[args cdr] car]];
     [[args car] invokeOnMachine: m];
     return NIL;
@@ -66,6 +136,17 @@ SchemeObject bi_apply (SchemeObject args, Machine m)
 
 SchemeObject bi_callcc (SchemeObject args, Machine m)
 {
+    if (args == [Nil nil]) {
+            return [Error type: "call-with-current-continuation"
+                          message: "expected at least 1 argument"
+                          by: m];
+    } else if (![[args car] isKindOfClass: [Procedure class]]) {
+            return [Error type: "call-with-current-continuation"
+                          message:
+                              sprintf("expected procedure as 1st argument, got: %s",
+                                      [[args car] printForm])
+                          by: m];
+    }
     if ([m continuation]) {
             [m stack: cons([m continuation], [Nil nil])];
     } else {

ruamoko/scheme/main.qc

@@ -31,7 +31,7 @@ integer main (integer argc, string []argv)
     local Compiler comp;
     local Machine vm;
     local Lambda lm;
-    local SchemeObject stuff;
+    local SchemeObject stuff, res;
 
     if (argc < 1) {
             return -1;
@@ -62,7 +62,13 @@ integer main (integer argc, string []argv)
             }
             lm = [Lambda newWithCode: code environment: NIL];
             [lm invokeOnMachine: vm];
-            [vm run];
+            res = [vm run];
+            if ([res isError]) {
+                    printf(">> %s: %i\n", [res source], [res line]);
+                    printf(">> Error (%s): %s\n", [res type], [res message]);
+                    return -1;
+            }
+            [vm reset];
     }
     [SchemeObject finishCollecting];
     return 0;

ruamoko/scheme/state.h

@@ -3,11 +3,13 @@
 
 #include "Instruction.h"
 #include "Frame.h"
+#include "CompiledCode.h"
 
 @class Continuation;
 
 struct state_s = {
     instruction_t [] program;
+    lineinfo_t [] lineinfo;
     integer pc;
     Frame literals, env;
     SchemeObject stack;