diff --git a/ruamoko/scheme/CompiledCode.h b/ruamoko/scheme/CompiledCode.h index 9e6f1433e..90e12825b 100644 --- a/ruamoko/scheme/CompiledCode.h +++ b/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 diff --git a/ruamoko/scheme/CompiledCode.r b/ruamoko/scheme/CompiledCode.r index e423dc10c..32b4779fb 100644 --- a/ruamoko/scheme/CompiledCode.r +++ b/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; diff --git a/ruamoko/scheme/Compiler.r b/ruamoko/scheme/Compiler.r index 84c1d4c77..c4505412f 100644 --- a/ruamoko/scheme/Compiler.r +++ b/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) { diff --git a/ruamoko/scheme/Cons.h b/ruamoko/scheme/Cons.h index 11124a24b..784b4ea25 100644 --- a/ruamoko/scheme/Cons.h +++ b/ruamoko/scheme/Cons.h @@ -15,5 +15,6 @@ @end @extern Cons cons (SchemeObject car, SchemeObject cdr); +@extern BOOL isList (SchemeObject ls); #endif //__Cons_h diff --git a/ruamoko/scheme/Cons.r b/ruamoko/scheme/Cons.r index ed9d7b354..2179fb32e 100644 --- a/ruamoko/scheme/Cons.r +++ b/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 diff --git a/ruamoko/scheme/Continuation.r b/ruamoko/scheme/Continuation.r index 9e84c1c08..8e50c7ff8 100644 --- a/ruamoko/scheme/Continuation.r +++ b/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; } diff --git a/ruamoko/scheme/Lambda.r b/ruamoko/scheme/Lambda.r index 8939674ca..8923b1880 100644 --- a/ruamoko/scheme/Lambda.r +++ b/ruamoko/scheme/Lambda.r @@ -23,6 +23,7 @@ [super invokeOnMachine: m]; [m loadCode: code]; [m environment: env]; + [m procedure: self]; } - (void) markReachable diff --git a/ruamoko/scheme/Machine.h b/ruamoko/scheme/Machine.h index 11ddf61e5..7768624e6 100644 --- a/ruamoko/scheme/Machine.h +++ b/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 diff --git a/ruamoko/scheme/Machine.r b/ruamoko/scheme/Machine.r index 47929cb41..b3559baa0 100644 --- a/ruamoko/scheme/Machine.r +++ b/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 diff --git a/ruamoko/scheme/SchemeObject.r b/ruamoko/scheme/SchemeObject.r index 1c81a70d3..62a41d99a 100644 --- a/ruamoko/scheme/SchemeObject.r +++ b/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]; diff --git a/ruamoko/scheme/builtins.r b/ruamoko/scheme/builtins.r index b0c85a87c..40b18d3e7 100644 --- a/ruamoko/scheme/builtins.r +++ b/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 { diff --git a/ruamoko/scheme/main.qc b/ruamoko/scheme/main.qc index 9ab5a6160..add4faaa8 100644 --- a/ruamoko/scheme/main.qc +++ b/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; diff --git a/ruamoko/scheme/state.h b/ruamoko/scheme/state.h index 53c3a291a..17752673b 100644 --- a/ruamoko/scheme/state.h +++ b/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;