Scheme: Added letrec, first-class continuations, and tuned the garbage

collector a bit.

ruamoko/scheme/BaseContinuation.h

@@ -0,0 +1,11 @@
+#ifndef __BaseContinuation_h
+#define __BaseContinuation_h
+#include "SchemeObject.h"
+#include "Procedure.h"
+#include "Machine.h"
+
+@interface BaseContinuation: Procedure
++ (id) baseContinuation;
+@end
+
+#endif //__BaseContinuation_h

ruamoko/scheme/BaseContinuation.r

@@ -0,0 +1,28 @@
+#include "BaseContinuation.h"
+
+instruction_t returninst;
+BaseContinuation base;
+
+@implementation BaseContinuation
++ (void) initialize
+{
+    returninst.opcode = RETURN;
+    base = [BaseContinuation new];
+}
++ (id) baseContinuation
+{
+    return base;
+}
+
+- (void) restoreOnMachine: (Machine) m
+{
+    [m state].program = &returninst;
+}
+
+- (void) invokeOnMachine: (Machine) m
+{
+    [m value: [[m stack] car]];
+    [m state].program = &returninst;
+}
+
+@end

ruamoko/scheme/Compiler.h

@@ -6,6 +6,8 @@
 #include "Scope.h"
 #include "Error.h"
 
+#define TAIL 1
+
 @interface Compiler: SchemeObject
 {
     CompiledCode code;

ruamoko/scheme/Compiler.r

@@ -10,6 +10,7 @@ Symbol lambdaSym;
 Symbol quoteSym;
 Symbol defineSym;
 Symbol ifSym;
+Symbol letrecSym;
 
 @implementation Compiler
 + (void) initialize
@@ -22,6 +23,8 @@ Symbol ifSym;
     [defineSym makeRootCell];
     ifSym = [Symbol forString: "if"];
     [ifSym makeRootCell];
+    letrecSym = symbol("letrec");
+    [letrecSym makeRootCell];
 }
 
 + (id) newWithLambda: (SchemeObject) xp scope: (Scope) sc
@@ -74,12 +77,16 @@ Symbol ifSym;
     }       
 }
 
-- (void) emitSequence: (SchemeObject) expressions
+- (void) emitSequence: (SchemeObject) expressions flags: (integer) fl
 {
     local SchemeObject cur;
 
     for (cur = expressions; cur != [Nil nil]; cur = [cur cdr]) {
-            [self emitExpression: [cur car]];
+            if ([cur cdr] == [Nil nil] && (fl & TAIL)) {
+                    [self emitExpression: [cur car] flags: fl];
+            } else {
+                    [self emitExpression: [cur car] flags: fl & ~TAIL];
+            }
             if (err) return;
     }
 }
@@ -137,7 +144,7 @@ Symbol ifSym;
     [code addInstruction: [Instruction opcode: SETGLOBAL]];
 }
 
-- (void) emitIf: (SchemeObject) expression
+- (void) emitIf: (SchemeObject) expression flags: (integer) fl
 {
     local Instruction falseLabel, endLabel;
     local integer index;
@@ -151,10 +158,10 @@ Symbol ifSym;
     falseLabel = [Instruction opcode: LABEL];
     endLabel = [Instruction opcode: LABEL];
 
-    [self emitExpression: [expression car]];
+    [self emitExpression: [expression car] flags: fl & ~TAIL];
     if (err) return;
     [code addInstruction: [Instruction opcode: IFFALSE label: falseLabel]];
-    [self emitExpression: [[expression cdr] car]];
+    [self emitExpression: [[expression cdr] car] flags: fl];
     if (err) return;
     [code addInstruction: [Instruction opcode: GOTO label: endLabel]];
     [code addInstruction: falseLabel];
@@ -163,7 +170,7 @@ Symbol ifSym;
             [code addInstruction: [Instruction opcode: LOADLITS]];
             [code addInstruction: [Instruction opcode: GET operand: index]];
     } else {
-            [self emitExpression: [[[expression cdr] cdr] car]];
+            [self emitExpression: [[[expression cdr] cdr] car] flags: fl];
             if (err) return;
     }
     [code addInstruction: endLabel];
@@ -173,7 +180,38 @@ Symbol ifSym;
 
     
 
-- (void) emitExpression: (SchemeObject) expression
+- (void) emitLetrec: (SchemeObject) expression flags: (integer) fl
+{
+    local SchemeObject bindings;
+    local integer count;
+
+    scope = [Scope newWithOuter: scope];
+    
+    count = 0;
+    
+    for (bindings = [expression car]; bindings != [Nil nil]; bindings = [bindings cdr]) {
+            [scope addName: (Symbol) [[bindings car] car]];
+            count++;
+    }
+
+    [code addInstruction: [Instruction opcode: MAKEENV operand: count]];
+
+    count = 0;
+    
+    for (bindings = [expression car]; bindings != [Nil nil]; bindings = [bindings cdr]) {
+            [self emitSequence: [[bindings car] cdr] flags: fl & ~TAIL];
+            [code addInstruction: [Instruction opcode: PUSH]];
+            [code addInstruction: [Instruction opcode: LOADENV]];
+            [code addInstruction: [Instruction opcode: SET operand: count]];
+            count++;
+    }
+
+    [self emitSequence: [expression cdr] flags: fl];
+    [code addInstruction: [Instruction opcode: POPENV]];
+    scope = [scope outer];
+}
+
+- (void) emitExpression: (SchemeObject) expression flags: (integer) fl
 {
     if ([expression isKindOfClass: [Cons class]]) {
             if ([expression car] == lambdaSym) {
@@ -183,9 +221,11 @@ Symbol ifSym;
             } else if ([expression car] == defineSym) {
                     [self emitDefine: [expression cdr]];
             } else if ([expression car] == ifSym) {
-                    [self emitIf: [expression cdr]];
+                    [self emitIf: [expression cdr] flags: fl];
+            } else if ([expression car] == letrecSym) {
+                    [self emitLetrec: [expression cdr] flags: fl];
             } else {
-                    [self emitApply: expression];
+                    [self emitApply: expression flags: fl];
             }
     } else if ([expression isKindOfClass: [Symbol class]]) {
             [self emitVariable: (Symbol) expression];
@@ -201,19 +241,21 @@ Symbol ifSym;
     } else {
             [self emitArguments: [expression cdr]];
             if (err) return;
-            [self emitExpression: [expression car]];
+            [self emitExpression: [expression car] flags: 0];
             if (err) return;
             [code addInstruction: [Instruction opcode: PUSH]];
     }
 }
 
-- (void) emitApply: (SchemeObject) expression
+- (void) emitApply: (SchemeObject) expression flags: (integer) fl
 {
     local Instruction label = [Instruction opcode: LABEL];
-    [code addInstruction: [Instruction opcode: MAKECONT label: label]];
+    if (!(fl & TAIL)) {
+            [code addInstruction: [Instruction opcode: MAKECONT label: label]];
+    }
     [self emitArguments: [expression cdr]];
     if (err) return;
-    [self emitExpression: [expression car]];
+    [self emitExpression: [expression car] flags: fl & ~TAIL];
     if (err) return;
     [code addInstruction: [Instruction opcode: CALL]];
     [code addInstruction: label];
@@ -267,7 +309,7 @@ Symbol ifSym;
     if (err) {
             return err;
     }
-    [self emitSequence: [[sexpr cdr] cdr]];
+    [self emitSequence: [[sexpr cdr] cdr] flags: TAIL];
     if (err) {
             return err;
     }

ruamoko/scheme/Continuation.r

@@ -18,8 +18,15 @@
     return self;
 }
 
+- (void) restoreOnMachine: (Machine) m
+{
+    [m state: &state];
+    return;
+}
+
 - (void) invokeOnMachine: (Machine) m
 {
+    [m value: [[m stack] car]];
     [m state: &state];
     return;
 }

ruamoko/scheme/Instruction.h

@@ -11,6 +11,7 @@ typedef enum {
     LOADENV,
     LOADLITS,
     MAKEENV,
+    POPENV,
     GET,
     SET,
     SETREST,

ruamoko/scheme/Machine.r

@@ -4,7 +4,6 @@
 #include "Boolean.h"
 #include "Nil.h"
 #include "defs.h"
-//#include "debug.h"
 
 string GlobalGetKey (void []ele, void []data)
 {
@@ -154,6 +153,9 @@ void GlobalFree (void []ele, void []data)
                     dprintf("Makeenv\n");
                     state.env = [Frame newWithSize: operand link: state.env];
                     break;
+                case POPENV:
+                    dprintf("Popenv\n");
+                    state.env = [state.env getLink];
                 case GET:
                     value = [value get: operand];
                     dprintf("Get: %i --> %s\n", operand, [value printForm]);
@@ -196,7 +198,7 @@ void GlobalFree (void []ele, void []data)
                     if (!state.cont) {
                             return value;
                     } else {
-                            [state.cont invokeOnMachine: self];
+                            [state.cont restoreOnMachine: self];
                     }
                     break;
                 case IFFALSE:

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 Boolean.r
+	Error.r Boolean.r BaseContinuation.r
 libscheme_a_AR=$(PAK) -cf
 
 scheme_data=\

ruamoko/scheme/Primitive.r

@@ -18,7 +18,7 @@
     [super invokeOnMachine: m];
     if (value) {
             [m value: value];
-            [[m continuation] invokeOnMachine: m];
+            [[m continuation] restoreOnMachine: m];
     }
 }
 

ruamoko/scheme/SchemeObject.r

@@ -14,20 +14,7 @@ typedef enum {
 gc_state_e gc_state;
 integer checkpoint;
 
-
-BOOL contains (SchemeObject list, SchemeObject what)
-{
-    local SchemeObject cur;
-
-    for (cur = list; cur; cur = cur.next) {
-            if (cur == what)
-                    return true;
-    }
-
-    return false;
-}
-
-
+#define GC_AMOUNT 200
 
 @implementation SchemeObject
 
@@ -55,7 +42,7 @@ BOOL contains (SchemeObject list, SchemeObject what)
 
 + (void) collectCheckPoint
 {
-    if (++checkpoint == 50)
+    if (checkpoint >= GC_AMOUNT)
     {
             [self collect];
             checkpoint = 0;
@@ -87,8 +74,9 @@ BOOL contains (SchemeObject list, SchemeObject what)
                             (integer) queue_pos);
                     [queue_pos markReachable];
                     queue_pos = queue_pos.prev;
-                    if (++amount == 50) return;
+                    if (++amount >= GC_AMOUNT/2) return;
             }
+            dprintf("MARKED: %i reachable objects\n", amount);
             gc_state = GC_SWEEP;
             queue_pos = maybe_garbage;
             return;
@@ -102,8 +90,9 @@ BOOL contains (SchemeObject list, SchemeObject what)
                             (integer) queue_pos);
                     [queue_pos release];
                     queue_pos = queue_pos.next;
-                    if (++amount == 100) return;
-            }
+                        //if (++amount == GC_AMOUNT) return;
+                    }
+            dprintf("Alloced: %i  Freed: %i\n", alloced, freed);
             maybe_garbage = not_garbage;
             not_garbage_end.next = wait_list;
             if (wait_list) {
@@ -127,6 +116,7 @@ BOOL contains (SchemeObject list, SchemeObject what)
 - (id) init
 {
     self = [super init];
+
     if (gc_state) {
             if (wait_list) {
                     wait_list.prev = self;
@@ -147,6 +137,7 @@ BOOL contains (SchemeObject list, SchemeObject what)
     
     prev = NIL;
     root = false;
+    checkpoint++;
     return self;
 }
 
@@ -169,10 +160,6 @@ BOOL contains (SchemeObject list, SchemeObject what)
             next = not_garbage;
             prev = NIL;
             not_garbage = self;
-                //[self markReachable];
-            if (contains (maybe_garbage, self)) {
-                    dprintf("Shit shit shit!\n");
-            }
     }
 }
 

ruamoko/scheme/Scope.r

@@ -84,4 +84,9 @@
     [outerScope mark];
 }
 
+- (Scope) outer
+{
+    return outerScope;
+}
+
 @end

ruamoko/scheme/builtins.r

@@ -6,6 +6,7 @@
 #include "string.h"
 #include "Cons.h"
 #include "Continuation.h"
+#include "BaseContinuation.h"
 #include "Boolean.h"
 
 SchemeObject bi_display (SchemeObject args, Machine m)
@@ -63,6 +64,19 @@ SchemeObject bi_apply (SchemeObject args, Machine m)
     return NIL;
 }
 
+SchemeObject bi_callcc (SchemeObject args, Machine m)
+{
+    if ([m continuation]) {
+            [m stack: cons([m continuation], [Nil nil])];
+    } else {
+            [m stack: cons([BaseContinuation baseContinuation],
+                           [Nil nil])];
+    }
+    [[args car] invokeOnMachine: m];
+    return NIL;
+}
+    
+
 void builtin_addtomachine (Machine m)
 {
     [m addGlobal: symbol("display")
@@ -81,4 +95,6 @@ void builtin_addtomachine (Machine m)
        value: [Primitive newFromFunc: bi_cdr]];
     [m addGlobal: symbol("apply")
        value: [Primitive newFromFunc: bi_apply]];
+    [m addGlobal: symbol("call-with-current-continuation")
+       value: [Primitive newFromFunc: bi_callcc]];
 }