Merge commit 'origin/exp' into exp

Conflicts:

	test-simulator.rkt

assemble.rkt

@@ -260,7 +260,7 @@ EOF
                                       (build-list (PushEnvironment-n stmt) 
                                                   (lambda: ([i : Natural])
                                                            (if (PushEnvironment-unbox? stmt)
-                                                               "[]"
+                                                               "[undefined]"
                                                                "undefined")))
                                       ", "))]
     [(PopEnvironment? stmt)
@@ -281,7 +281,9 @@ EOF
     [(EnvLexicalReference? target)
      (assemble-lexical-reference target)]
     [(EnvPrefixReference? target)
-     (assemble-prefix-reference target)]))
+     (assemble-prefix-reference target)]
+    [(PrimitivesReference? target)
+     (format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
 
 
 
@@ -299,7 +301,7 @@ EOF
               [(boolean? val)
                (if val "true" "false")]
               [(empty? val)
-               (format "Primitives.NULL")]
+               (format "Primitives.null")]
               [else
                (format "~s" val)])))
 

bootstrapped-primitives.rkt

@@ -0,0 +1,162 @@
+#lang typed/racket/base
+(require "expression-structs.rkt"
+         "lexical-structs.rkt"
+         "il-structs.rkt"
+         "lexical-env.rkt"
+         "helpers.rkt"
+         "find-toplevel-variables.rkt"
+         "sets.rkt"
+         "compile.rkt"
+         "typed-parse.rkt"
+         racket/list)
+
+
+
+(provide get-bootstrapping-code)
+
+
+
+;; The primitive code necessary to do call/cc
+
+(: call/cc-label Symbol)
+(define call/cc-label 'callCCEntry)
+(define call/cc-closure-entry 'callCCClosureEntry)
+
+
+;; (call/cc f)
+;; Tail-calls f, providing it a special object that knows how to do the low-level
+;; manipulation of the environment and control stack.
+(define (make-call/cc-code)
+  (statements
+   (append-instruction-sequences
+    (make-instruction-sequence 
+     `(,call/cc-label
+       ;; Precondition: the environment holds the f function that we want to jump into.
+       
+       ;; First, move f to the proc register
+       ,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
+       
+       ;; Next, capture the envrionment and the current continuation closure,.
+       ,(make-PushEnvironment 2 #f)
+       ,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f) 
+                                    (make-CaptureControl 0))
+       ,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
+                                    ;; When capturing, skip over f and the two slots we just added.
+                                    (make-CaptureEnvironment 3))
+       ,(make-AssignPrimOpStatement (adjust-target-depth (make-EnvLexicalReference 0 #f) 2)
+                                    (make-MakeCompiledProcedure call/cc-closure-entry
+                                                                1 ;; the continuation consumes a single value
+                                                                (list (make-EnvLexicalReference 0 #f)
+                                                                      (make-EnvLexicalReference 1 #f))
+                                                                'call/cc))
+       ,(make-PopEnvironment 2 0)))
+    
+    ;; Finally, do a tail call into f.
+    (compile-procedure-call '()
+                            (extend-lexical-environment/placeholders '() 1)
+                            1 
+                            'val
+                            'return)
+    
+    ;; The code for the continuation coe follows.  It's supposed to
+    ;; abandon the current continuation, initialize the control and environment, and then jump.
+    (make-instruction-sequence `(,call/cc-closure-entry
+                                 ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
+                                 ,(make-PerformStatement (make-InstallClosureValues!))
+                                 ,(make-PerformStatement (make-RestoreControl!))
+                                 ,(make-PerformStatement (make-RestoreEnvironment!))
+                                 ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
+                                 ,(make-PopControlFrame)
+                                 ,(make-GotoStatement (make-Reg 'proc)))))))
+
+(: make-bootstrapped-primitive-code (Symbol Any -> (Listof Statement)))
+(define (make-bootstrapped-primitive-code name src)
+  (parameterize ([current-defined-name name])
+    (append
+     (compile (parse src) (make-PrimitivesReference name) 'next)
+     ;; Remove the prefix after the Primitives assignment.
+     `(,(make-PopEnvironment 1 0)))))
+
+
+
+
+
+(: get-bootstrapping-code (-> (Listof Statement)))
+(define (get-bootstrapping-code)
+  
+  (append
+   
+   (make-bootstrapped-primitive-code 
+    'map 
+    '(letrec ([map (lambda (f l)
+		     (if (null? l)
+			 null
+			 (cons (f (car l))
+			       (map f (cdr l)))))])
+       map))
+
+   (make-bootstrapped-primitive-code
+    'for-each
+    '(letrec ([for-each (lambda (f l)
+			  (if (null? l)
+			      null
+			      (begin (f (car l))
+				     (for-each f (cdr l)))))])
+       for-each))
+
+   (make-bootstrapped-primitive-code
+    'caar
+    '(lambda (x)
+       (car (car x))))
+
+
+   (make-bootstrapped-primitive-code
+    'memq
+    '(letrec ([memq (lambda (x l)
+		      (if (null? l)
+			  #f
+			  (if (eq? x (car l))
+			      l
+			      (memq x (cdr l)))))])
+       memq))
+
+   (make-bootstrapped-primitive-code
+    'assq
+    '(letrec ([assq (lambda (x l)
+		     (if (null? l)
+			 #f
+			 (if (eq? x (caar l))
+			     (car l)
+			     (assq x (cdr l)))))])
+      assq))
+
+   (make-bootstrapped-primitive-code
+    'length
+    '(letrec ([length-iter (lambda (l i)
+			    (if (null? l)
+				i
+				(length-iter (cdr l) (add1 i))))])
+      (lambda (l) (length-iter l 0))))
+			  
+
+   (make-bootstrapped-primitive-code
+    'append
+    '(letrec ([append (lambda (l1 l2)
+			(if (null? l1) 
+			    l2
+			    (cons (car l1) (append (cdr l1) l2))))])
+       append))
+	      
+
+   
+   ;; The call/cc code is special:
+   (let ([after-call/cc-code (make-label 'afterCallCCImplementation)])
+     (append 
+
+      `(,(make-AssignPrimOpStatement (make-PrimitivesReference 'call/cc) 
+                                     (make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
+        ,(make-AssignPrimOpStatement (make-PrimitivesReference 'call-with-current-continuation) 
+                                     (make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
+        ,(make-GotoStatement (make-Label after-call/cc-code)))
+      (make-call/cc-code)
+      `(,after-call/cc-code)))))

browser-evaluate.rkt

@@ -216,7 +216,13 @@ var comet = function() {
                     var invoke = eval(req.responseText)();
                     var output = [];
                     var startTime, endTime;
-                    var params = { currentDisplayer: function(v) { output.push(String(v)); } };
+                    var params = { currentDisplayer: function(v) {
+                                                         var pNode = document.createElement("span");
+                                                         pNode.style.whiteSpace = 'pre';
+                                                         pNode.appendChild(document.createTextNode(String(v)));
+                                                         document.body.appendChild(pNode);
+                                                         //console.log(v);
+                                                         output.push(String(v)); } };
 
                     var onSuccess = function(v) {
                         endTime = new Date();

compile.rkt

@@ -12,9 +12,8 @@
 (provide (rename-out [-compile compile])
          compile-procedure-call
          append-instruction-sequences
-         
+         current-defined-name
-         call/cc-label
+         adjust-target-depth)
-         make-call/cc-code)
 
 
 (: current-defined-name (Parameterof (U Symbol False)))
@@ -32,10 +31,7 @@
                          exp)
                (list)
                target 
-               linkage)
+               linkage)))))
-      (make-instruction-sequence `(,(make-GotoStatement (make-Label end))))
-      (make-call/cc-code)
-      end))))
 
 
 
@@ -625,7 +621,9 @@
                                (EnvLexicalReference-unbox? target))]
     [(EnvPrefixReference? target)
      (make-EnvPrefixReference (+ n (EnvPrefixReference-depth target))
-                              (EnvPrefixReference-pos target))]))
+                              (EnvPrefixReference-pos target))]
+    [(PrimitivesReference? target)
+     target]))
 
 
 
@@ -652,61 +650,3 @@
       (error 'ensure-natural "Not a natural: ~s\n" n)))
 
 
-
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;; The primitive code necessary to do call/cc
-
-(: call/cc-label Symbol)
-(define call/cc-label 'callCCEntry)
-(define call/cc-closure-entry 'callCCClosureEntry)
-
-
-;; (call/cc f)
-;; Tail-calls f, providing it a special object that knows how to do the low-level
-;; manipulation of the environment and control stack.
-(define (make-call/cc-code)
-  (append-instruction-sequences
-   (make-instruction-sequence 
-    `(,call/cc-label
-      ;; Precondition: the environment holds the f function that we want to jump into.
-      
-      ;; First, move f to the proc register
-      ,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
-      
-      ;; Next, capture the envrionment and the current continuation closure,.
-      ,(make-PushEnvironment 2 #f)
-      ,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f) 
-                                   (make-CaptureControl 0))
-      ,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
-                                   ;; When capturing, skip over f and the two slots we just added.
-                                   (make-CaptureEnvironment 3))
-      ,(make-AssignPrimOpStatement (adjust-target-depth (make-EnvLexicalReference 0 #f) 2)
-                                   (make-MakeCompiledProcedure call/cc-closure-entry
-                                                               1 ;; the continuation consumes a single value
-                                                               (list (make-EnvLexicalReference 0 #f)
-                                                                     (make-EnvLexicalReference 1 #f))
-                                                               (current-defined-name)))
-      ,(make-PopEnvironment 2 0)))
-                                   
-   ;; Finally, do a tail call into f.
-   (compile-procedure-call '()
-                           (extend-lexical-environment/placeholders '() 1)
-                           1 
-                           'val
-                           'return)
-   
-   ;; The code for the continuation coe follows.  It's supposed to
-   ;; abandon the current continuation, initialize the control and environment, and then jump.
-   (make-instruction-sequence `(,call/cc-closure-entry
-                                ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
-                                ,(make-PerformStatement (make-InstallClosureValues!))
-                                ,(make-PerformStatement (make-RestoreControl!))
-                                ,(make-PerformStatement (make-RestoreEnvironment!))
-                                ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
-                                ,(make-PopControlFrame)
-                                ,(make-GotoStatement (make-Reg 'proc))))))

expression-structs.rkt

@@ -37,11 +37,6 @@
   #:transparent)
 
 
-
-#;(define-struct: Letrec ([names : (Listof Symbol)]
-                        [procs : (Listof Lam)]
-                        [body : ExpressionCore]))
-
 (: last-exp? ((Listof Expression) -> Boolean))
 (define (last-exp? seq) 
   (null? (cdr seq)))

il-structs.rkt

@@ -29,7 +29,8 @@
 ;; Targets: these are the allowable lhs's for an assignment.
 (define-type Target (U AtomicRegisterSymbol 
                        EnvLexicalReference
-                       EnvPrefixReference))
+                       EnvPrefixReference
+                       PrimitivesReference))
 
 
 
@@ -49,6 +50,10 @@
   #:transparent)
 
 
+(define-struct: PrimitivesReference ([name : Symbol])
+  #:transparent)
+
+
 
 ;; An environment reference is either lexical or referring to a whole prefix.
 (define-type EnvReference (U EnvLexicalReference

package.rkt

@@ -4,6 +4,7 @@
          "assemble.rkt"
          "typed-parse.rkt"
          "il-structs.rkt"
+         "bootstrapped-primitives.rkt"
          racket/runtime-path
          racket/port)
 
@@ -17,13 +18,6 @@
 ;; package: s-expression output-port -> void
 (define (package source-code op)
 
-  ;; The support code for call/cc
-  (for-each (lambda (code)
-              (displayln code op))
-            (map assemble-basic-block 
-                 (fracture (statements 
-                            (make-call/cc-code)))))
-
   ;; The runtime code
   (call-with-input-file* runtime.js
     (lambda (ip)
@@ -32,9 +26,10 @@
   (newline op)
   
   (fprintf op "var invoke = ")
-  (assemble/write-invoke (compile (parse source-code)
+  (assemble/write-invoke (append (get-bootstrapping-code)
-                                  'val
+				 (compile (parse source-code)
-                                  'next)
+					  'val
+					  'next))
                          op)
   (fprintf op ";\n"))
 

runtime.js

@@ -130,6 +130,24 @@ var Primitives = (function() {
 	    return firstArg[1];
 	},
 
+	'pair?': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    return (typeof(firstArg) == 'object' && 
+		    firstArg.length === 2);
+	},
+
+	'set-car!': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    var secondArg = MACHINE.env[MACHINE.env.length-2];
+	    firstArg[0] = secondArg;
+	},
+
+	'set-cdr!': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    var secondArg = MACHINE.env[MACHINE.env.length-2];
+	    firstArg[1] = secondArg;
+	},
+	
 	'not': function(arity, returnLabel) {
 	    var firstArg = MACHINE.env[MACHINE.env.length-1];
 	    return (!firstArg);
@@ -166,6 +184,26 @@ var Primitives = (function() {
 	    return result;
 	},
 
+	'vector->list': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    var i;
+	    var result = NULL;
+	    for (i = 0; i < firstArg.length; i++) {
+		result = [firstArg[firstArg.length - 1 - i], result];
+	    }
+	    return result;
+	},
+	
+	'list->vector': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    var result = [];
+	    while (firstArg !== NULL) {
+		result.push(firstArg[0]);
+		firstArg = firstArg[1];
+	    }
+	    return result;
+	},
+
 	'vector-ref': function(arity, returnLabel) {
 	    var firstArg = MACHINE.env[MACHINE.env.length-1];
 	    var secondArg = MACHINE.env[MACHINE.env.length-2];
@@ -185,14 +223,86 @@ var Primitives = (function() {
 	    return typeof(firstArg) === 'string';
 	},
 
- 	'call/cc': new Closure(callCCEntry,
+	'symbol->string': function(arity, returnLabel) {
- 			       1,
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
- 			       [],
+	    return firstArg;
- 			       "call/cc"),
+	},
-	'call-with-current-continuation': new Closure(callCCEntry,
+
- 						      1,
+	'string-append': function(arity, returnLabel) {
- 						      [],
+	    var buffer = [];
- 						      "call-with-current-continuation")
+	    var i;
+	    for (i = 0; i < arity; i++) {
+		buffer.push(MACHINE.env[MACHINE.env.length - 1 - i]);
+	    }
+	    return buffer.join('');
+	},
+
+	'string-length': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    return firstArg.length;
+	},
+	
+	'box': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    var result = [firstArg];
+	    return result;
+	},
+
+	'unbox': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    return firstArg[0];
+        },
+
+	'set-box!': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    var secondArg = MACHINE.env[MACHINE.env.length-2];
+	    firstArg[0] = secondArg;
+	    return;
+	},
+
+	'void': function(arity, returnLabel) {
+	    return;
+	},
+
+
+	'eq?': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    var secondArg = MACHINE.env[MACHINE.env.length-2];
+	    return firstArg === secondArg;
+	},
+
+	'equal?': function(arity, returnLabel) {
+	    var firstArg = MACHINE.env[MACHINE.env.length-1];
+	    var secondArg = MACHINE.env[MACHINE.env.length-2];
+	    var lset = [firstArg], rset = [secondArg];
+	    while (lset.length !== 0 && rset.length !== 0) {
+		var lhs = lset.pop();
+		var rhs = rset.pop();
+		if (lhs === rhs) {
+		    continue;
+		} else if (typeof(lhs) === 'object' &&
+			   typeof(rhs) === 'object' &&
+			   typeof(lhs.length) === 'number' &&
+			   typeof(rhs.length) === 'number' &&
+			   lhs.length === rhs.length) {
+		    lset.push.apply(lset, lhs);
+		    rset.push.apply(rset, rhs);
+		} else {
+		    return false;
+		}
+	    }
+	    return true;
+	}
+
+// 	, 
+//  	'call/cc': new Closure(callCCEntry,
+//  			       1,
+//  			       [],
+//  			       "call/cc"),
+// 	'call-with-current-continuation': new Closure(callCCEntry,
+//  						      1,
+//  						      [],
+//  						      "call-with-current-continuation")
 
     };
 })();
@@ -242,19 +352,60 @@ var Primitives = (function() {
 
 
 
-var MACHINE={callsBeforeTrampoline: 100, 
+var MACHINE = { callsBeforeTrampoline: 100, 
-             val:undefined,
+		val:undefined,
-             proc:undefined, 
+		proc:undefined, 
-             env: [],
+		env: [],
-	     control : [],
+		control : [],
-             params: { currentDisplayer: function(v) {},
+		running : false,
-		       currentErrorHandler: function(e) {},
+		params: { currentDisplayer: function(v) {},
-		       currentNamespace: {}}};
+			  currentErrorHandler: function(e) {},
+			  currentNamespace: {},
+
+			  // These parameters control how often
+			  // control yields back to the browser
+			  // for response.  The implementation is a
+			  // simple PID controller.
+			  //
+			  // To tune this, adjust desiredYieldsPerSecond.
+			  // Do no touch numBouncesBeforeYield or
+			  // maxNumBouncesBeforeYield, because those
+			  // are adjusted automatically by the
+			  // recomputeMaxNumBouncesBeforeYield
+			  // procedure.
+			  desiredYieldsPerSecond: 5,
+			  numBouncesBeforeYield: 2000,   // self-adjusting
+			  maxNumBouncesBeforeYield: 2000 // self-adjusting
+			}
+	      };
+
+
+
+// recomputeGas: state number -> number
+var recomputeMaxNumBouncesBeforeYield = function(observedDelay) {
+    // We'd like to see a delay of DESIRED_DELAY_BETWEEN_BOUNCES so
+    // that we get MACHINE.params.desiredYieldsPerSecond bounces per
+    // second.
+    var DESIRED_DELAY_BETWEEN_BOUNCES = 
+	(1000 / MACHINE.params.desiredYieldsPerSecond);
+    var ALPHA = 256;
+    var delta = (ALPHA * ((DESIRED_DELAY_BETWEEN_BOUNCES -
+			   observedDelay) / 
+			  DESIRED_DELAY_BETWEEN_BOUNCES));
+    MACHINE.params.maxNumBouncesBeforeYield = 
+        Math.max(MACHINE.params.maxNumBouncesBeforeYield + delta,
+                 1);
+};
 
 
 var trampoline = function(initialJump, success, fail) {
     var thunk = initialJump;
+    var startTime = (new Date()).valueOf();
     MACHINE.callsBeforeTrampoline = 100;
+    MACHINE.params.numBouncesBeforeYield = 
+	MACHINE.params.maxNumBouncesBeforeYield;
+    MACHINE.running = true;
+
     while(thunk) {
         try {
             thunk();
@@ -263,10 +414,23 @@ var trampoline = function(initialJump, success, fail) {
             if (typeof(e) === 'function') {
                 thunk = e;
                 MACHINE.callsBeforeTrampoline = 100;
+
+		if (MACHINE.params.numBouncesBeforeYield-- < 0) {
+		    recomputeMaxNumBouncesBeforeYield(
+			(new Date()).valueOf() - startTime);
+		    setTimeout(
+			function() {
+			    trampoline(thunk, success, fail);
+			},
+			0);
+		    return;
+		}
             } else {
+		MACHINE.running = false;
 	        return fail(e);
             }
         }
     }
+    MACHINE.running = false;
     return success();
 };

simulator-primitives.rkt

@@ -1,10 +1,15 @@
 #lang racket/base
 (require "simulator-structs.rkt"
          "compile.rkt"
+         "bootstrapped-primitives.rkt"
          racket/math
          (for-syntax racket/base))
 
-(provide lookup-primitive)
+(provide lookup-primitive set-primitive!)
+
+(define mutated-primitives (make-hasheq))
+(define (set-primitive! n p)
+  (hash-set! mutated-primitives n p))
 
 
 (define-syntax (make-lookup stx)
@@ -28,6 +33,8 @@
                ...)
            (lambda (n)
              (cond
+               [(hash-has-key? mutated-primitives n)
+                (hash-ref mutated-primitives n)]
                [(eq? n 'exported-name)
                 prim-name]
                ...
@@ -38,12 +45,12 @@
                 (make-undefined)]
                )))))]))
 
-(define call/cc
+;(define call/cc
-  (make-closure call/cc-label
+;  (make-closure call/cc-label
-                1
+;                1
-                '()
+;                '()
-                'call/cc))
+;                'call/cc))
-(define call-with-current-continuation call/cc)
+;(define call-with-current-continuation call/cc)
 
 (define e (exp 1))
 
@@ -147,7 +154,7 @@
                                                      
                                                      symbol?)
                                       #:constants (null pi e 
-                                                        call/cc
+                                                        #;call/cc
-                                                        call-with-current-continuation)))
+                                                        #;call-with-current-continuation)))
 
 

simulator.rkt

@@ -7,12 +7,14 @@
 
 (require "il-structs.rkt"
          "simulator-structs.rkt"
+         "bootstrapped-primitives.rkt"
          racket/list
          racket/match
          (for-syntax racket/base))
 
 (require/typed "simulator-primitives.rkt"
-               [lookup-primitive (Symbol -> PrimitiveValue)])
+               [lookup-primitive (Symbol -> PrimitiveValue)]
+               [set-primitive! (Symbol PrimitiveValue -> Void)])
 
 (require/typed "simulator-helpers.rkt"
                [ensure-primitive-value-box (SlotValue -> (Boxof PrimitiveValue))]
@@ -28,17 +30,36 @@
 (define current-simulated-output-port (make-parameter (current-output-port)))
 
 
-(: new-machine ((Listof Statement) -> machine))
+(: new-machine (case-lambda [(Listof Statement) -> machine]
-(define (new-machine program-text)
+                            [(Listof Statement) Boolean -> machine]))
-  (let: ([m : machine (make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text) 0
+(define new-machine
-                                    ((inst make-hash Symbol Natural)))])
+  (case-lambda: 
-        (let: loop : Void ([i : Natural 0])
+    [([program-text : (Listof Statement)])
-              (when (< i (vector-length (machine-text m)))
+     (new-machine program-text #t)]
-                (let: ([stmt : Statement (vector-ref (machine-text m) i)])
+    [([program-text : (Listof Statement)]
-                      (when (symbol? stmt)
+      [with-bootstrapping-code? : Boolean])
-                        (hash-set! (machine-jump-table m) stmt i))
+     (let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)]
-                      (loop (add1 i)))))
+             [program-text : (Listof Statement)
-        m))
+                           (cond [with-bootstrapping-code?
+                                  (append (get-bootstrapping-code)
+                                          program-text)]
+                                 [else
+                                  program-text])])
+            (let: ([m : machine (make-machine (make-undefined)
+                                              (make-undefined)
+                                              '() 
+                                              '()
+                                              0 
+                                              (list->vector program-text) 
+                                              0
+                                              ((inst make-hash Symbol Natural)))])
+                  (let: loop : Void ([i : Natural 0])
+                        (when (< i (vector-length (machine-text m)))
+                          (let: ([stmt : Statement (vector-ref (machine-text m) i)])
+                                (when (symbol? stmt)
+                                  (hash-set! (machine-jump-table m) stmt i))
+                                (loop (add1 i)))))
+                  m))]))
 
 
 
@@ -103,20 +124,7 @@
 (define (step-assign-immediate! m stmt)
   (let: ([t : Target (AssignImmediateStatement-target stmt)]
          [v : SlotValue (evaluate-oparg m (AssignImmediateStatement-value stmt))])
-        (cond [(eq? t 'proc)
+        ((get-target-updater t) m v)))
-               (proc-update! m v)]
-              [(eq? t 'val)
-               (val-update! m v)]
-              [(EnvLexicalReference? t)
-               (if (EnvLexicalReference-unbox? t)
-                   (begin (set-box! (ensure-primitive-value-box (env-ref m (EnvLexicalReference-depth t)))
-                                    (ensure-primitive-value v))
-                          'ok)
-                   (env-mutate! m (EnvLexicalReference-depth t) v))]
-              [(EnvPrefixReference? t)
-               (toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t)))
-                                 (EnvPrefixReference-pos t)
-                                 (ensure-primitive-value v))])))
 
 
 (: step-push-environment! (machine PushEnvironment -> 'ok))
@@ -251,7 +259,12 @@
      (lambda: ([m : machine] [v : SlotValue])
               (toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t)))
                                 (EnvPrefixReference-pos t)
-                                (ensure-primitive-value v)))]))
+                                (ensure-primitive-value v)))]
+    [(PrimitivesReference? t)
+     (lambda: ([m : machine] [v : SlotValue])
+              (set-primitive! (PrimitivesReference-name t)
+                              (ensure-primitive-value v))
+              'ok)]))
 
 
 (: step-assign-primitive-operation! (machine AssignPrimOpStatement -> 'ok))

test-assemble.rkt

@@ -43,16 +43,10 @@
                              (string-append
                               "(function() { "
                               
-                                ;; The support code for call/cc
-                              (string-join (map assemble-basic-block 
-                                                (fracture (statements 
-                                                           (make-call/cc-code))))
-                                           "\n")
-                              
                               runtime
 
-                              
+                              "return function(success, fail, params){" 
-                              "return function(success, fail, params){" snippet
+			      snippet
                               (format "success(String(~a)); };" inspector)
                               "});")])
                        (displayln snippet)
@@ -68,13 +62,6 @@
                             
                             (display "(function() { " op)
                             
-                            (display
-                             (string-join (map assemble-basic-block 
-                                                (fracture (statements 
-                                                           (make-call/cc-code))))
-                                           "\n")
-                             op)
-                            
                             (display runtime op)
                             
                             (display "var myInvoke = " op)

test-browser-evaluate.rkt

@@ -20,7 +20,6 @@
                                      #'stx)))
              (printf " ok (~a milliseconds)\n" (evaluated-t result))))))]))
 
-
 (test '(begin (define (f x) 
                 (if (= x 0)
                     0

test-conform-browser.rkt

@@ -0,0 +1,24 @@
+#lang racket
+(require "browser-evaluate.rkt"
+         "package.rkt")
+
+(define evaluate (make-evaluate package-anonymous))
+
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ s exp)
+     (with-syntax ([stx stx])
+       (syntax/loc #'stx
+         (begin
+           (printf "running test...")
+           (let ([result (evaluate s)])
+             (let ([output (evaluated-stdout result)])
+               (unless (string=? output exp)
+                 (printf " error!\n")
+                 (raise-syntax-error #f (format "Expected ~s, got ~s" exp output)
+                                     #'stx)))
+             (printf " ok (~a milliseconds)\n" (evaluated-t result))))))]))
+
+
+(test (read (open-input-file "tests/conform/program0.sch"))
+      (port->string (open-input-file "tests/conform/expected0.txt")))

test-simulator.rkt

@@ -42,7 +42,8 @@
 
 
 ;; Infinite loop
-(let ([m (new-machine `(hello world ,(make-GotoStatement (make-Label 'hello))))])
+(let ([m (new-machine `(hello world ,(make-GotoStatement (make-Label 'hello)))
+                      #f)])
   (test (machine-pc (step-n m 0)) 0)
   (test (machine-pc (step-n m 1)) 1)
   (test (machine-pc (step-n m 1)) 2)
@@ -52,13 +53,15 @@
 
 
 ;; Assigning to val
-(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))))])
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42)))
+                      #f)])
   (test (machine-val m) (make-undefined))
   (step! m)
   (test (machine-val m) 42))
 
 ;; Assigning to proc
-(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const 42))))])
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const 42)))
+                      #f)])
   (test (machine-proc m) (make-undefined))
   (step! m)
   (test (machine-proc m) 42))
@@ -66,7 +69,8 @@
 
 ;; Assigning to a environment reference
 (let* ([m (new-machine `(,(make-PushEnvironment 1 #f)
-                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42))))]
+                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42)))
+                       #f)]
        [m (run m)])
   (test (machine-env m) '(42)))
 
@@ -375,7 +379,8 @@
                         end
                         ))])
   (test (machine-val (run m))
-        (make-closure 'procedure-entry 0 (list 'larry 'moe) 'procedure-entry)))
+        (make-closure 'procedure-entry 0 (list 'larry 'moe)
+                      'procedure-entry)))
 
 ;; make-compiled-procedure: Capturing a toplevel.
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
@@ -396,7 +401,8 @@
                         end
                         ))])
   (test (machine-val (run m))
-        (make-closure 'procedure-entry 0 (list (make-toplevel (list "x" "y" "z"))) 'procedure-entry)))
+        (make-closure 'procedure-entry 0 (list (make-toplevel (list "x" "y" "z")))
+                      'procedure-entry)))
 
 ;; make-compiled-procedure: Capturing both a toplevel and some lexical values
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))

tests/conform/expected0.txt

@@ -3,48 +3,3 @@
 30 -> 374 -> 31
 31 -> 119
  ok.
-6 -> 26 -> 16
-16 -> 132 -> 30
-30 -> 374 -> 31
-31 -> 119
- ok.
-6 -> 26 -> 16
-16 -> 132 -> 30
-30 -> 374 -> 31
-31 -> 119
- ok.
-6 -> 26 -> 16
-16 -> 132 -> 30
-30 -> 374 -> 31
-31 -> 119
- ok.
-6 -> 26 -> 16
-16 -> 132 -> 30
-30 -> 374 -> 31
-31 -> 119
- ok.
-6 -> 26 -> 16
-16 -> 132 -> 30
-30 -> 374 -> 31
-31 -> 119
- ok.
-6 -> 26 -> 16
-16 -> 132 -> 30
-30 -> 374 -> 31
-31 -> 119
- ok.
-6 -> 26 -> 16
-16 -> 132 -> 30
-30 -> 374 -> 31
-31 -> 119
- ok.
-6 -> 26 -> 16
-16 -> 132 -> 30
-30 -> 374 -> 31
-31 -> 119
- ok.
-6 -> 26 -> 16
-16 -> 132 -> 30
-30 -> 374 -> 31
-31 -> 119
- ok.

tests/conform/program0.sch

@@ -1,46 +1,46 @@
 (begin
 
-(define (caar l)
+;; (define (caar l)
-  (car (car l)))
+;;   (car (car l)))
 
-(define (map f l)
+;; (define (map f l)
-  (if (null? l)
+;;   (if (null? l)
-      null
+;;       null
-      (cons (f (car l))
+;;       (cons (f (car l))
-            (map f (cdr l)))))
+;;             (map f (cdr l)))))
 
-(define (for-each f l)
+;; (define (for-each f l)
-  (if (null? l)
+;;   (if (null? l)
-      null
+;;       null
-      (begin (f (car l))
+;;       (begin (f (car l))
-	     (for-each f (cdr l)))))
+;; 	     (for-each f (cdr l)))))
 
-(define (memq x l)
+;; (define (memq x l)
-  (if (null? l)
+;;   (if (null? l)
-      #f
+;;       #f
-      (if (eq? x (car l))
+;;       (if (eq? x (car l))
-          l
+;;           l
-	  (memq x (cdr l)))))
+;; 	  (memq x (cdr l)))))
 
 
-(define (assq x l)
+;; (define (assq x l)
-  (if (null? l)
+;;   (if (null? l)
-      #f
+;;       #f
-      (if (eq? x (caar l))
+;;       (if (eq? x (caar l))
-          (car l)
+;;           (car l)
-	  (assq x (cdr l)))))
+;; 	  (assq x (cdr l)))))
 
 
-(define (length l)
+;; (define (length l)
-  (if (null? l)
+;;   (if (null? l)
-      0
+;;       0
-      (add1 (length (cdr l)))))
+;;       (add1 (length (cdr l)))))
 
 
-(define (append l1 l2)
+;; (define (append l1 l2)
-  (if (null? l1) 
+;;   (if (nullb? l1) 
-      l2
+;;       l2
-      (cons (car l1) (append (cdr l1) l2))))
+;;       (cons (car l1) (append (cdr l1) l2))))
 
 
 (define vector-copy
@@ -513,4 +513,4 @@
       (newline))))
 
 
-(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) '10)))
+(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) 1)))