From adba6b26dc7f159959e1dc02198e9104211737d0 Mon Sep 17 00:00:00 2001 From: Brian Koropoff Date: Fri, 6 May 2005 23:25:06 +0000 Subject: [PATCH] Scheme updates: - Boolean type (no support in lexer yet) - Conditionals - Defines (only work correctly at top level) - More core builtins (apply, cons, car, cdr) - Variable-argument functions - Incremental garbage collection - Garbage collection fixes - Other misc bugs fixed --- ruamoko/scheme/.gitignore | 1 + ruamoko/scheme/Boolean.h | 12 ++++ ruamoko/scheme/Boolean.r | 32 +++++++++ ruamoko/scheme/CompiledCode.r | 27 +++++-- ruamoko/scheme/Compiler.h | 1 - ruamoko/scheme/Compiler.r | 125 +++++++++++++++++++++++++++++---- ruamoko/scheme/Continuation.h | 6 +- ruamoko/scheme/Continuation.r | 17 +++-- ruamoko/scheme/Instruction.h | 7 +- ruamoko/scheme/Lambda.r | 1 + ruamoko/scheme/Lexer.h | 2 +- ruamoko/scheme/Lexer.r | 20 +++--- ruamoko/scheme/Machine.h | 3 +- ruamoko/scheme/Machine.r | 83 ++++++++++++++++------ ruamoko/scheme/Makefile.am | 2 +- ruamoko/scheme/Parser.h | 2 +- ruamoko/scheme/Parser.r | 12 +++- ruamoko/scheme/Primitive.r | 7 +- ruamoko/scheme/Procedure.r | 1 + ruamoko/scheme/SchemeObject.h | 7 +- ruamoko/scheme/SchemeObject.r | 128 +++++++++++++++++++++++++++------- ruamoko/scheme/Scope.r | 6 +- ruamoko/scheme/Symbol.h | 3 + ruamoko/scheme/Symbol.r | 13 ++++ ruamoko/scheme/builtins.h | 7 +- ruamoko/scheme/builtins.r | 104 +++++++++++++-------------- ruamoko/scheme/debug.h | 4 ++ ruamoko/scheme/defs.h | 4 +- ruamoko/scheme/defs.qc | 4 +- ruamoko/scheme/main.qc | 12 ++-- ruamoko/scheme/state.h | 6 +- 31 files changed, 484 insertions(+), 175 deletions(-) create mode 100644 ruamoko/scheme/Boolean.h create mode 100644 ruamoko/scheme/Boolean.r create mode 100644 ruamoko/scheme/debug.h diff --git a/ruamoko/scheme/.gitignore b/ruamoko/scheme/.gitignore index d5dbce515..ab744ed76 100644 --- a/ruamoko/scheme/.gitignore +++ b/ruamoko/scheme/.gitignore @@ -4,5 +4,6 @@ *.src *.sym .vimrc +*~ Makefile.in Makefile diff --git a/ruamoko/scheme/Boolean.h b/ruamoko/scheme/Boolean.h new file mode 100644 index 000000000..336585714 --- /dev/null +++ b/ruamoko/scheme/Boolean.h @@ -0,0 +1,12 @@ +#ifndef __Boolean_h +#define __Boolean_h +#include "SchemeObject.h" + +@interface Boolean: SchemeObject +{ +} ++ (id) trueConstant; ++ (id) falseConstant; +@end + +#endif //__Void_h diff --git a/ruamoko/scheme/Boolean.r b/ruamoko/scheme/Boolean.r new file mode 100644 index 000000000..eb2db0b07 --- /dev/null +++ b/ruamoko/scheme/Boolean.r @@ -0,0 +1,32 @@ +#include "Boolean.h" + +Boolean trueConstant; +Boolean falseConstant; + +@implementation Boolean + ++ (void) initialize +{ + trueConstant = [Boolean new]; + [trueConstant makeRootCell]; + falseConstant = [Boolean new]; + [falseConstant makeRootCell]; + +} + ++ (id) trueConstant +{ + return trueConstant; +} + ++ (id) falseConstant +{ + return falseConstant; +} + +- (string) printForm +{ + return self == trueConstant ? "#t" : "#f"; +} + +@end diff --git a/ruamoko/scheme/CompiledCode.r b/ruamoko/scheme/CompiledCode.r index f05e02a9c..e423dc10c 100644 --- a/ruamoko/scheme/CompiledCode.r +++ b/ruamoko/scheme/CompiledCode.r @@ -13,8 +13,10 @@ - (void) markReachable { [literals mark]; - [constants makeObjectsPerformSelector: @selector(mark)]; - [instructions makeObjectsPerformSelector: @selector(mark)]; + if (constants) + [constants makeObjectsPerformSelector: @selector(mark)]; + if (instructions) + [instructions makeObjectsPerformSelector: @selector(mark)]; } - (void) addInstruction: (Instruction) inst @@ -30,7 +32,7 @@ local integer number = [constants count]; [constants addItem: c]; return number; -} +} - (void) compile { @@ -62,10 +64,23 @@ - (void) dealloc { - [instructions release]; - [constants release]; - if (code) + local Array temp; + + if (instructions) { + temp = instructions; + instructions = NIL; + [temp release]; + } + if (constants) { + temp = constants; + constants = NIL; + [temp release]; + } + + if (code) { obj_free (code); + } + [super dealloc]; } @end diff --git a/ruamoko/scheme/Compiler.h b/ruamoko/scheme/Compiler.h index f4e1e1a9c..d01bed8fc 100644 --- a/ruamoko/scheme/Compiler.h +++ b/ruamoko/scheme/Compiler.h @@ -10,7 +10,6 @@ { CompiledCode code; SchemeObject sexpr; - Symbol lambdaSym, quoteSym; Scope scope; Error err; } diff --git a/ruamoko/scheme/Compiler.r b/ruamoko/scheme/Compiler.r index 99dda6f50..1883a8c36 100644 --- a/ruamoko/scheme/Compiler.r +++ b/ruamoko/scheme/Compiler.r @@ -1,10 +1,29 @@ #include "Compiler.h" #include "Instruction.h" #include "Nil.h" +#include "Void.h" +#include "Boolean.h" #include "Cons.h" #include "defs.h" +Symbol lambdaSym; +Symbol quoteSym; +Symbol defineSym; +Symbol ifSym; + @implementation Compiler ++ (void) initialize +{ + lambdaSym = [Symbol forString: "lambda"]; + [lambdaSym makeRootCell]; + quoteSym = [Symbol forString: "quote"]; + [quoteSym makeRootCell]; + defineSym = [Symbol forString: "define"]; + [defineSym makeRootCell]; + ifSym = [Symbol forString: "if"]; + [ifSym makeRootCell]; +} + + (id) newWithLambda: (SchemeObject) xp scope: (Scope) sc { return [[self alloc] initWithLambda: xp scope: sc]; @@ -15,14 +34,11 @@ self = [super init]; sexpr = xp; scope = sc; - 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; @@ -30,15 +46,30 @@ scope = [Scope newWithOuter: scope]; count = 0; - for (cur = arguments; cur != [Nil nil]; cur = [cur cdr]) { + for (cur = arguments; [cur isKindOfClass: [Cons class]]; cur = [cur cdr]) { + count++; + } + if (cur != [Nil nil]) { count++; } [code addInstruction: [Instruction opcode: MAKEENV operand: count]]; [code addInstruction: [Instruction opcode: LOADENV]]; cur = arguments; for (index = 0; index < count; cur = [cur cdr]) { - [scope addName: (Symbol) [cur car]]; - [code addInstruction: [Instruction opcode: SET operand: index]]; + if ([cur isKindOfClass: [Cons class]]) { + [scope addName: (Symbol) [cur car]]; + [code addInstruction: [Instruction opcode: SET operand: index]]; + } else if ([cur isKindOfClass: [Symbol class]]) { + [scope addName: (Symbol) cur]; + [code addInstruction: + [Instruction opcode: SETREST operand: index]]; + break; + } else { + err = [Error type: "syntax" + message: "Invalid entry in argument list" + by: arguments]; + return; + } index++; } } @@ -72,17 +103,89 @@ } } +- (void) emitDefine: (SchemeObject) expression +{ + local integer index = 0; + + if (![expression isKindOfClass: [Cons class]] || + ![[expression cdr] isKindOfClass: [Cons class]]) { + err = [Error type: "syntax" + message: "Malformed define statement" + by: expression]; + return; + } + + if ([[expression car] isKindOfClass: [Cons class]]) { + index = [code addConstant: [[expression car] car]]; + [self emitLambda: cons(lambdaSym, + cons([[expression car] cdr], + [expression cdr]))]; + if (err) return; + } else if ([[expression car] isKindOfClass: [Symbol class]]) { + index = [code addConstant: [expression car]]; + [self emitExpression: [[expression cdr] car]]; + if (err) return; + } else { + err = [Error type: "syntax" + message: "Malformed define statement" + by: expression]; + return; + } + [code addInstruction: [Instruction opcode: PUSH]]; + [code addInstruction: [Instruction opcode: LOADLITS]]; + [code addInstruction: [Instruction opcode: GET operand: index]]; + [code addInstruction: [Instruction opcode: SETGLOBAL]]; +} + +- (void) emitIf: (SchemeObject) expression +{ + local Instruction falseLabel, endLabel; + local integer index; + if (![expression isKindOfClass: [Cons class]] || + ![[expression cdr] isKindOfClass: [Cons class]]) { + err = [Error type: "syntax" + message: "Malformed if expression" + by: expression]; + } + + falseLabel = [Instruction opcode: LABEL]; + endLabel = [Instruction opcode: LABEL]; + + [self emitExpression: [expression car]]; + if (err) return; + [code addInstruction: [Instruction opcode: IFFALSE label: falseLabel]]; + [self emitExpression: [[expression cdr] car]]; + if (err) return; + [code addInstruction: [Instruction opcode: GOTO label: endLabel]]; + [code addInstruction: falseLabel]; + if ([[expression cdr] cdr] == [Nil nil]) { + index = [code addConstant: [Void voidConstant]]; + [code addInstruction: [Instruction opcode: LOADLITS]]; + [code addInstruction: [Instruction opcode: GET operand: index]]; + } else { + [self emitExpression: [[[expression cdr] cdr] car]]; + if (err) return; + } + [code addInstruction: endLabel]; +} + + + + + - (void) emitExpression: (SchemeObject) expression { 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 if ([expression car] == defineSym) { + [self emitDefine: [expression cdr]]; + } else if ([expression car] == ifSym) { + [self emitIf: [expression cdr]]; } else { [self emitApply: expression]; - if (err) return; } } else if ([expression isKindOfClass: [Symbol class]]) { [self emitVariable: (Symbol) expression]; @@ -122,7 +225,7 @@ scope: scope]; local SchemeObject res; local integer index; - + res = [compiler compile]; if ([res isError]) { err = (Error) res; @@ -177,9 +280,7 @@ { [code mark]; [sexpr mark]; - [lambdaSym mark]; - [quoteSym mark]; - [Scope mark]; + [scope mark]; } @end diff --git a/ruamoko/scheme/Continuation.h b/ruamoko/scheme/Continuation.h index ea3c8e2f7..e8e1d33f6 100644 --- a/ruamoko/scheme/Continuation.h +++ b/ruamoko/scheme/Continuation.h @@ -7,11 +7,9 @@ @interface Continuation: Procedure { state_t state; - SchemeObject cont; - Frame env; } -+ (id) newWithState: (state_t []) st environment: (Frame) e continuation: (Continuation) c pc: (integer) p; -- (id) initWithState: (state_t []) st environment: (Frame) e continuation: (Continuation) c pc: (integer) p; ++ (id) newWithState: (state_t []) st pc: (integer) p; +- (id) initWithState: (state_t []) st pc: (integer) p; @end diff --git a/ruamoko/scheme/Continuation.r b/ruamoko/scheme/Continuation.r index cdcee6648..0c3d53d76 100644 --- a/ruamoko/scheme/Continuation.r +++ b/ruamoko/scheme/Continuation.r @@ -2,27 +2,25 @@ #include "defs.h" @implementation Continuation -+ (id) newWithState: (state_t []) st environment: (Frame) e continuation: (Continuation) c pc: (integer) p ++ (id) newWithState: (state_t []) st pc: (integer) p { - return [[self alloc] initWithState: st environment: e continuation: c pc: p]; + return [[self alloc] initWithState: st pc: p]; } -- (id) initWithState: (state_t []) st environment: (Frame) e continuation: (Continuation) c pc: (integer) p +- (id) initWithState: (state_t []) st pc: (integer) p { self = [self init]; state.program = st.program; state.pc = p; state.literals = st.literals; state.stack = st.stack; - cont = c; - env = e; + state.cont = st.cont; + state.env = st.env; return self; } - (void) invokeOnMachine: (Machine) m { [m state: &state]; - [m environment: env]; - [m continuation: cont]; return; } @@ -30,8 +28,9 @@ { [state.literals mark]; [state.stack mark]; - [cont mark]; - [env mark]; + [state.cont mark]; + [state.env mark]; + [state.proc mark]; } - (string) printForm diff --git a/ruamoko/scheme/Instruction.h b/ruamoko/scheme/Instruction.h index c2fabeb17..6039bef95 100644 --- a/ruamoko/scheme/Instruction.h +++ b/ruamoko/scheme/Instruction.h @@ -13,10 +13,15 @@ typedef enum { MAKEENV, GET, SET, + SETREST, + SETSTACK, GETLINK, GETGLOBAL, + SETGLOBAL, CALL, - RETURN + RETURN, + IFFALSE, + GOTO } opcode_e; struct instruction_s { diff --git a/ruamoko/scheme/Lambda.r b/ruamoko/scheme/Lambda.r index c151cda9d..8939674ca 100644 --- a/ruamoko/scheme/Lambda.r +++ b/ruamoko/scheme/Lambda.r @@ -20,6 +20,7 @@ - (void) invokeOnMachine: (Machine) m { + [super invokeOnMachine: m]; [m loadCode: code]; [m environment: env]; } diff --git a/ruamoko/scheme/Lexer.h b/ruamoko/scheme/Lexer.h index b56d479fa..2fed9610f 100644 --- a/ruamoko/scheme/Lexer.h +++ b/ruamoko/scheme/Lexer.h @@ -3,7 +3,7 @@ #include "SchemeObject.h" #include "Symbol.h" -@interface Lexer: Object +@interface Lexer: SchemeObject { string source; string filename; diff --git a/ruamoko/scheme/Lexer.r b/ruamoko/scheme/Lexer.r index a9b2299a1..949b5dc21 100644 --- a/ruamoko/scheme/Lexer.r +++ b/ruamoko/scheme/Lexer.r @@ -30,7 +30,8 @@ BOOL issymbol (string x) - (id) initWithSource: (string) s file: (string) f { self = [super init]; - source = s; + source = str_new(); + str_copy(source, s); filename = f; linenum = 1; return self; @@ -49,14 +50,14 @@ BOOL issymbol (string x) } } - source = str_mid(source, len); + str_copy (source, str_mid(source, len)); switch (str_mid (source, 0, 1)) { case "(": - source = str_mid (source, 1); + str_copy (source, str_mid (source, 1)); return [Symbol leftParen]; case ")": - source = str_mid (source, 1); + str_copy (source, str_mid (source, 1)); return [Symbol rightParen]; case "0": case "1": case "2": case "3": case "4": case "5": @@ -66,24 +67,27 @@ BOOL issymbol (string x) num = [Number newFromInt: stoi (str_mid(source, 0, len))]; [num source: filename]; [num line: linenum]; - source = str_mid(source, len); + str_copy (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); + str_copy (source, str_mid(source, len+1)); return str; case "'": - source = str_mid (source, 1); + str_copy (source, str_mid (source, 1)); return [Symbol quote]; + case ".": + str_copy (source, str_mid (source, 1)); + return [Symbol dot]; case "": return NIL; default: for (len = 1; issymbol(str_mid(source, len, len+1)); len++); sym = [Symbol forString: str_mid (source, 0, len)]; - source = str_mid(source, len); + str_copy (source, str_mid(source, len)); return sym; } } diff --git a/ruamoko/scheme/Machine.h b/ruamoko/scheme/Machine.h index e23f7da07..11ddf61e5 100644 --- a/ruamoko/scheme/Machine.h +++ b/ruamoko/scheme/Machine.h @@ -11,9 +11,8 @@ { state_t state; SchemeObject value; - Continuation cont; - Frame env; hashtab_t globals; + SchemeObject all_globals; } - (void) loadCode: (CompiledCode) code; - (SchemeObject) run; diff --git a/ruamoko/scheme/Machine.r b/ruamoko/scheme/Machine.r index c1e2b3d2d..b5e149222 100644 --- a/ruamoko/scheme/Machine.r +++ b/ruamoko/scheme/Machine.r @@ -1,8 +1,10 @@ #include "Machine.h" #include "Cons.h" #include "Lambda.h" +#include "Boolean.h" #include "Nil.h" #include "defs.h" +//#include "debug.h" string GlobalGetKey (void []ele, void []data) { @@ -22,19 +24,20 @@ void GlobalFree (void []ele, void []data) state.program = NIL; state.pc = 0; value = NIL; - cont = NIL; - env = NIL; + state.cont = NIL; + state.env = NIL; state.literals = NIL; state.stack = [Nil nil]; globals = Hash_NewTable(1024, GlobalGetKey, GlobalFree, NIL); + all_globals = [Nil nil]; return self; } - (void) addGlobal: (Symbol) sym value: (SchemeObject) val { local Cons c = cons(sym, val); - [c makeRootCell]; Hash_Add(globals, c); + all_globals = cons(c, all_globals); } - (void) loadCode: (CompiledCode) code @@ -46,12 +49,12 @@ void GlobalFree (void []ele, void []data) - (void) environment: (Frame) e { - env = e; + state.env = e; } - (void) continuation: (Continuation) c { - cont = c; + state.cont = c; } - (void) value: (SchemeObject) v @@ -59,9 +62,14 @@ void GlobalFree (void []ele, void []data) value = v; } +- (SchemeObject) value +{ + return value; +} + - (Continuation) continuation { - return cont; + return state.cont; } - (SchemeObject) stack @@ -85,6 +93,14 @@ void GlobalFree (void []ele, void []data) state.pc = st[0].pc; state.literals = st[0].literals; state.stack = st[0].stack; + state.cont = st[0].cont; + state.env = st[0].env; + state.proc = st[0].proc; +} + +- (void) procedure: (Procedure) pr +{ + state.proc = pr; } - (SchemeObject) run @@ -118,18 +134,17 @@ void GlobalFree (void []ele, void []data) case MAKECLOSURE: dprintf("Makeclosure\n"); value = [Lambda newWithCode: (CompiledCode) value - environment: env]; + environment: state.env]; break; case MAKECONT: dprintf("Makecont\n"); - cont = [Continuation newWithState: &state - environment: env - continuation: cont - pc: operand]; + state.cont = [Continuation newWithState: &state + pc: operand]; + state.stack = [Nil nil]; break; case LOADENV: dprintf("Loadenv\n"); - value = env; + value = state.env; break; case LOADLITS: dprintf("Loadlits\n"); @@ -137,7 +152,7 @@ void GlobalFree (void []ele, void []data) break; case MAKEENV: dprintf("Makeenv\n"); - env = [Frame newWithSize: operand link: env]; + state.env = [Frame newWithSize: operand link: state.env]; break; case GET: value = [value get: operand]; @@ -145,29 +160,55 @@ void GlobalFree (void []ele, void []data) break; case SET: [value set: operand to: [state.stack car]]; - dprintf("Set: %i --> %s\n", operand, [value printForm]); + dprintf("Set: %i --> %s\n", operand, [[state.stack car] printForm]); state.stack = [state.stack cdr]; break; + case SETREST: + [value set: operand to: state.stack]; + dprintf("Setrest: %i --> %s\n", operand, [state.stack printForm]); + state.stack = [Nil nil]; + break; + case SETSTACK: + dprintf("Setstack: %s\n", [value printForm]); + state.stack = value; + break; case GETLINK: - dprintf("Getlink"); + dprintf("Getlink\n"); value = [value getLink]; break; case GETGLOBAL: dprintf("Getglobal: %s\n", [value printForm]); value = [((Cons) Hash_Find(globals, [value printForm])) cdr]; + dprintf(" --> %s\n", [value printForm]); + break; + case SETGLOBAL: + dprintf("Setglobal: %s\n", [value printForm]); + [self addGlobal: (Symbol) value value: [state.stack car]]; + state.stack = [state.stack cdr]; break; case CALL: dprintf("Call\n"); + [SchemeObject collectCheckPoint]; [value invokeOnMachine: self]; break; case RETURN: dprintf("Return: %s\n", [value printForm]); - if (!cont) { + if (!state.cont) { return value; } else { - [cont invokeOnMachine: self]; + [state.cont invokeOnMachine: self]; } break; + case IFFALSE: + dprintf("Iffalse: %s\n", [value printForm]); + if (value == [Boolean falseConstant]) { + state.pc = operand; + } + break; + case GOTO: + dprintf("Goto: %i\n", operand); + state.pc = operand; + break; } } } @@ -176,9 +217,11 @@ void GlobalFree (void []ele, void []data) { [state.literals mark]; [state.stack mark]; - [cont mark]; - [env mark]; + [state.cont mark]; + [state.env mark]; + [state.proc mark]; [value mark]; - // FIXME: need to mark globals + [all_globals mark]; } @end + diff --git a/ruamoko/scheme/Makefile.am b/ruamoko/scheme/Makefile.am index d8b73cc68..16dbf4d0f 100644 --- a/ruamoko/scheme/Makefile.am +++ b/ruamoko/scheme/Makefile.am @@ -45,7 +45,7 @@ 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 \ - Error.r + Error.r Boolean.r libscheme_a_AR=$(PAK) -cf scheme_data=\ diff --git a/ruamoko/scheme/Parser.h b/ruamoko/scheme/Parser.h index 4156dbe23..29ad205f9 100644 --- a/ruamoko/scheme/Parser.h +++ b/ruamoko/scheme/Parser.h @@ -2,7 +2,7 @@ #define __Parser_h #include "Lexer.h" -@interface Parser: Object +@interface Parser: SchemeObject { Lexer lexer; string file; diff --git a/ruamoko/scheme/Parser.r b/ruamoko/scheme/Parser.r index 6f3231a57..861e15c7c 100644 --- a/ruamoko/scheme/Parser.r +++ b/ruamoko/scheme/Parser.r @@ -40,6 +40,16 @@ if (token == [Symbol rightParen]) { return [Nil nil]; + } else if (token == [Symbol dot]) { + res = [self readAtomic]; + if ([res isError]) return res; + if ([self readAtomic] != [Symbol rightParen]) { + err = [Error type: "parse" message: "Improper use of dot"]; + [err source: file]; + [err line: [lexer lineNumber]]; + return err; + } + return res; } else { res = [self readList]; if ([res isError]) return res; @@ -56,7 +66,7 @@ local integer line; line = [lexer lineNumber]; - + token = [lexer nextToken]; if ([token isError]) { diff --git a/ruamoko/scheme/Primitive.r b/ruamoko/scheme/Primitive.r index a55450ac2..a8f74d238 100644 --- a/ruamoko/scheme/Primitive.r +++ b/ruamoko/scheme/Primitive.r @@ -15,8 +15,11 @@ - (SchemeObject) invokeOnMachine: (Machine) m { local SchemeObject value = func ([m stack], m); - [m value: value]; - [[m continuation] invokeOnMachine: m]; + [super invokeOnMachine: m]; + if (value) { + [m value: value]; + [[m continuation] invokeOnMachine: m]; + } } - (string) printForm diff --git a/ruamoko/scheme/Procedure.r b/ruamoko/scheme/Procedure.r index e05ce3ae0..aafef4487 100644 --- a/ruamoko/scheme/Procedure.r +++ b/ruamoko/scheme/Procedure.r @@ -3,6 +3,7 @@ @implementation Procedure - (void) invokeOnMachine: (Machine) m { + [m procedure: self]; return; } diff --git a/ruamoko/scheme/SchemeObject.h b/ruamoko/scheme/SchemeObject.h index d700d262c..a178fcfdc 100644 --- a/ruamoko/scheme/SchemeObject.h +++ b/ruamoko/scheme/SchemeObject.h @@ -3,13 +3,8 @@ #include "Object.h" #define true YES #define false NO - -//#define DEBUG -#ifdef DEBUG -#define dprintf printf -#else #define dprintf(x, ...) -#endif + @interface SchemeObject: Object diff --git a/ruamoko/scheme/SchemeObject.r b/ruamoko/scheme/SchemeObject.r index ec6a7660b..630c29ff8 100644 --- a/ruamoko/scheme/SchemeObject.r +++ b/ruamoko/scheme/SchemeObject.r @@ -1,9 +1,20 @@ #include "SchemeObject.h" #include "defs.h" +//#include "debug.h" -SchemeObject maybe_garbage, not_garbage, roots; +SchemeObject maybe_garbage, not_garbage, not_garbage_end, wait_list, roots, queue_pos; BOOL markstate; +typedef enum { + GC_IDLE = 0, + GC_MARK = 1, + GC_SWEEP = 2 +} gc_state_e; + +gc_state_e gc_state; +integer checkpoint; + + BOOL contains (SchemeObject list, SchemeObject what) { local SchemeObject cur; @@ -22,8 +33,10 @@ BOOL contains (SchemeObject list, SchemeObject what) + (void) initialize { - maybe_garbage = not_garbage = roots = NIL; + maybe_garbage = not_garbage = not_garbage_end = wait_list = roots = NIL; markstate = true; + gc_state = GC_IDLE; + checkpoint = 0; } + (id) dummyObject @@ -40,40 +53,99 @@ BOOL contains (SchemeObject list, SchemeObject what) return self; } ++ (void) collectCheckPoint +{ + if (++checkpoint == 50) + { + [self collect]; + checkpoint = 0; + } +} + + (void) collect { - local SchemeObject cur, next = NIL, dummy; + local SchemeObject cur; + local integer amount; - not_garbage = dummy = [SchemeObject dummyObject]; - for (cur = roots; cur; cur = next) { - next = cur.next; - [cur markReachable]; + switch (gc_state) { + case GC_IDLE: + dprintf("GC: Starting collection...\n"); + gc_state = GC_MARK; + not_garbage = not_garbage_end = [SchemeObject dummyObject]; + for (cur = roots; cur; cur = cur.next) { + [cur markReachable]; + } + queue_pos = not_garbage_end; + return; + case GC_MARK: + dprintf("GC: Marking...\n"); + amount = 0; + while (queue_pos) { + dprintf("GC: marking queue: %s[%s]@%i\n", + [queue_pos description], + [queue_pos printForm], + (integer) queue_pos); + [queue_pos markReachable]; + queue_pos = queue_pos.prev; + if (++amount == 50) return; + } + gc_state = GC_SWEEP; + queue_pos = maybe_garbage; + return; + case GC_SWEEP: + dprintf("GC: Sweeping...\n"); + amount = 0; + while (queue_pos) { + dprintf("GC: freeing %s[%s]@%i...\n", + [queue_pos description], + [queue_pos printForm], + (integer) queue_pos); + [queue_pos release]; + queue_pos = queue_pos.next; + if (++amount == 100) return; + } + maybe_garbage = not_garbage; + not_garbage_end.next = wait_list; + if (wait_list) { + wait_list.prev = not_garbage_end; + } + wait_list = NIL; + not_garbage_end = NIL; + not_garbage = NIL; + markstate = !markstate; + gc_state = GC_IDLE; } - for (cur = dummy; cur; cur = cur.prev) { - dprintf("GC: marking queue: %s[%s]@%i\n", [cur description], [cur printForm], - (integer) cur); - [cur markReachable]; +} + ++ (void) finishCollecting +{ + while (gc_state) { + [self collect]; } - for (cur = maybe_garbage; cur; cur = next) { - next = cur.next; - dprintf("GC: freeing %s[%s]@%i...\n", [cur description], [cur printForm], (integer) cur); - [cur release]; - } - maybe_garbage = not_garbage; - not_garbage = NIL; - markstate = !markstate; } - (id) init { self = [super init]; - if (maybe_garbage) { - maybe_garbage.prev = self; + if (gc_state) { + if (wait_list) { + wait_list.prev = self; + } + next = wait_list; + wait_list = self; + marked = markstate; + dprintf("GC: During collect: %i\n", (integer) self); + } else { + if (maybe_garbage) { + maybe_garbage.prev = self; + } + next = maybe_garbage; + maybe_garbage = self; + marked = !markstate; + dprintf("GC: Not during collect: %i\n", (integer) self); } - next = maybe_garbage; - maybe_garbage = self; + prev = NIL; - marked = !markstate; root = false; return self; } @@ -98,11 +170,19 @@ BOOL contains (SchemeObject list, SchemeObject what) prev = NIL; not_garbage = self; //[self markReachable]; + if (contains (maybe_garbage, self)) { + dprintf("Shit shit shit!\n"); + } } } - (void) makeRootCell { + if (gc_state) { + dprintf("Root cell made during collection!\n"); + [SchemeObject finishCollecting]; + } + if (prev) { prev.next = next; } else { diff --git a/ruamoko/scheme/Scope.r b/ruamoko/scheme/Scope.r index 1175751a9..28380bc1e 100644 --- a/ruamoko/scheme/Scope.r +++ b/ruamoko/scheme/Scope.r @@ -71,7 +71,11 @@ - (void) dealloc { - [names release]; + if (names) { + [names release]; + } + names = NIL; + [super dealloc]; } - (void) markReachable diff --git a/ruamoko/scheme/Symbol.h b/ruamoko/scheme/Symbol.h index 1aebb4b30..d3523ccf1 100644 --- a/ruamoko/scheme/Symbol.h +++ b/ruamoko/scheme/Symbol.h @@ -8,7 +8,10 @@ + (void) initialize; + (Symbol) leftParen; + (Symbol) rightParen; ++ (Symbol) dot; + (Symbol) forString: (string) s; @end +@extern Symbol symbol (string str); + #endif //__Symbol_h diff --git a/ruamoko/scheme/Symbol.r b/ruamoko/scheme/Symbol.r index c7182a957..639e4fa19 100644 --- a/ruamoko/scheme/Symbol.r +++ b/ruamoko/scheme/Symbol.r @@ -20,6 +20,12 @@ hashtab_t symbols; Symbol lparen; Symbol rparen; Symbol quote; +Symbol dot; + +Symbol symbol (string str) +{ + return [Symbol forString: str]; +} @implementation Symbol + (void) initialize @@ -28,9 +34,11 @@ Symbol quote; lparen = [Symbol forString: "("]; rparen = [Symbol forString: ")"]; quote = [Symbol forString: "'"]; + dot = symbol("."); [lparen makeRootCell]; [rparen makeRootCell]; [quote makeRootCell]; + [dot makeRootCell]; } + (Symbol) forString: (string) s @@ -61,6 +69,11 @@ Symbol quote; return quote; } ++ (Symbol) dot +{ + return dot; +} + - (string) printForm { return value; diff --git a/ruamoko/scheme/builtins.h b/ruamoko/scheme/builtins.h index 3f3766237..e553b2f35 100644 --- a/ruamoko/scheme/builtins.h +++ b/ruamoko/scheme/builtins.h @@ -1,8 +1,3 @@ #include "Primitive.h" -@extern Primitive print_p; -@extern Primitive newline_p; -@extern Primitive add_p; -@extern Primitive map_p; -@extern Primitive for_each_p; -@extern void builtin_init (void); +@extern void builtin_addtomachine (Machine m); diff --git a/ruamoko/scheme/builtins.r b/ruamoko/scheme/builtins.r index 98846f73f..3b50a49f6 100644 --- a/ruamoko/scheme/builtins.r +++ b/ruamoko/scheme/builtins.r @@ -6,14 +6,9 @@ #include "string.h" #include "Cons.h" #include "Continuation.h" +#include "Boolean.h" -Primitive print_p; -Primitive newline_p; -Primitive add_p; -Primitive map_p; -Primitive for_each_p; - -SchemeObject bi_print (SchemeObject args, Machine m) +SchemeObject bi_display (SchemeObject args, Machine m) { print([[args car] printForm]); return [Void voidConstant]; @@ -37,58 +32,53 @@ SchemeObject bi_add (SchemeObject args, Machine m) return [Number newFromInt: sum]; } -SchemeObject bi_map (SchemeObject args, Machine m) +SchemeObject bi_cons (SchemeObject args, Machine m) { - local SchemeObject func = [args car]; - local SchemeObject list = [[args cdr] car]; - local SchemeObject output, cur, last, temp; - local Continuation oldcont; - - if (list == [Nil nil]) { - return list; - } else { - oldcont = [m continuation]; - [m stack: cons([list car], [Nil nil])]; - [m continuation: NIL]; - [func invokeOnMachine: m]; - output = last = cons([m run], [Nil nil]); - for (cur = [list cdr]; cur != [Nil nil]; cur = [cur cdr]) { - [m stack: cons([cur car], [Nil nil])]; - [func invokeOnMachine: m]; - temp = cons([m run], [Nil nil]); - [last cdr: temp]; - last = temp; - } - [m continuation: oldcont]; - return output; - } -} - -SchemeObject bi_for_each (SchemeObject args, Machine m) -{ - local SchemeObject func = [args car]; - local SchemeObject list = [[args cdr] car]; - local SchemeObject cur; - local Continuation oldcont; - - if (list != [Nil nil]) { - oldcont = [m continuation]; - [m continuation: NIL]; - for (cur = list; cur != [Nil nil]; cur = [cur cdr]) { - [m stack: cons([cur car], [Nil nil])]; - [func invokeOnMachine: m]; - [m run]; - } - [m continuation: oldcont]; - } - return [Void voidConstant]; + [args cdr: [[args cdr] car]]; + return args; } -void builtin_init (void) +SchemeObject bi_null (SchemeObject args, Machine m) { - print_p = [Primitive newFromFunc: bi_print]; - newline_p = [Primitive newFromFunc: bi_newline]; - add_p = [Primitive newFromFunc: bi_add]; - map_p = [Primitive newFromFunc: bi_map]; - for_each_p = [Primitive newFromFunc: bi_for_each]; + return [args car] == [Nil nil] + ? + [Boolean trueConstant] : + [Boolean falseConstant]; +} + +SchemeObject bi_car (SchemeObject args, Machine m) +{ + return [[args car] car]; +} + +SchemeObject bi_cdr (SchemeObject args, Machine m) +{ + return [[args car] cdr]; +} + +SchemeObject bi_apply (SchemeObject args, Machine m) +{ + [m stack: [[args cdr] car]]; + [[args car] invokeOnMachine: m]; + return NIL; +} + +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]]; } diff --git a/ruamoko/scheme/debug.h b/ruamoko/scheme/debug.h new file mode 100644 index 000000000..e8757c87a --- /dev/null +++ b/ruamoko/scheme/debug.h @@ -0,0 +1,4 @@ +#ifdef dprintf +#undef dprintf +#endif +#define dprintf printf diff --git a/ruamoko/scheme/defs.h b/ruamoko/scheme/defs.h index 9ab6632ef..43f038906 100644 --- a/ruamoko/scheme/defs.h +++ b/ruamoko/scheme/defs.h @@ -7,7 +7,7 @@ @extern integer (integer handle, string buffer, integer count) write = #0; @extern integer (integer handle, integer pos, integer whence) seek = #0; -//@extern void() traceon = #0; // turns statment trace on -//@extern void() traceoff = #0; +@extern void() traceon = #0; // turns statment trace on +@extern void() traceoff = #0; @extern void (...) printf = #0; diff --git a/ruamoko/scheme/defs.qc b/ruamoko/scheme/defs.qc index 664e40288..cd1082a10 100644 --- a/ruamoko/scheme/defs.qc +++ b/ruamoko/scheme/defs.qc @@ -7,8 +7,8 @@ string (integer handle, integer count, integer []result) read = #0; integer (integer handle, string buffer, integer count) write = #0; integer (integer handle, integer pos, integer whence) seek = #0; -//void() traceon = #0; // turns statment trace on -//void() traceoff = #0; +void() traceon = #0; // turns statment trace on +void() traceoff = #0; void (...) printf = #0; diff --git a/ruamoko/scheme/main.qc b/ruamoko/scheme/main.qc index 4dab1cadc..9ab5a6160 100644 --- a/ruamoko/scheme/main.qc +++ b/ruamoko/scheme/main.qc @@ -36,16 +36,14 @@ integer main (integer argc, string []argv) if (argc < 1) { return -1; } + + //traceon(); - builtin_init(); parser = [Parser newFromSource: readfile(argv[1]) file: argv[1]]; vm = [Machine new]; [vm makeRootCell]; - [vm addGlobal: [Symbol forString: "display"] value: print_p]; - [vm addGlobal: [Symbol forString: "newline"] value: newline_p]; - [vm addGlobal: [Symbol forString: "+"] value: add_p]; - [vm addGlobal: [Symbol forString: "map"] value: map_p]; - [vm addGlobal: [Symbol forString: "for-each"] value: for_each_p]; + [parser makeRootCell]; + builtin_addtomachine (vm); while ((stuff = [parser read])) { if ([stuff isError]) { printf(">> %s: %i\n", [stuff source], [stuff line]); @@ -65,7 +63,7 @@ integer main (integer argc, string []argv) lm = [Lambda newWithCode: code environment: NIL]; [lm invokeOnMachine: vm]; [vm run]; - [SchemeObject collect]; } + [SchemeObject finishCollecting]; return 0; } diff --git a/ruamoko/scheme/state.h b/ruamoko/scheme/state.h index 113f37dca..53c3a291a 100644 --- a/ruamoko/scheme/state.h +++ b/ruamoko/scheme/state.h @@ -4,11 +4,15 @@ #include "Instruction.h" #include "Frame.h" +@class Continuation; + struct state_s = { instruction_t [] program; integer pc; - Frame literals; + Frame literals, env; SchemeObject stack; + Continuation cont; + Procedure proc; }; typedef struct state_s state_t;