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

@@ -4,5 +4,6 @@
 *.src
 *.sym
 .vimrc
+*~
 Makefile.in
 Makefile

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

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

ruamoko/scheme/CompiledCode.r

@@ -13,8 +13,10 @@
 - (void) markReachable
 {
     [literals mark];
-    [constants makeObjectsPerformSelector: @selector(mark)];
+    if (constants)
-    [instructions makeObjectsPerformSelector: @selector(mark)];
+            [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];
+    local Array temp;
-    [constants release];
+    
-    if (code)
+    if (instructions) {
+            temp = instructions;
+            instructions = NIL;
+            [temp release];
+    }
+    if (constants) {
+            temp = constants;
+            constants = NIL;
+            [temp release];
+    }
+       
+    if (code) {
             obj_free (code);
+    }
+    [super dealloc];
 }
 
 @end

ruamoko/scheme/Compiler.h

@@ -10,7 +10,6 @@
 {
     CompiledCode code;
     SchemeObject sexpr;
-    Symbol lambdaSym, quoteSym;
     Scope scope;
     Error err;
 }

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]];
+            if ([cur isKindOfClass: [Cons class]]) {
-            [code addInstruction: [Instruction opcode: SET operand: index]];
+                    [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];
+    [scope mark];
-    [quoteSym mark];
-    [Scope mark];
 }
 
 @end

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) newWithState: (state_t []) st pc: (integer) p;
-- (id) initWithState: (state_t []) st environment: (Frame) e continuation: (Continuation) c pc: (integer) p;
+- (id) initWithState: (state_t []) st pc: (integer) p;
 
 @end
 

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;
+    state.cont = st.cont;
-    env = e;
+    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];
+    [state.cont mark];
-    [env mark];
+    [state.env mark];
+    [state.proc mark];
 }
 
 - (string) printForm

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 {

ruamoko/scheme/Lambda.r

@@ -20,6 +20,7 @@
 
 - (void) invokeOnMachine: (Machine) m
 {
+    [super invokeOnMachine: m];
     [m loadCode: code];
     [m environment: env];
 }

ruamoko/scheme/Lexer.h

@@ -3,7 +3,7 @@
 #include "SchemeObject.h"
 #include "Symbol.h"
 
-@interface Lexer: Object
+@interface Lexer: SchemeObject
 {
     string source;
     string filename;

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;
     }
 }

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;

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;
+    state.cont = NIL;
-    env = 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
+                    state.cont = [Continuation newWithState: &state
-                                         environment: env
+                                               pc: operand];
-                                         continuation: cont
+                    state.stack = [Nil nil];
-                                         pc: operand];
                     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];
+    [state.cont mark];
-    [env mark];
+    [state.env mark];
+    [state.proc mark];
     [value mark];
-        // FIXME: need to mark globals
+    [all_globals mark];
 }
 @end
+

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=\

ruamoko/scheme/Parser.h

@@ -2,7 +2,7 @@
 #define __Parser_h
 #include "Lexer.h"
 
-@interface Parser: Object
+@interface Parser: SchemeObject
 {
     Lexer lexer;
     string file;

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]) {

ruamoko/scheme/Primitive.r

@@ -15,8 +15,11 @@
 - (SchemeObject) invokeOnMachine: (Machine) m
 {
     local SchemeObject value = func ([m stack], m);
-    [m value: value];
+    [super invokeOnMachine: m];
-    [[m continuation] invokeOnMachine: m];
+    if (value) {
+            [m value: value];
+            [[m continuation] invokeOnMachine: m];
+    }
 }
 
 - (string) printForm

ruamoko/scheme/Procedure.r

@@ -3,6 +3,7 @@
 @implementation Procedure
 - (void) invokeOnMachine: (Machine) m
 {
+    [m procedure: self];
     return;
 }
 

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

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];
+    switch (gc_state) {
-    for (cur = roots; cur; cur = next) {
+        case GC_IDLE:
-            next = cur.next;
+            dprintf("GC: Starting collection...\n");
-            [cur markReachable];
+            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);
++ (void) finishCollecting
-            [cur markReachable];
+{
+    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) {
+    if (gc_state) {
-            maybe_garbage.prev = self;
+            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 {

ruamoko/scheme/Scope.r

@@ -71,7 +71,11 @@
 
 - (void) dealloc
 {
-    [names release];
+    if (names) {
+            [names release];
+    }
+    names = NIL;
+    [super dealloc];
 }
 
 - (void) markReachable

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

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;

ruamoko/scheme/builtins.h

@@ -1,8 +1,3 @@
 #include "Primitive.h"
 
-@extern Primitive print_p;
+@extern void builtin_addtomachine (Machine m);
-@extern Primitive newline_p;
-@extern Primitive add_p;
-@extern Primitive map_p;
-@extern Primitive for_each_p;
-@extern void builtin_init (void);

ruamoko/scheme/builtins.r

@@ -6,14 +6,9 @@
 #include "string.h"
 #include "Cons.h"
 #include "Continuation.h"
+#include "Boolean.h"
 
-Primitive print_p;
+SchemeObject bi_display (SchemeObject args, Machine m)
-Primitive newline_p;
-Primitive add_p;
-Primitive map_p;
-Primitive for_each_p;
-
-SchemeObject bi_print (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];
+    [args cdr: [[args cdr] car]];
-    local SchemeObject list = [[args cdr] car];
+    return args;
-    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];
 }
 
-void builtin_init (void)
+SchemeObject bi_null (SchemeObject args, Machine m)
 {
-    print_p = [Primitive newFromFunc: bi_print];
+    return [args car] == [Nil nil]
-    newline_p = [Primitive newFromFunc: bi_newline];
+        ?
-    add_p = [Primitive newFromFunc: bi_add];
+        [Boolean trueConstant] :
-    map_p = [Primitive newFromFunc: bi_map];
+        [Boolean falseConstant];
-    for_each_p = [Primitive newFromFunc: bi_for_each];
+}
+
+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]];
 }

ruamoko/scheme/debug.h

@@ -0,0 +1,4 @@
+#ifdef dprintf
+#undef dprintf
+#endif
+#define dprintf printf

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() traceon = #0;          // turns statment trace on
-//@extern void() traceoff = #0;
+@extern void() traceoff = #0;
 
 @extern void (...) printf = #0;

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() traceon = #0;          // turns statment trace on
-//void() traceoff = #0;
+void() traceoff = #0;
 
 void (...) printf = #0;
 

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];
+    [parser makeRootCell];
-    [vm addGlobal: [Symbol forString: "newline"] value: newline_p];
+    builtin_addtomachine (vm);
-    [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];
     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;
 }

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;