Added proper error checking and reporting with line numbers. Next:

Runtime errors and support for line number reporting with the error.

ruamoko/scheme/Compiler.h

@@ -4,6 +4,7 @@
 #include "CompiledCode.h"
 #include "Symbol.h"
 #include "Scope.h"
+#include "Error.h"
 
 @interface Compiler: SchemeObject
 {
@@ -11,12 +12,12 @@
     SchemeObject sexpr;
     Symbol lambdaSym, quoteSym;
     Scope scope;
+    Error err;
 }
 
 + (id) newWithLambda: (SchemeObject) xp scope: (Scope) sc;
 - (id) initWithLambda: (SchemeObject) xp scope: (Scope) sc;
-- (void) compile;
-- (CompiledCode) code;
+- (SchemeObject) compile;
 
 @end
 

ruamoko/scheme/Compiler.r

@@ -18,9 +18,11 @@
     lambdaSym = [Symbol forString: "lambda"];
     quoteSym = [Symbol forString: "quote"];
     code = [CompiledCode new];
+    err = NIL;
     return self;
 }
 
+// FIXME: handle variable argument lists
 - (void) emitBuildEnvironment: (SchemeObject) arguments
 {
     local integer count, index;
@@ -47,6 +49,7 @@
 
     for (cur = expressions; cur != [Nil nil]; cur = [cur cdr]) {
             [self emitExpression: [cur car]];
+            if (err) return;
     }
 }
 
@@ -74,10 +77,12 @@
     if ([expression isKindOfClass: [Cons class]]) {
             if ([expression car] == lambdaSym) {
                     [self emitLambda: expression];
+                    if (err) return;
             } else if ([expression car] == quoteSym) {
                     [self emitConstant: [[expression cdr] car]];
             } else {
                     [self emitApply: expression];
+                    if (err) return;
             }
     } else if ([expression isKindOfClass: [Symbol class]]) {
             [self emitVariable: (Symbol) expression];
@@ -92,7 +97,9 @@
             return;
     } else {
             [self emitArguments: [expression cdr]];
+            if (err) return;
             [self emitExpression: [expression car]];
+            if (err) return;
             [code addInstruction: [Instruction opcode: PUSH]];
     }
 }
@@ -102,7 +109,9 @@
     local Instruction label = [Instruction opcode: LABEL];
     [code addInstruction: [Instruction opcode: MAKECONT label: label]];
     [self emitArguments: [expression cdr]];
+    if (err) return;
     [self emitExpression: [expression car]];
+    if (err) return;
     [code addInstruction: [Instruction opcode: CALL]];
     [code addInstruction: label];
 }
@@ -111,10 +120,15 @@
 {
     local Compiler compiler = [Compiler newWithLambda: expression
                                         scope: scope];
+    local SchemeObject res;
     local integer index;
     
-    [compiler compile];
-    index = [code addConstant: [compiler code]];
+    res = [compiler compile];
+    if ([res isError]) {
+            err = (Error) res;
+            return;
+    }          
+    index = [code addConstant: res];
     [code addInstruction: [Instruction opcode: LOADLITS]];
     [code addInstruction: [Instruction opcode: GET operand: index]];
     [code addInstruction: [Instruction opcode: MAKECLOSURE]];
@@ -128,16 +142,34 @@
     [code addInstruction: [Instruction opcode: GET operand: index]];
 }
 
-- (void) compile
+- (void) checkLambdaSyntax: (SchemeObject) expression
 {
-    [self emitBuildEnvironment: [[sexpr cdr] car]];
-    [self emitSequence: [[sexpr cdr] cdr]];
-    [code addInstruction: [Instruction opcode: RETURN]];
-    [code compile];
+    if (![expression isKindOfClass: [Cons class]] ||
+        [expression car] != lambdaSym ||
+        [expression cdr] == [Nil nil] ||
+        [[expression cdr] cdr] == [Nil nil]) {
+            err = [Error type: "syntax"
+                         message: "malformed lambda expression"
+                         by: expression];
+    }
 }
 
-- (CompiledCode) code
+- (SchemeObject) compile
 {
+    [self checkLambdaSyntax: sexpr];
+    if (err) {
+            return err;
+    }
+    [self emitBuildEnvironment: [[sexpr cdr] car]];
+    if (err) {
+            return err;
+    }
+    [self emitSequence: [[sexpr cdr] cdr]];
+    if (err) {
+            return err;
+    }
+    [code addInstruction: [Instruction opcode: RETURN]];
+    [code compile];
     return code;
 }
 

ruamoko/scheme/Error.h

@@ -0,0 +1,17 @@
+#ifndef __Error_h
+#define __Error_h
+#include "SchemeObject.h"
+
+@interface Error: SchemeObject
+{
+    string type, message;
+}
++ (id) type: (string) t message: (string) m by: (SchemeObject) o;
++ (id) type: (string) t message: (string) m;
+- (id) initWithType: (string) t message: (string) m by: (SchemeObject) o;
+- (string) type;
+- (string) message;
+
+@end
+
+#endif //__Error_h

ruamoko/scheme/Error.r

@@ -0,0 +1,50 @@
+#include "Error.h"
+#include "string.h"
+
+@implementation Error
++ (id) type: (string) t message: (string) m by: (SchemeObject) o
+{
+    return [[self alloc] initWithType: t message: m by: o];
+}
+
++ (id) type: (string) t message: (string) m
+{
+    return [[self alloc] initWithType: t message: m by: NIL];
+}
+
+- (id) initWithType: (string) t message: (string) m by: (SchemeObject) o
+{
+    self = [super init];
+    type = str_new();
+    message = str_new();
+    str_copy(type, t);
+    str_copy(message, m);
+    if (o) {
+            [self source: [o source]];
+            [self line: [o line]];
+    }
+    return self;
+}
+
+- (BOOL) isError
+{
+    return true;
+}
+
+- (string) type
+{
+    return type;
+}
+
+- (string) message
+{
+    return message;
+}
+
+- (void) dealloc
+{
+    str_free(type);
+    str_free(message);
+    [super dealloc];
+}
+@end

ruamoko/scheme/Lexer.h

@@ -6,10 +6,13 @@
 @interface Lexer: Object
 {
     string source;
+    string filename;
+    integer linenum;
 }
-+ (id) newFromSource: (string) s;
-- (id) initWithSource: (string) s;
++ (id) newFromSource: (string) s file: (string) f;
+- (id) initWithSource: (string) s file: (string) f;
 - (SchemeObject) nextToken;
+- (integer) lineNumber;
 @end
 
 #endif //__Lexer_h

ruamoko/scheme/Lexer.r

@@ -1,7 +1,7 @@
 #include "Lexer.h"
 #include "Number.h"
 #include "string.h"
-
+#include "defs.h"
 
 BOOL isdigit (string x)
 {
@@ -22,15 +22,17 @@ BOOL issymbol (string x)
 
 @implementation Lexer
 
-+ (id) newFromSource: (string) s
++ (id) newFromSource: (string) s file: (string) f
 {
-    return [[Lexer alloc] initWithSource: s];
+    return [[Lexer alloc] initWithSource: s file: f];
 }
 
-- (id) initWithSource: (string) s
+- (id) initWithSource: (string) s file: (string) f
 {
     self = [super init];
     source = s;
+    filename = f;
+    linenum = 1;
     return self;
 }
 
@@ -40,8 +42,13 @@ BOOL issymbol (string x)
     local Number num;
     local Symbol sym;
     local String str;
-    
-    for (len = 0; isspace(str_mid(source, len, len+1)); len++);
+
+    for (len = 0; isspace(str_mid(source, len, len+1)); len++) {
+            if (str_mid(source, len, len+1) == "\n") {
+                    linenum++;
+            }
+    }
+
     source = str_mid(source, len);
 
     switch (str_mid (source, 0, 1)) {
@@ -57,11 +64,15 @@ BOOL issymbol (string x)
         case "9":
             for (len = 1; isdigit(str_mid(source, len, len+1)); len++);
             num = [Number newFromInt: stoi (str_mid(source, 0, len))];
+            [num source: filename];
+            [num line: linenum];
             source = str_mid(source, len);
             return num;
         case "\"":
             for (len = 1; str_mid(source, len, len+1) != "\""; len++);
             str = [String newFromString: str_mid(source, 1, len)];
+            [str source: filename];
+            [str line: linenum];
             source = str_mid(source, len+1);
             return str;
         case "'":
@@ -77,4 +88,9 @@ BOOL issymbol (string x)
     }
 }
 
+- (integer) lineNumber
+{
+    return linenum;
+}
+
 @end

ruamoko/scheme/Makefile.am

@@ -44,7 +44,8 @@ EXTRA_DATA = $(scheme_data)
 libscheme_a_SOURCES=\
 	SchemeObject.r Cons.r Number.r String.r Symbol.r Lexer.r Parser.r Nil.r \
 	Procedure.r Primitive.r Lambda.r Scope.r Instruction.r builtins.r \
-	Frame.r CompiledCode.r Compiler.r Continuation.r Machine.r Void.r
+	Frame.r CompiledCode.r Compiler.r Continuation.r Machine.r Void.r \
+	Error.r
 libscheme_a_AR=$(PAK) -cf
 
 scheme_data=\

ruamoko/scheme/Parser.h

@@ -5,9 +5,11 @@
 @interface Parser: Object
 {
     Lexer lexer;
+    string file;
 }
-+ (id) newFromSource: (string) s;
-- (id) initWithSource: (string) s;
++ (id) newFromSource: (string) s file: (string) f;
+- (id) initWithSource: (string) s file: (string) f;
+- (SchemeObject) readAtomic;
 - (SchemeObject) read;
 @end
 

ruamoko/scheme/Parser.r

@@ -1,56 +1,106 @@
 #include "Cons.h"
 #include "Parser.h"
 #include "Nil.h"
+#include "Error.h"
 #include "defs.h"
 
 @implementation Parser
 
-+ (id) newFromSource: (string) s
++ (id) newFromSource: (string) s file: (string) f
 {
-    return [[self alloc] initWithSource: s];
+    return [[self alloc] initWithSource: s file: f];
 }
 
-- (id) initWithSource: (string) s
+- (id) initWithSource: (string) s file: (string) f
 {
     self = [super init];
-    lexer = [Lexer newFromSource: s];
+    lexer = [Lexer newFromSource: s file: f];
+    file = f;
     return self;
 }
 
 - (SchemeObject) readList
 {
-    local SchemeObject token;
-    
-    token = [self read];
+    local SchemeObject token, res;
+    local integer line;
+    local Error err;
 
-    if (!token)
-            return NIL;
+    line = [lexer lineNumber];
+    token = [self readAtomic];
+
+    if ([token isError])
+            return token;
+    
+    if (!token) {
+            err = [Error type: "parse" message: "Unmatched open parenthesis"];
+            [err source: file];
+            [err line: [lexer lineNumber]];
+            return err;
+    }
     
     if (token == [Symbol rightParen]) {
             return [Nil nil];
     } else {
-            return [Cons newWithCar: token cdr: [self readList]];
+            res = [self readList];
+            if ([res isError]) return res;
+            res = cons(token, res);
+            [res source: file];
+            [res line: line];
+            return res;
     }
 }
 
+- (SchemeObject) readAtomic
+{
+    local SchemeObject token, list, res;
+    local integer line;
+
+    line = [lexer lineNumber];
+
+    token = [lexer nextToken];
+
+    if ([token isError]) {
+            return token;
+    }
+    
+    if (!token) {
+            return NIL;
+    }
+
+    if (token == [Symbol leftParen]) {
+            list = [self readList];
+            return list;
+    } else if (token == [Symbol quote]) {
+            res = [self read];
+            if ([res isError]) return res;
+            res = cons(res, [Nil nil]);
+            [res source: file];
+            [res line: line];
+            res = cons([Symbol forString: "quote"], res);
+            [res source: file];
+            [res line: line];
+            return res;
+    } else return token;
+}
+
 - (SchemeObject) read
 {
     local SchemeObject token;
-    local SchemeObject list;
-    
-    token = [lexer nextToken];
+    local Error err;
 
-    if (!token) {
-            return NIL;
+    token = [self readAtomic];
+    if (token == [Symbol rightParen]) {
+            err = [Error type: "parse" message: "mismatched close parentheis"];
+            [err source: file];
+            [err line: [lexer lineNumber]];
+            return err;
     }
+    return token;
+}
 
-    
-    if (token == [Symbol leftParen]) {
-            list = [self readList];
-            return list;
-    } else if (token == [Symbol quote]) {
-            return cons([Symbol forString: "quote"], cons([self read], [Nil nil]));
-    } else return token;
+- (void) markReachable
+{
+    [lexer mark];
 }
 
 @end

ruamoko/scheme/SchemeObject.h

@@ -16,11 +16,18 @@
 {
     @public SchemeObject prev, next;
     BOOL marked, root;
+    integer line;
+    string source;
 }
 - (void) mark;
 - (void) markReachable;
 - (void) makeRootCell;
 - (string) printForm;
+- (string) source;
+- (void) source: (string) s;
+- (integer) line;
+- (void) line: (integer) l;
+- (BOOL) isError;
 @end
 
 #endif //__SchemeObject_h

ruamoko/scheme/SchemeObject.r

@@ -136,4 +136,29 @@ BOOL contains (SchemeObject list, SchemeObject what)
     [super dealloc];
 }
 
+- (BOOL) isError
+{
+    return false;
+}
+
+- (string) source
+{
+    return source;
+}
+
+- (void) source: (string) s
+{
+    source = s;
+}
+
+- (integer) line
+{
+    return line;
+}
+
+- (void) line: (integer) l
+{
+    line = l;
+}
+
 @end

ruamoko/scheme/main.qc

@@ -15,7 +15,7 @@ string readfile (string filename)
     local string acc = "", res;
     local QFile file = Qopen (filename, "r");
     while (!Qeof (file)) {
-            acc += Qgetline (file) + "\n";
+            acc += Qgetline (file);
     }
     Qclose (file);
     res = str_new();
@@ -38,7 +38,7 @@ integer main (integer argc, string []argv)
     }
     
     builtin_init();
-    parser = [Parser newFromSource: readfile(argv[1])];
+    parser = [Parser newFromSource: readfile(argv[1]) file: argv[1]];
     vm = [Machine new];
     [vm makeRootCell];
     [vm addGlobal: [Symbol forString: "display"] value: print_p];
@@ -47,12 +47,21 @@ integer main (integer argc, string []argv)
     [vm addGlobal: [Symbol forString: "map"] value: map_p];
     [vm addGlobal: [Symbol forString: "for-each"] value: for_each_p];
     while ((stuff = [parser read])) {
+            if ([stuff isError]) {
+                    printf(">> %s: %i\n", [stuff source], [stuff line]);
+                    printf(">> Error (%s): %s\n", [stuff type], [stuff message]);
+                    return -1;
+            }
             comp = [Compiler newWithLambda: cons ([Symbol forString: "lambda"],
                                                   cons ([Nil nil],
                                                         cons(stuff, [Nil nil])))
                              scope: NIL];
-            [comp compile];
-            code = [comp code];
+            code = (CompiledCode) [comp compile];
+            if ([code isError]) {
+                    printf(">> %s: %i\n", [code source], [code line]);
+                    printf(">> Error (%s): %s\n", [code type], [code message]);
+                    return -1;
+            }
             lm = [Lambda newWithCode: code environment: NIL];
             [lm invokeOnMachine: vm];
             [vm run];