Bug fixes, plus a first stab at the garbage collector. It *seems* to work

properly so far.

ruamoko/scheme/CompiledCode.r

@@ -9,7 +9,14 @@
     instructions = [Array new];
     return self;
 }
-    
+
+- (void) markReachable
+{
+    [literals mark];
+    [constants makeObjectsPerformSelector: @selector(mark)];
+    [instructions makeObjectsPerformSelector: @selector(mark)];
+}
+
 - (void) addInstruction: (Instruction) inst
 {
     [inst offset: [instructions count]];
@@ -38,10 +45,9 @@
             inst = [instructions getItemAt: index];
             [inst emitStruct: code];
     }
-    [instructions makeObjectsPerformSelector: @selector(retain)];
     [instructions release];
-    [constants makeObjectsPerformSelector: @selector(retain)];
     [constants release];
+    instructions = constants = NIL;
 }
 
 - (instruction_t []) code
@@ -54,4 +60,12 @@
     return literals;
 }
 
+- (void) dealloc
+{
+    [instructions release];
+    [constants release];
+    if (code)
+            obj_free (code);
+}
+
 @end

ruamoko/scheme/Compiler.r

@@ -15,8 +15,8 @@
     self = [super init];
     sexpr = xp;
     scope = sc;
-    lambdaSym = [Symbol newFromString: "lambda"];
-    quoteSym = [Symbol newFromString: "quote"];
+    lambdaSym = [Symbol forString: "lambda"];
+    quoteSym = [Symbol forString: "quote"];
     code = [CompiledCode new];
     return self;
 }
@@ -140,5 +140,14 @@
 {
     return code;
 }
-            
+
+- (void) markReachable
+{
+    [code mark];
+    [sexpr mark];
+    [lambdaSym mark];
+    [quoteSym mark];
+    [Scope mark];
+}
+
 @end

ruamoko/scheme/Cons.r

@@ -49,9 +49,8 @@ Cons cons (SchemeObject car, SchemeObject cdr)
     cdr = d;
 }   
 
-- (void) mark
+- (void) markReachable
 {
-    [super mark];
     [car mark];
     [cdr mark];
 }

ruamoko/scheme/Continuation.r

@@ -26,6 +26,14 @@
     return;
 }
 
+- (void) markReachable
+{
+    [state.literals mark];
+    [state.stack mark];
+    [cont mark];
+    [env mark];
+}
+
 - (string) printForm
 {
     return "<continuation>";

ruamoko/scheme/Frame.r

@@ -30,4 +30,19 @@
     return link;
 }
 
+- (void) markReachable
+{
+    local integer index;
+    for (index = 0; index < size; index++) {
+            [array[index] mark];
+    }
+    [link mark];
+}
+
+- (void) dealloc
+{
+    obj_free(array);
+    [super dealloc];
+}
+
 @end

ruamoko/scheme/Instruction.r

@@ -51,4 +51,9 @@
     }
 }
 
+- (void) markReachable
+{
+    [label mark];
+}
+
 @end

ruamoko/scheme/Lambda.r

@@ -4,71 +4,6 @@
 #include "string.h"
 #include "defs.h"
 
-/*
-SchemeObject evaluate (SchemeObject expr, SchemeObject env);
-
-SchemeObject extend_environment (SchemeObject baseenv, SchemeObject argnames, SchemeObject argvalues)
-{
-    local SchemeObject name, value;
-
-    if (argnames == [Nil nil]) {
-            return baseenv;
-    }
-
-    name = [argnames car];
-    value = [argvalues car];
-    return [Cons newWithCar: [Cons newWithCar: name cdr: value] cdr:
-                     extend_environment([baseenv cdr], [argnames cdr], [argvalues cdr])];
-}
-
-SchemeObject assoc (Symbol name, SchemeObject list)
-{
-    if (list == [Nil nil]) {
-            return NIL;
-    }
-
-    printf("assoc: Comparing %s to %s\n",
-           [name printForm], [[[list car] car] printForm]);
-    
-    if ([[list car] car] == name) {
-            print("assoc: Comparison successful, returning" +
-                  [[[list car] cdr] printForm] + "\n");
-            return [[list car] cdr];
-    } else {
-            return assoc (name, [list cdr]);
-    }
-}
-
-SchemeObject evaluate_list (SchemeObject list, SchemeObject env)
-{
-    if (list == [Nil nil]) {
-            return list;
-    } else {
-            return [Cons newWithCar: evaluate([list car], env) cdr:
-                             evaluate_list ([list cdr], env)];
-    }
-}
-
-SchemeObject evaluate (SchemeObject expr, SchemeObject env)
-{
-    local SchemeObject res;
-
-    print ("Entering evaluated...\n");
-    
-    if ([expr isKindOfClass: [Cons class]]) {
-            res = evaluate_list (expr, env);
-            print("Got evaluated list: " + [res printForm] + "\n");
-            return [[res car] invokeWithArgs: [res cdr]];
-    } else if ([expr isKindOfClass: [Symbol class]]) {
-            print("Looking up symbol: " + [expr printForm] + "\n");
-            return assoc((Symbol) expr, env);
-    } else {
-            return expr;
-    }
-}
-
-*/
-
 @implementation Lambda
 + (id) newWithCode: (CompiledCode) c environment: (Frame) e
 {
@@ -88,5 +23,11 @@ SchemeObject evaluate (SchemeObject expr, SchemeObject env)
     [m loadCode: code];
     [m environment: env];
 }
-    
+
+- (void) markReachable
+{
+    [env mark];
+    [code mark];
+}
+
 @end

ruamoko/scheme/Lexer.h

@@ -6,8 +6,6 @@
 @interface Lexer: Object
 {
     string source;
-    Symbol lparen;
-    Symbol rparen;
 }
 + (id) newFromSource: (string) s;
 - (id) initWithSource: (string) s;

ruamoko/scheme/Lexer.r

@@ -29,8 +29,9 @@ BOOL issymbol (string x)
 
 - (id) initWithSource: (string) s
 {
+    self = [super init];
     source = s;
-    return [super init];
+    return self;
 }
 
 - (SchemeObject) nextToken
@@ -70,7 +71,7 @@ BOOL issymbol (string x)
             return NIL;
         default:
             for (len = 1; issymbol(str_mid(source, len, len+1)); len++);
-            sym = [Symbol newFromString: str_mid (source, 0, len)];
+            sym = [Symbol forString: str_mid (source, 0, len)];
             source = str_mid(source, len);
             return sym;
     }

ruamoko/scheme/Machine.r

@@ -4,14 +4,6 @@
 #include "Nil.h"
 #include "defs.h"
 
-
-//#define DEBUG
-#ifdef DEBUG
-#define dprintf printf
-#else
-#define dprintf(x, ...)
-#endif
-
 string GlobalGetKey (void []ele, void []data)
 {
     return [[((Cons) ele) car] printForm];
@@ -40,7 +32,9 @@ void GlobalFree (void []ele, void []data)
 
 - (void) addGlobal: (Symbol) sym value: (SchemeObject) val
 {
-    Hash_Add(globals, cons(sym, val));
+    local Cons c = cons(sym, val);
+    [c makeRootCell];
+    Hash_Add(globals, c);
 }
 
 - (void) loadCode: (CompiledCode) code
@@ -123,7 +117,8 @@ void GlobalFree (void []ele, void []data)
                     break;
                 case MAKECLOSURE:
                     dprintf("Makeclosure\n");
-                    value = [Lambda newWithCode: (CompiledCode) value environment: env];
+                    value = [Lambda newWithCode: (CompiledCode) value
+                                    environment: env];
                     break;
                 case MAKECONT:
                     dprintf("Makecont\n");
@@ -176,4 +171,14 @@ void GlobalFree (void []ele, void []data)
             }
     }
 }
+
+- (void) markReachable
+{
+    [state.literals mark];
+    [state.stack mark];
+    [cont mark];
+    [env mark];
+    [value mark];
+        // FIXME: need to mark globals
+}
 @end

ruamoko/scheme/Nil.r

@@ -8,6 +8,7 @@ Nil one_nil_to_rule_them_all;
 + (void) initialize
 {
     one_nil_to_rule_them_all = [Nil new];
+    [one_nil_to_rule_them_all makeRootCell];
 }
 
 + (id) nil

ruamoko/scheme/Parser.r

@@ -12,8 +12,9 @@
 
 - (id) initWithSource: (string) s
 {
+    self = [super init];
     lexer = [Lexer newFromSource: s];
-    return [super init];
+    return self;
 }
 
 - (SchemeObject) readList

ruamoko/scheme/SchemeObject.h

@@ -4,13 +4,22 @@
 #define true YES
 #define false NO
 
+//#define DEBUG
+#ifdef DEBUG
+#define dprintf printf
+#else
+#define dprintf(x, ...)
+#endif
+
+
 @interface SchemeObject: Object
 {
-	BOOL marked;
+    @public SchemeObject prev, next;
+    BOOL marked, root;
 }
 - (void) mark;
-- (BOOL) sweep;
-//+ (id) alloc;
+- (void) markReachable;
+- (void) makeRootCell;
 - (string) printForm;
 @end
 

ruamoko/scheme/SchemeObject.r

@@ -1,27 +1,128 @@
 #include "SchemeObject.h"
+#include "defs.h"
+
+SchemeObject maybe_garbage, not_garbage, roots;
+BOOL markstate;
+
+BOOL contains (SchemeObject list, SchemeObject what)
+{
+    local SchemeObject cur;
+
+    for (cur = list; cur; cur = cur.next) {
+            if (cur == what)
+                    return true;
+    }
+
+    return false;
+}
+
+
 
 @implementation SchemeObject
 
-/*
-+ (id) alloc
++ (void) initialize
 {
-    return [super alloc];
-}
-*/
-- (void) mark
-{
-    marked = true;
+    maybe_garbage = not_garbage = roots = NIL;
+    markstate = true;
 }
 
-- (BOOL) sweep
++ (id) dummyObject
 {
-    if (marked) {
-            marked = false;
-            return false;
-    } else {
-            [self release];
-            return true;
+    return [[SchemeObject alloc] initDummy];
+}
+
+- (id) initDummy
+{
+    self = [super init];
+    prev = next = NIL;
+    marked = markstate;
+    root = false;
+    return self;
+}
+
++ (void) collect
+{
+    local SchemeObject cur, next = NIL, dummy;
+
+    not_garbage = dummy = [SchemeObject dummyObject];
+    for (cur = roots; cur; cur = next) {
+            next = cur.next;
+            [cur markReachable];
     }
+    for (cur = dummy; cur; cur = cur.prev) {
+            dprintf("GC: marking queue: %s[%s]@%i\n", [cur description], [cur printForm],
+                    (integer) cur);
+            [cur markReachable];
+    }
+    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;
+    }
+    next = maybe_garbage;
+    maybe_garbage = self;
+    prev = NIL;
+    marked = !markstate;
+    root = false;
+    return self;
+}
+
+- (void) mark
+{
+    if (!root && marked != markstate) {
+            dprintf("GC: Marking %s[%s]@%i\n", [self description], [self printForm], (integer) self);
+            marked = markstate;
+            if (prev) {
+                    prev.next = next;
+            } else {
+                    maybe_garbage = next;
+                    }
+            if (next) {
+                    next.prev = prev;
+            }
+            if (not_garbage) {
+                    not_garbage.prev = self;
+            }
+            next = not_garbage;
+            prev = NIL;
+            not_garbage = self;
+                //[self markReachable];
+    }
+}
+
+- (void) makeRootCell
+{
+    if (prev) {
+            prev.next = next;
+    } else {
+            maybe_garbage = next;
+    }
+    if (next) {
+            next.prev = prev;
+    }
+    if (roots) {
+            roots.prev = self;
+    }
+    next = roots;
+    prev = NIL;
+    roots = self;
+    root = true;
+}
+
+- (void) markReachable
+{
+    return;
 }
 
 - (string) printForm
@@ -29,4 +130,10 @@
     return "<generic>";
 }
 
+- (void) dealloc
+{
+    dprintf("Deallocing %s @ %i!\n", [self description], (integer) self);
+    [super dealloc];
+}
+
 @end

ruamoko/scheme/Scope.r

@@ -74,4 +74,10 @@
     [names release];
 }
 
+- (void) markReachable
+{
+    [names makeObjectsPerformSelector: @selector(mark)];
+    [outerScope mark];
+}
+
 @end

ruamoko/scheme/Symbol.h

@@ -4,7 +4,6 @@
 
 @interface Symbol: String
 {
-    string value;
 }
 + (void) initialize;
 + (Symbol) leftParen;

ruamoko/scheme/Symbol.r

@@ -28,12 +28,22 @@ Symbol quote;
     lparen = [Symbol forString: "("];
     rparen = [Symbol forString: ")"];
     quote = [Symbol forString: "'"];
-    
+    [lparen makeRootCell];
+    [rparen makeRootCell];
+    [quote makeRootCell];
 }
 
 + (Symbol) forString: (string) s
 {
-    return (Symbol) [self newFromString: s];
+    local Symbol res;
+
+    if ((res = Hash_Find (symbols, s))) {
+            return res;
+    } else {
+            res = (Symbol) [self newFromString: s];
+            Hash_Add (symbols, res);
+            return res;
+    }
 }
 
 + (Symbol) leftParen
@@ -51,24 +61,17 @@ Symbol quote;
     return quote;
 }
 
-- (id) initWithString: (string) s
-{
-    local Symbol res;
-    [super initWithString: s];
-
-    if ((res = Hash_Find (symbols, s))) {
-            [self release];
-            return res;
-    } else {
-            Hash_Add (symbols, self);
-            return self;
-    }
-}
-
 - (string) printForm
 {
-    return [self stringValue];
+    return value;
 }
 
+- (void) dealloc
+{
+    if (Hash_Find (symbols, value) == self) {
+            Hash_Del (symbols, value);
+    }
+    [super dealloc];
+}
 
 @end

ruamoko/scheme/Void.r

@@ -7,6 +7,7 @@ Void voidConstant;
 + (void) initialize
 {
     voidConstant = [Void new];
+    [voidConstant makeRootCell];
 }
 
 + (id) voidConstant

ruamoko/scheme/main.qc

@@ -40,6 +40,7 @@ integer main (integer argc, string []argv)
     builtin_init();
     parser = [Parser newFromSource: readfile(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];
@@ -55,6 +56,7 @@ integer main (integer argc, string []argv)
             lm = [Lambda newWithCode: code environment: NIL];
             [lm invokeOnMachine: vm];
             [vm run];
+            [SchemeObject collect];
     }
     return 0;
 }