still debugging, but something broke

NOTES

@@ -0,0 +1,73 @@
+Some possible optimizations with application:
+
+    If any of the operands are constant (either by being variable
+    lookups or literal constants), and if all of them are side-effect
+    free, then juggle-operands might not be necessary.
+    
+    In a self-application, it's not necessary to compute the operator,
+    since the value is in the top control frame.  A parameterization
+    can maintain the current lam in the top of the control frame.
+    Given that, then there's no need to juggle operands either, since
+    we can grab the operator afterwards and put it in place.
+
+    For a kernel primitive call, if all of the operands are all
+    constant, stack references, or kernel primitive calls, then
+    there's no need to push for fresh stack space.
+
+
+
+
+Multiple values
+
+There's interplay between compile-proc-appl and the linkage compiling
+functions compile-linkage and compile-application-linkage.  When we
+deal with multiple values, we'll have to do something here to make the
+values efficient.  There's a paper by J. Michael Ashley and R. Kent
+Dybvig called "An Efficient Implementation of Multiple Return Values
+in Scheme" that I'll need to read.
+http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.39.1668&rep=rep1&type=pdf
+
+
+
+
+
+Open coding:
+
+I want to be able to write the definitions of kernel primitives once,
+and reuse those definitions for both the open-coding as well as the
+real runtime.  I also need to be able to encode the type checks.  I
+want to be able to say:
+
+
+(make-kernel-primitive '+
+                       (arity 0 #t)
+
+                       (lambda (args)
+			 (values (mapi (lambda (arg i)
+					 (test arg i number?))
+				       arg)
+				 (string-join args "+"))))
+
+and have it magically generate the definitions for the open-coding
+primitive as well as:
+
+    PRIMITIVES["+"] = function(MACHINE, arity) {
+                          var result = 0;
+                          for (var i = 0 ; i < arity; i++) {
+                              test(isNumber(MACHINE.env[MACHINE.env.length - 1 - i]),
+                                   i,
+                                   "number");
+                              result += MACHINE.env[MACHINE.env.length - 1 - i];
+			  }
+                          return result;
+                      };
+
+Is this completely unrealistic?  I have to see how Rabbit and Orbit do this.
+
+
+
+
+----------------------------------------------------------------------
+
+Runtime values and types are in in the plt.runtime namespace.  I need
+to move types from WeScheme into here.

README.md

@@ -1,46 +0,0 @@
-Whalesong
-=========
-
-Important
----------
-
-Whalesong needs Racket 6.2.
-As is Whalesong doesn't work on version 6.3 or greater.
-See https://github.com/soegaard/whalesong/issues/48
-
-Installation
-------------
-
-raco pkg install -j 1 --force --deps search-auto --scope installation whalesong
-
-Important: Use -j 1 to build Whalesong (this turns off parallel builds)
-           This also means, that you can't install Whalesong from the DrRacket package manager.
-
-This fork of Whalesong differs from dyoo/whalesong in the following ways:
-
-  * Builds on latest release of Racket
-    (fixes the x undefined problem)
-  * Adds for
-    (require whalesong/lang/for)
-  * Adds match
-    (require whalesong/lang/match)
-  * Adds on-release
-    (as a complement to on-key)
-    Contributed by Darren Cruse
-  * Adds parameters
-    (require whalesong/lang/parameters)
-  * Extended whalesong/image and whalesong/images
-    (more functions, bug fixes, now matches WeScheme)
-    Contributed by Emmanuel Schanzer
-  * Adds play-sound
-    (assumes a browser with html5 audio support)
-    Contributed by Emmanuel Schanzer and Darren Cruse
-  * Bug fixes by Vishesh Yadav
-  * The flag --as-standalone-xhtml is now --as-standalone-html
-    and produces standalone html rather than xhtml.
-
-Note: The implementation of parameters works fine,
-      as long as you don't mix parameterize with non-local-exits
-      and reentries (i.e. call/cc and friends)
-      
-/soegaard

assemble-helpers.rkt

@@ -0,0 +1,123 @@
+#lang typed/racket/base
+
+(require "il-structs.rkt"
+         "lexical-structs.rkt"
+         racket/list)
+
+(provide assemble-oparg
+         assemble-target
+         assemble-const
+         assemble-lexical-reference
+         assemble-prefix-reference
+         assemble-whole-prefix-reference
+         assemble-reg
+         assemble-label
+         assemble-input)
+
+
+(: assemble-oparg (OpArg -> String))
+(define (assemble-oparg v)
+  (cond 
+    [(Reg? v)
+     (assemble-reg v)]
+    [(Label? v)
+     (assemble-label v)]
+    [(Const? v)
+     (assemble-const v)]
+    [(EnvLexicalReference? v)
+     (assemble-lexical-reference v)]
+    [(EnvPrefixReference? v)
+     (assemble-prefix-reference v)]
+    [(EnvWholePrefixReference? v)
+     (assemble-whole-prefix-reference v)]))
+
+
+
+
+(: assemble-target (Target -> String))
+(define (assemble-target target)
+  (cond
+    [(eq? target 'proc)
+     "MACHINE.proc"]
+    [(eq? target 'val)
+     "MACHINE.val"]
+    [(EnvLexicalReference? target)
+     (assemble-lexical-reference target)]
+    [(EnvPrefixReference? target)
+     (assemble-prefix-reference target)]
+    [(PrimitivesReference? target)
+     (format "MACHINE.primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
+
+
+
+;; fixme: use js->string
+(: assemble-const (Const -> String))
+(define (assemble-const stmt)
+  (let: loop : String ([val : Any (Const-const stmt)])
+        (cond [(symbol? val)
+               (format "~s" (symbol->string val))]
+              [(pair? val)
+               (format "[~a, ~a]" 
+                       (loop (car val))
+                       (loop (cdr val)))]
+              [(boolean? val)
+               (if val "true" "false")]
+              [(void? val)
+               "null"]
+              [(empty? val)
+               (format "RUNTIME.NULL")]
+              [(number? val)
+               (format "(~s)" val)]
+              [else
+               (format "~s" val)])))
+
+
+
+
+(: assemble-lexical-reference (EnvLexicalReference -> String))
+(define (assemble-lexical-reference a-lex-ref)
+  (if (EnvLexicalReference-unbox? a-lex-ref)
+      (format "MACHINE.env[MACHINE.env.length - 1 - ~a][0]"
+              (EnvLexicalReference-depth a-lex-ref))
+      (format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
+              (EnvLexicalReference-depth a-lex-ref))))
+
+(: assemble-prefix-reference (EnvPrefixReference -> String))
+(define (assemble-prefix-reference a-ref)
+  (format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a]"
+          (EnvPrefixReference-depth a-ref)
+          (EnvPrefixReference-pos a-ref)))
+
+(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String))
+(define (assemble-whole-prefix-reference a-prefix-ref)
+  (format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
+          (EnvWholePrefixReference-depth a-prefix-ref)))
+
+
+(: assemble-reg (Reg -> String))
+(define (assemble-reg a-reg)
+  (string-append "MACHINE." (symbol->string (Reg-name a-reg))))
+
+
+
+(: assemble-label (Label -> String))
+(define (assemble-label a-label)
+  (symbol->string (Label-name a-label)))
+
+
+
+(: assemble-input (OpArg -> String))
+(define (assemble-input an-input)
+  (cond
+    [(Reg? an-input)
+     (assemble-reg an-input)]
+    [(Const? an-input)
+     (assemble-const an-input)]
+    [(Label? an-input)
+     (assemble-label an-input)]
+    [(EnvLexicalReference? an-input)
+     (assemble-lexical-reference an-input)]
+    [(EnvPrefixReference? an-input)
+     (assemble-prefix-reference an-input)]
+    [(EnvWholePrefixReference? an-input)
+     (assemble-whole-prefix-reference an-input)]))

assemble-open-coded.rkt

@@ -0,0 +1,151 @@
+#lang typed/racket/base
+
+(require "il-structs.rkt"
+         "lexical-structs.rkt"
+         "assemble-helpers.rkt"
+         "kernel-primitives.rkt"
+         racket/string
+         racket/list)
+
+(provide open-code-kernel-primitive-procedure)
+
+
+
+(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
+(define (open-code-kernel-primitive-procedure op)
+  (let*: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
+          [operands : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))]
+          [checked-operands : (Listof String)
+                            (map maybe-typecheck-operand
+                                 (CallKernelPrimitiveProcedure-expected-operand-types op)
+                                 (build-list (length operands) (lambda: ([i : Natural]) i))
+                                 operands
+                                 (CallKernelPrimitiveProcedure-typechecks? op))])
+        (case operator
+          [(+)
+           (cond [(empty? checked-operands)
+                  "0"]
+                 [else
+                  (string-append "(" (string-join checked-operands " + ") ")")])]
+          
+          [(-)
+           (cond [(empty? (rest checked-operands))
+                  (format "(-(~a))" (first checked-operands))]
+                 [else
+                  (string-append "(" (string-join checked-operands "-") ")")])]
+          
+          [(*)
+           (cond [(empty? checked-operands)
+                  "1"]
+                 [else
+                  (string-append "(" (string-join checked-operands "*") ")")])]
+
+          [(/)
+           (string-append "(" (string-join checked-operands "/") ")")]
+
+          [(add1)
+           (format "(~a + 1)" (first checked-operands))]
+          
+          [(sub1)
+           (format "(~a - 1)" (first checked-operands))]
+          
+          [(<)
+           (assemble-chain "<" checked-operands)]
+
+          [(<=)
+           (assemble-chain "<=" checked-operands)]
+          
+          [(=)
+           (assemble-chain "===" checked-operands)]
+          
+          [(>)
+           (assemble-chain ">" checked-operands)]
+          
+          [(>=)
+           (assemble-chain ">=" checked-operands)]
+          
+          [(cons)
+           (format "[~a, ~a]" (first checked-operands) (second checked-operands))]
+
+          [(car)
+           (format "(~a)[0]" (first checked-operands))]
+          
+          [(cdr)
+           (format "(~a)[1]" (first checked-operands))]
+          
+          [(list)
+           (let loop ([checked-operands checked-operands])
+             (cond
+               [(empty? checked-operands)
+                "RUNTIME.NULL"]
+               [else
+                (format "[~a,~a]" (first checked-operands) (loop (rest checked-operands)))]))]
+          
+          [(null?)
+           (format "(~a === RUNTIME.NULL)" (first checked-operands))]
+
+          [(not)
+           (format "(!(~a))" (first checked-operands))]
+          
+          [(eq?)
+           (format "(~a === ~a)" (first checked-operands) (second checked-operands))])))
+
+
+(: assemble-chain (String (Listof String) -> String))
+(define (assemble-chain rator rands)
+  (string-append "("
+                 (string-join (let: loop : (Listof String) ([rands : (Listof String) rands])
+                                (cond
+                                  [(empty? rands)
+                                   '()]
+                                  [(empty? (rest rands))
+                                   '()]
+                                  [else
+                                   (cons (format "(~a ~a ~a)" (first rands) rator (second rands))
+                                         (loop (rest rands)))]))
+                              "&&")
+                 ")"))
+
+
+
+
+
+(: assemble-domain-check (OperandDomain String Natural -> String))
+(define (assemble-domain-check domain operand-string pos)
+  (cond
+    [(eq? domain 'any)
+     operand-string]
+    [else
+     (let: ([test-string : String
+                         (case domain
+                           [(number)
+                            (format "(typeof(~a) === 'number')"
+                                    operand-string)]             
+                           [(string)
+                            (format "(typeof(~a) === 'string')"
+                                    operand-string)]
+                           [(list)
+                            (format "(~a === [] || (typeof(~a) === 'object' && (~a).length === 2))"
+                                    operand-string operand-string operand-string)]
+                           [(pair)
+                            (format "(typeof(~a) === 'object' && (~a).length === 2)"
+                                    operand-string operand-string)]
+                           [(box)
+                            (format "(typeof(~a) === 'object' && (~a).length === 1)"
+                                    operand-string operand-string)])])
+           (format "((~a) ? (~a) : RUNTIME.raise(new Error('Expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))"
+                   test-string
+                   operand-string
+                   (symbol->string domain)
+                   (add1 pos)
+                   operand-string))]))
+
+
+(: maybe-typecheck-operand (OperandDomain Natural String Boolean -> String))
+;; Adds typechecks if we can't prove that the operand is of the required type.
+(define (maybe-typecheck-operand domain-type position operand-string typecheck?)
+  (cond
+    [typecheck?
+     (assemble-domain-check domain-type operand-string position)]
+    [else
+     operand-string]))

assemble.rkt

@@ -0,0 +1,523 @@
+#lang typed/racket/base
+(require "il-structs.rkt"
+         "lexical-structs.rkt"
+         "helpers.rkt"
+         "assemble-helpers.rkt"
+         "assemble-open-coded.rkt"
+         racket/string
+         racket/list)
+
+(provide assemble/write-invoke
+         fracture
+         assemble-basic-block
+         assemble-statement)
+
+
+;; Parameter that controls the generation of a trace.
+(define current-emit-debug-trace? (make-parameter #t))
+
+
+
+(: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
+;; Writes out the JavaScript code that represents the anonymous invocation expression.
+(define (assemble/write-invoke stmts op)
+  (let* ([basic-blocks (fracture stmts)]
+         [basic-block-labels (map BasicBlock-name basic-blocks)])
+    (fprintf op "(function(MACHINE, success, fail, params) {\n")
+    (fprintf op "var param;\n")
+    (fprintf op "var RUNTIME = plt.runtime;\n")
+    (for-each (lambda: ([basic-block : BasicBlock])
+                       (displayln (assemble-basic-block basic-block) op)
+                       (newline op))
+              basic-blocks)
+    (for-each (lambda: ([a-paired-label : PairedLabel])
+                       (cond [(member (PairedLabel-label a-paired-label)
+                                      basic-block-labels)
+                              
+                              (assemble-paired-label a-paired-label op)
+                              (newline op)]
+                             [else
+                              (void)]))
+              (collect-paired-labels stmts))
+    (fprintf op "MACHINE.params.currentErrorHandler = fail;\n")
+    (fprintf op "MACHINE.params.currentSuccessHandler = success;\n")
+    (fprintf op #<<EOF
+for (param in params) {
+    if (params.hasOwnProperty(param)) {
+        MACHINE.params[param] = params[param];
+    }
+}
+EOF
+             )
+    (fprintf op "RUNTIME.trampoline(MACHINE, ~a); })"
+             (BasicBlock-name (first basic-blocks)))))
+
+
+
+
+;; fracture: (listof stmt) -> (listof basic-block)
+(: fracture ((Listof Statement) -> (Listof BasicBlock)))
+(define (fracture stmts)
+  (let* ([first-block-label (if (and (not (empty? stmts))
+                                     (symbol? (first stmts)))
+                                (first stmts)
+                                (make-label 'start))]
+         [stmts (if (and (not (empty? stmts))
+                         (symbol? (first stmts)))
+                    (rest stmts)
+                    stmts)]
+         [jump-targets 
+          (cons first-block-label (collect-general-jump-targets stmts))])
+    (let: loop : (Listof BasicBlock)
+          ([name : Symbol first-block-label]
+           [acc : (Listof UnlabeledStatement) '()]
+           [basic-blocks  : (Listof BasicBlock) '()]
+           [stmts : (Listof Statement) stmts]
+           [last-stmt-goto? : Boolean #f])
+          (cond
+            [(null? stmts)
+             (reverse (cons (make-BasicBlock name (reverse acc))
+                            basic-blocks))]
+            [else
+             (let ([first-stmt (car stmts)])
+               (cond
+                 
+                 [(symbol? first-stmt)
+                  (cond
+                    [(member first-stmt jump-targets)
+                     (loop first-stmt
+                           '()
+                           (cons (make-BasicBlock 
+                                  name  
+                                  (if last-stmt-goto? 
+                                      (reverse acc)
+                                      (reverse (append `(,(make-GotoStatement (make-Label first-stmt)))
+                                                       acc))))
+                                 basic-blocks)
+                           (cdr stmts)
+                           last-stmt-goto?)]
+                    [else
+                     (loop name
+                           acc
+                           basic-blocks
+                           (cdr stmts)
+                           last-stmt-goto?)])]
+                 
+                 [(PairedLabel? first-stmt)
+                  (cond
+                    [(member (PairedLabel-label first-stmt) jump-targets)
+                     (loop (PairedLabel-label first-stmt)
+                           '()
+                           (cons (make-BasicBlock 
+                                  name  
+                                  (if last-stmt-goto? 
+                                      (reverse acc)
+                                      (reverse (append `(,(make-GotoStatement 
+                                                           (make-Label (PairedLabel-label first-stmt))))
+                                                       acc))))
+                                 basic-blocks)
+                           (cdr stmts)
+                           last-stmt-goto?)]
+                    [else
+                     (loop name
+                           acc
+                           basic-blocks
+                           (cdr stmts)
+                           last-stmt-goto?)])]
+                 
+                 [else
+                  (loop name
+                        (cons first-stmt acc)
+                        basic-blocks
+                        (cdr stmts)
+                        (GotoStatement? first-stmt))]))]))))
+
+
+
+(: collect-paired-labels ((Listof Statement) -> (Listof PairedLabel)))
+(define (collect-paired-labels stmts)
+  (cond
+    [(empty? stmts)
+     empty]
+    [else
+     (let ([first-stmt (first stmts)])
+       (cond
+         [(PairedLabel? first-stmt)
+          (cons first-stmt (collect-paired-labels (rest stmts)))]
+         [else
+          (collect-paired-labels (rest stmts))]))]))
+
+
+;; collect-general-jump-targets: (listof stmt) -> (listof label)
+;; collects all the labels that are potential targets for GOTOs or branches.
+(: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol)))
+(define (collect-general-jump-targets stmts)
+  (: collect-input (OpArg -> (Listof Symbol)))
+  (define (collect-input an-input)
+    (cond
+      [(Reg? an-input)
+       empty]
+      [(Const? an-input)
+       empty]
+      [(Label? an-input)
+       (list (Label-name an-input))]
+      [(EnvLexicalReference? an-input)
+       empty]
+      [(EnvPrefixReference? an-input)
+       empty]
+      [(EnvWholePrefixReference? an-input)
+       empty]))
+  
+  (: collect-location ((U Reg Label) -> (Listof Symbol)))
+  (define (collect-location a-location)
+    (cond
+      [(Reg? a-location)
+       empty]
+      [(Label? a-location)
+       (list (Label-name a-location))]))
+  
+  (: collect-primitive-operator (PrimitiveOperator -> (Listof Symbol)))
+  (define (collect-primitive-operator op)
+    (cond
+      [(GetCompiledProcedureEntry? op)
+       empty]
+      [(MakeCompiledProcedure? op)
+       (list (MakeCompiledProcedure-label op))]
+      [(MakeCompiledProcedureShell? op)
+       (list (MakeCompiledProcedureShell-label op))]
+      [(ApplyPrimitiveProcedure? op)
+       empty]
+      [(GetControlStackLabel? op)
+       empty]
+      [(CaptureEnvironment? op)
+       empty]
+      [(CaptureControl? op)
+       empty]
+      [(MakeBoxedEnvironmentValue? op)
+       empty]
+      [(CallKernelPrimitiveProcedure? op)
+       empty]))
+  
+  (: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
+  (define (collect-primitive-command op)
+    (cond
+      [(CheckToplevelBound!? op)
+       empty]
+      [(CheckClosureArity!? op)
+       empty]
+      [(ExtendEnvironment/Prefix!? op)
+       empty]
+      [(InstallClosureValues!? op)
+       empty]
+      [(RestoreEnvironment!? op)
+       empty]
+      [(RestoreControl!? op)
+       empty]
+      [(FixClosureShellMap!? op)
+       empty]))
+  
+  (unique/eq?
+   (let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
+         (cond [(empty? stmts)
+                empty]
+               [else
+                (let ([stmt (first stmts)])
+                  (append (cond
+                            [(symbol? stmt)
+                             empty]
+                            [(PairedLabel? stmt)
+                             (list (PairedLabel-previous stmt))]
+                            [(AssignImmediateStatement? stmt)
+                             (let: ([v : OpArg (AssignImmediateStatement-value stmt)])
+                                   (cond 
+                                     [(Reg? v)
+                                      empty]
+                                     [(Label? v)
+                                      (list (Label-name v))]
+                                     [(Const? v)
+                                      empty]
+                                     [(EnvLexicalReference? v)
+                                      empty]
+                                     [(EnvPrefixReference? v)
+                                      empty] 
+                                     [(EnvWholePrefixReference? v)
+                                      empty]))]
+                            [(AssignPrimOpStatement? stmt)
+                             (collect-primitive-operator (AssignPrimOpStatement-op stmt))]
+                            [(PerformStatement? stmt)
+                             (collect-primitive-command (PerformStatement-op stmt))]
+                            [(TestAndBranchStatement? stmt)
+                             (list (TestAndBranchStatement-label stmt))]
+                            [(GotoStatement? stmt)
+                             (collect-location (GotoStatement-target stmt))]
+                            [(PushEnvironment? stmt)
+                             empty]
+                            [(PopEnvironment? stmt)
+                             empty]
+                            [(PushControlFrame? stmt)
+                             (list (PushControlFrame-label stmt))]
+                            [(PushControlFrame/Prompt? stmt)
+                             (list (PushControlFrame/Prompt-label stmt))]
+                            [(PopControlFrame? stmt)
+                             empty]
+                            [(PopControlFrame/Prompt? stmt)
+                             empty])
+                          (loop (rest stmts))))]))))
+
+
+
+
+;; assemble-basic-block: basic-block -> string
+(: assemble-basic-block (BasicBlock -> String))
+(define (assemble-basic-block a-basic-block)
+  (format "var ~a=function(MACHINE){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"
+          (BasicBlock-name a-basic-block)
+          (BasicBlock-name a-basic-block)
+          (string-join (map assemble-statement (BasicBlock-stmts a-basic-block))
+                       "\n")))
+
+
+
+
+(: assemble-statement (UnlabeledStatement -> String))
+;; Generates the code to assemble a statement.
+(define (assemble-statement stmt)
+  (string-append 
+   (if (current-emit-debug-trace?)
+       (format "if (typeof(window.console) !== 'undefined' && typeof(console.log) === 'function') { console.log(~s);\n}"
+               (format "~a" stmt))
+       "")
+   (cond
+     [(AssignImmediateStatement? stmt)
+      (let ([t (assemble-target (AssignImmediateStatement-target stmt))]
+            [v (AssignImmediateStatement-value stmt)])
+        (format "~a = ~a;" t (assemble-oparg v)))]
+     
+     [(AssignPrimOpStatement? stmt)
+      (format "~a=~a;" 
+              (assemble-target (AssignPrimOpStatement-target stmt))
+              (assemble-op-expression (AssignPrimOpStatement-op stmt)))]
+     
+     [(PerformStatement? stmt)
+      (assemble-op-statement (PerformStatement-op stmt))]
+     
+     [(TestAndBranchStatement? stmt)
+      (let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
+             (cond
+               [(eq? test 'false?)
+                (format "if (! ~a) { ~a }"
+                        (assemble-reg (make-Reg (TestAndBranchStatement-register stmt)))
+                        (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
+               [(eq? test 'primitive-procedure?)
+                (format "if (typeof(~a) === 'function') { ~a };"
+                        (assemble-reg (make-Reg (TestAndBranchStatement-register stmt)))
+                        (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]))]
+     
+     [(GotoStatement? stmt)
+      (assemble-jump (GotoStatement-target stmt))]
+
+     [(PushControlFrame? stmt)
+      (format "MACHINE.control.push(new RUNTIME.CallFrame(~a, MACHINE.proc));" (PushControlFrame-label stmt))]
+     [(PushControlFrame/Prompt? stmt)
+      ;; fixme: use a different frame structure
+      (format "MACHINE.control.push(new RUNTIME.PromptFrame(~a, ~a));" 
+              (PushControlFrame/Prompt-label stmt)
+              (let ([tag (PushControlFrame/Prompt-tag stmt)])
+                (cond
+                  [(DefaultContinuationPromptTag? tag)
+                   (assemble-default-continuation-prompt-tag)]
+                  [(OpArg? tag)
+                   (assemble-oparg tag)])))]
+     [(PopControlFrame? stmt)
+      "MACHINE.control.pop();"]
+     [(PopControlFrame/Prompt? stmt)
+      "MACHINE.control.pop();"]
+     [(PushEnvironment? stmt)
+      (format "MACHINE.env.push(~a);" (string-join
+                                       (build-list (PushEnvironment-n stmt) 
+                                                   (lambda: ([i : Natural])
+                                                            (if (PushEnvironment-unbox? stmt)
+                                                                "[undefined]"
+                                                                "undefined")))
+                                       ", "))]
+     [(PopEnvironment? stmt)
+      (if (= (PopEnvironment-skip stmt) 0)
+          (format "MACHINE.env.length = MACHINE.env.length - ~a;"
+                  (PopEnvironment-n stmt))
+          (format "MACHINE.env.splice(MACHINE.env.length-(~a),~a);"
+                  (+ (PopEnvironment-skip stmt)
+                     (PopEnvironment-n stmt))
+                  (PopEnvironment-n stmt)))])))
+
+
+
+(: assemble-jump ((U Label Reg) -> String))
+(define (assemble-jump target)
+  (format "return (~a)(MACHINE);" (assemble-location target)))
+
+
+
+
+
+
+
+
+(: assemble-env-reference/closure-capture (Natural -> String))
+;; When we're capturing the values for a closure, we need to not unbox
+;; lexical references: they must remain boxes.  So all we need is 
+;; the depth into the environment.
+(define (assemble-env-reference/closure-capture depth)
+  (format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
+          depth))
+
+
+(: assemble-display-name ((U Symbol False) -> String))
+(define (assemble-display-name symbol-or-string)
+  (if (symbol? symbol-or-string)
+      (format "~s" (symbol->string symbol-or-string))
+      "false"))
+
+(: assemble-op-expression (PrimitiveOperator -> String))
+(define (assemble-op-expression op)
+  (cond
+    [(GetCompiledProcedureEntry? op)
+     "MACHINE.proc.label"]
+    
+    [(MakeCompiledProcedure? op)
+     (format "new RUNTIME.Closure(~a, ~a, [~a], ~a)"
+             (MakeCompiledProcedure-label op)
+             (MakeCompiledProcedure-arity op)
+             (string-join (map assemble-env-reference/closure-capture 
+                               ;; The closure values are in reverse order
+                               ;; to make it easier to push, in bulk, into
+                               ;; the environment (which is also in reversed order)
+                               ;; during install-closure-values.
+                               (reverse (MakeCompiledProcedure-closed-vals op)))
+                          ", ")
+             (assemble-display-name (MakeCompiledProcedure-display-name op)))]
+    
+    [(MakeCompiledProcedureShell? op)
+     (format "new RUNTIME.Closure(~a, ~a, undefined, ~a)"
+             (MakeCompiledProcedureShell-label op)
+             (MakeCompiledProcedureShell-arity op)
+             (assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
+    
+    [(ApplyPrimitiveProcedure? op)
+     (format "MACHINE.proc(MACHINE, ~a)"
+             (ApplyPrimitiveProcedure-arity op))]
+    
+    [(GetControlStackLabel? op)
+     (format "MACHINE.control[MACHINE.control.length-1].label")]
+    
+    [(CaptureEnvironment? op)
+     (format "MACHINE.env.slice(0, MACHINE.env.length - ~a)"
+             (CaptureEnvironment-skip op))]
+    
+    [(CaptureControl? op)
+     (format "RUNTIME.captureControl(MACHINE, ~a, ~a)"
+             (CaptureControl-skip op)
+             (let ([tag (CaptureControl-tag op)])
+               (cond [(DefaultContinuationPromptTag? tag)
+                      (assemble-default-continuation-prompt-tag)]
+                     [(OpArg? tag)
+                      (assemble-oparg tag)])))]
+
+    
+    [(MakeBoxedEnvironmentValue? op)
+     (format "[MACHINE.env[MACHINE.env.length - 1 - ~a]]"
+             (MakeBoxedEnvironmentValue-depth op))]
+
+    [(CallKernelPrimitiveProcedure? op)
+     (open-code-kernel-primitive-procedure op)]))
+
+
+(: assemble-default-continuation-prompt-tag (-> String))
+(define (assemble-default-continuation-prompt-tag)
+  "RUNTIME.DEFAULT_CONTINUATION_PROMPT_TAG")
+
+
+
+
+
+(: assemble-op-statement (PrimitiveCommand -> String))
+(define (assemble-op-statement op)  
+  (cond 
+    
+    [(CheckToplevelBound!? op)
+     (format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { throw new Error(\"Not bound: \" + MACHINE.env[MACHINE.env.length - 1 - ~a].names[~a]); }"
+             (CheckToplevelBound!-depth op)
+             (CheckToplevelBound!-pos op)
+             (CheckToplevelBound!-depth op)
+             (CheckToplevelBound!-pos op))]
+    
+    [(CheckClosureArity!? op)
+     (format "if (! (MACHINE.proc instanceof RUNTIME.Closure && MACHINE.proc.arity === ~a)) { if (! (MACHINE.proc instanceof RUNTIME.Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure\"); } }"
+             (CheckClosureArity!-arity op))]
+    
+    [(ExtendEnvironment/Prefix!? op)
+     (let: ([names : (Listof (U Symbol False ModuleVariable)) (ExtendEnvironment/Prefix!-names op)])
+           (format "MACHINE.env.push([~a]);  MACHINE.env[MACHINE.env.length-1].names = [~a];"
+                   (string-join (map (lambda: ([n : (U Symbol False ModuleVariable)])
+                                              (cond [(symbol? n)
+                                                     (format "MACHINE.params.currentNamespace[~s] || MACHINE.primitives[~s]"
+                                                             (symbol->string n) 
+                                                             (symbol->string n))]
+                                                    [(eq? n #f)
+                                                     "false"]
+                                                    [(ModuleVariable? n)
+                                                     (format "MACHINE.primitives[~s]"
+                                                             (symbol->string (ModuleVariable-name n)))]))
+                                     names)
+                                ",")
+                   (string-join (map (lambda: ([n : (U Symbol False ModuleVariable)])
+                                              (cond
+                                                [(symbol? n)
+                                                 (format "~s" (symbol->string n))]
+                                                [(eq? n #f)
+                                                 "false"]
+                                                [(ModuleVariable? n)
+                                                 (format "~s" (symbol->string (ModuleVariable-name n)))]))
+                                     names)
+                                ",")))]
+    
+    [(InstallClosureValues!? op)
+     "MACHINE.env.splice.apply(MACHINE.env, [MACHINE.env.length, 0].concat(MACHINE.proc.closedVals));"]
+    [(RestoreEnvironment!? op)
+     "MACHINE.env = MACHINE.env[MACHINE.env.length - 2].slice(0);"]
+    [(RestoreControl!? op)
+     (format "RUNTIME.restoreControl(MACHINE, ~a);"
+             (let ([tag (RestoreControl!-tag op)])
+               (cond
+                 [(DefaultContinuationPromptTag? tag)
+                  (assemble-default-continuation-prompt-tag)]
+                 [(OpArg? tag)
+                  (assemble-oparg tag)])))]
+    [(FixClosureShellMap!? op)
+     (format "MACHINE.env[MACHINE.env.length - 1 - ~a].closedVals = [~a]"
+             (FixClosureShellMap!-depth op)
+              (string-join (map assemble-env-reference/closure-capture 
+                               ;; The closure values are in reverse order
+                               ;; to make it easier to push, in bulk, into
+                               ;; the environment (which is also in reversed order)
+                               ;; during install-closure-values.
+                               (reverse (FixClosureShellMap!-closed-vals op)))
+                          ", "))]))
+
+
+
+(: assemble-location ((U Reg Label) -> String))
+(define (assemble-location a-location)
+  (cond
+    [(Reg? a-location)
+     (assemble-reg a-location)]
+    [(Label? a-location)
+     (assemble-label a-location)]))
+
+
+(: assemble-paired-label (PairedLabel Output-Port -> 'ok))
+;; Write out the code to make it easy to jump to the previous label.
+(define (assemble-paired-label a-paired-label op)
+  (fprintf op "~a.predecessor = ~a;"
+           (PairedLabel-label a-paired-label)
+           (PairedLabel-previous a-paired-label))
+  'ok)

bootstrapped-primitives.rkt

@@ -0,0 +1,155 @@
+#lang typed/racket/base
+(require "expression-structs.rkt"
+         "lexical-structs.rkt"
+         "il-structs.rkt"
+         "compile.rkt"
+         "typed-parse.rkt"
+         "parameters.rkt")
+
+
+(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 default-continuation-prompt-tag))
+       ,(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 0 1)
+                                                                'call/cc))
+       ,(make-PopEnvironment 2 0)))
+    
+    ;; Finally, do a tail call into f.
+    (compile-general-procedure-call '()
+                                    '(?)
+                                    1 
+                                    'val
+                                    return-linkage)
+    
+    ;; The code for the continuation code 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! default-continuation-prompt-tag))
+                                 ,(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-linkage))))
+
+
+
+
+
+(: 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

@@ -0,0 +1,401 @@
+#lang racket/base
+
+(require racket/list
+         web-server/servlet
+         web-server/servlet-env)
+
+
+;; A hacky way to test the evaluation.
+;;
+;; Sets up a web server and opens a browser window.
+;; The page on screen periodically polls the server to see if a program has
+;; come in to be evaluated.  Whenever code does come in, evaluates and returns the
+;; value to the user, along with the time it took to evaluate.
+
+
+(provide make-evaluate
+         (struct-out error-happened)
+         (struct-out evaluated))
+
+
+
+(define-struct error-happened (str t) #:transparent)
+(define-struct evaluated (stdout value t
+                                 browser) #:transparent)
+
+
+
+;; make-evaluate: (Any output-port) -> void
+;; Produce a JavaScript evaluator that cooperates with a browser.
+;; The JavaScript-compiler is expected to write out a thunk.  When invoked,
+;; the thunk should return a function that consumes three values, corresponding
+;; to success, failure, and other parameters to evaluation.  For example:
+;;
+;; (make-evaluate (lambda (program op)
+;;                          (fprintf op "(function() {
+;;                                            return function(success, fail, params) {
+;;                                                       success('ok');
+;;                                            }})")))
+;;
+;; is a do-nothing evaluator that will always give back 'ok'. 
+;;
+;; At the moment, the evaluator will pass in a parameter that binds 'currentDisplayer' to a function
+;; that captures output.
+(define (make-evaluate javascript-compiler)
+  (define port (+ 8000 (random 8000)))
+  
+  
+  ;; This channel's meant to serialize use of the web server.
+  (define ch (make-channel))
+  
+  
+  ;; start up the web server
+  ;; The web server responds to two types of requests
+  ;; ?comet    Starting up the comet request path.
+  ;; ?v       Getting a value back from evaluation.
+  ;; ?e       Got an error.
+  (void
+   (thread (lambda ()
+             (define (start req)
+               (cond
+                 ;; Server-side sync for a program
+                 [(exists-binding? 'comet (request-bindings req))
+                  (handle-comet req)]
+                 
+                 ;; Normal result came back
+                 [(exists-binding? 'v (request-bindings req))
+                  (handle-normal-response req)]
+                 
+                 ;; Error occurred
+                 [(exists-binding? 'e (request-bindings req))
+                  (handle-error-response req)]
+                 
+                 [else
+                  (make-on-first-load-response)]))
+             
+             
+             (serve/servlet start 
+                            #:banner? #f
+                            #:launch-browser? #t
+                            #:quit? #f
+                            #:port port
+                            #:servlet-path "/eval"))))
+  
+  
+  (define *alarm-timeout* 30000)
+  
+  (define (handle-comet req)
+    (let/ec return
+      (let* ([alarm (alarm-evt (+ (current-inexact-milliseconds) *alarm-timeout*))]
+             [program (sync ch alarm)]
+             [op (open-output-bytes)])
+        (cond
+          [(eq? program alarm)
+           (try-again-response)]
+          [else
+           (with-handlers ([exn:fail? (lambda (exn)
+                                        (let ([sentinel
+                                               (format
+                                                #<<EOF
+(function () {
+    return function(success, fail, params) {
+        fail(~s);
+    }
+ });
+EOF
+                                                (exn-message exn))])
+                                          
+                                          (return 
+                                           (response/full 200 #"Okay"
+                                                          (current-seconds)
+                                                          #"text/plain; charset=utf-8"
+                                                          empty
+                                                          (list #"" (string->bytes/utf-8 sentinel))))))])
+             (javascript-compiler program op))
+           
+           (response/full 200 #"Okay" 
+                          (current-seconds) 
+                          #"text/plain; charset=utf-8"
+                          empty 
+                          (list #"" (get-output-bytes op)))]))))
+
+  
+  (define (try-again-response)
+    (response/full 200 #"Try again"
+                   (current-seconds)
+                   #"text/plain; charset=utf-8"
+                   empty
+                   (list #"" #"")))
+  
+  (define (ok-response)
+    (response/full 200 #"Okay"
+                   (current-seconds)
+                   TEXT/HTML-MIME-TYPE
+                   empty
+                   (list #"" #"<html><head></head><body><p>ok</p></body></html>")))
+  
+  
+  
+  (define (handle-normal-response req)
+    (channel-put ch (make-evaluated (extract-binding/single 'o (request-bindings req))
+                                    (extract-binding/single 'v (request-bindings req))
+                                    (string->number
+                                     (extract-binding/single 't (request-bindings req)))
+                                    (extract-binding/single 'b (request-bindings req))))
+    (ok-response))
+  
+  
+  (define (handle-error-response req)
+    (channel-put ch (make-error-happened 
+                     (extract-binding/single 'e (request-bindings req))
+                     (string->number
+                      (extract-binding/single 't (request-bindings req)))))
+    (ok-response))
+  
+  
+  (define (make-on-first-load-response)
+    (let ([op (open-output-bytes)])
+      (fprintf op #<<EOF
+<html>
+<head>
+<script>
+// http://www.quirksmode.org/js/xmlhttp.html
+//
+// XMLHttpRequest wrapper.  Transparently restarts the request
+// if a timeout occurs.
+function sendRequest(url,callback,postData) {
+	var req = createXMLHTTPObject(), method;
+
+	if (!req) return;
+	method = (postData) ? "POST" : "GET";
+	req.open(method,url,true);
+	if (postData) {
+  	    req.setRequestHeader('Content-type','application/x-www-form-urlencoded');
+        }
+	req.onreadystatechange = function () {
+		if (req.readyState != 4) return;
+		if (req.status !== 200 && req.status !== 304) {
+			return;
+		}
+                if (req.status === 200 && req.statusText === 'Try again') {
+                   req.abort();
+                   setTimeout(function() { sendRequest(url, callback, postData); }, 0);
+                   return;
+                }
+		callback(req);
+	}
+	if (req.readyState == 4) return;
+	req.send(postData);
+}
+
+var XMLHttpFactories = [
+	function () {return new XMLHttpRequest()},
+	function () {return new ActiveXObject("Msxml2.XMLHTTP")},
+	function () {return new ActiveXObject("Msxml3.XMLHTTP")},
+	function () {return new ActiveXObject("Microsoft.XMLHTTP")}
+];
+
+function createXMLHTTPObject() {
+	var xmlhttp = false;
+	for (var i=0;i<XMLHttpFactories.length;i++) {
+		try {
+			xmlhttp = XMLHttpFactories[i]();
+		}
+		catch (e) {
+			continue;
+		}
+		break;
+	}
+	return xmlhttp;
+}
+
+var comet = function() {
+    sendRequest("/eval", 
+                function(req) {
+                    // debug:
+                    if (window.console && typeof(console.log) === 'function') { console.log(req.responseText); }
+
+                    var invoke = eval(req.responseText)();
+                    var output = [];
+                    var startTime, endTime;
+                    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();
+                        sendRequest("/eval", function(req) { setTimeout(comet, 0); },
+                            "v=" + encodeURIComponent(String(v)) +
+                            "&o=" + encodeURIComponent(output.join('')) +
+                            "&t=" + encodeURIComponent(String(endTime - startTime)) +
+                            "&b=" + encodeURIComponent(String(BrowserDetect.browser + ' ' + BrowserDetect.version + '/' + BrowserDetect.OS)));
+                    };
+
+                    var onFail = function(machine, e) {
+                        endTime = new Date();
+                        sendRequest("/eval", function(req) { setTimeout(comet, 0); },
+                            "e=" + encodeURIComponent(String(e)) +
+                            "&t=" + encodeURIComponent(String(endTime - startTime)));
+                    };
+                    startTime = new Date();
+                    invoke(onSuccess, onFail, params);
+                },
+                "comet=t");
+};
+
+var BrowserDetect = {
+	init: function () {
+		this.browser = this.searchString(this.dataBrowser) || "An unknown browser";
+		this.version = this.searchVersion(navigator.userAgent)
+			|| this.searchVersion(navigator.appVersion)
+			|| "an unknown version";
+		this.OS = this.searchString(this.dataOS) || "an unknown OS";
+	},
+	searchString: function (data) {
+		for (var i=0;i<data.length;i++)	{
+			var dataString = data[i].string;
+			var dataProp = data[i].prop;
+			this.versionSearchString = data[i].versionSearch || data[i].identity;
+			if (dataString) {
+				if (dataString.indexOf(data[i].subString) != -1)
+					return data[i].identity;
+			}
+			else if (dataProp)
+				return data[i].identity;
+		}
+	},
+	searchVersion: function (dataString) {
+		var index = dataString.indexOf(this.versionSearchString);
+		if (index == -1) return;
+		return parseFloat(dataString.substring(index+this.versionSearchString.length+1));
+	},
+	dataBrowser: [
+		{
+			string: navigator.userAgent,
+			subString: "Chrome",
+			identity: "Chrome"
+		},
+		{ 	string: navigator.userAgent,
+			subString: "OmniWeb",
+			versionSearch: "OmniWeb/",
+			identity: "OmniWeb"
+		},
+		{
+			string: navigator.vendor,
+			subString: "Apple",
+			identity: "Safari",
+			versionSearch: "Version"
+		},
+		{
+			prop: window.opera,
+			identity: "Opera"
+		},
+		{
+			string: navigator.vendor,
+			subString: "iCab",
+			identity: "iCab"
+		},
+		{
+			string: navigator.vendor,
+			subString: "KDE",
+			identity: "Konqueror"
+		},
+		{
+			string: navigator.userAgent,
+			subString: "Firefox",
+			identity: "Firefox"
+		},
+		{
+			string: navigator.vendor,
+			subString: "Camino",
+			identity: "Camino"
+		},
+		{		// for newer Netscapes (6+)
+			string: navigator.userAgent,
+			subString: "Netscape",
+			identity: "Netscape"
+		},
+		{
+			string: navigator.userAgent,
+			subString: "MSIE",
+			identity: "Explorer",
+			versionSearch: "MSIE"
+		},
+		{
+			string: navigator.userAgent,
+			subString: "Gecko",
+			identity: "Mozilla",
+			versionSearch: "rv"
+		},
+		{ 		// for older Netscapes (4-)
+			string: navigator.userAgent,
+			subString: "Mozilla",
+			identity: "Netscape",
+			versionSearch: "Mozilla"
+		}
+	],
+	dataOS : [
+		{
+			string: navigator.platform,
+			subString: "Win",
+			identity: "Windows"
+		},
+		{
+			string: navigator.platform,
+			subString: "Mac",
+			identity: "Mac"
+		},
+		{
+			   string: navigator.userAgent,
+			   subString: "iPhone",
+			   identity: "iPhone/iPod"
+	    },
+		{
+			string: navigator.platform,
+			subString: "Linux",
+			identity: "Linux"
+		}
+	]
+
+};
+BrowserDetect.init();
+
+
+var whenLoaded = function() {
+    setTimeout(comet, 0);
+};
+
+</script>
+</head>
+<body onload="whenLoaded()">
+<p>Harness loaded.  Do not close this window.</p>
+</body>
+</html>
+EOF
+               )
+      (response/full 200 #"Okay" 
+                     (current-seconds) 
+                     TEXT/HTML-MIME-TYPE
+                     empty 
+                     (list #"" (get-output-bytes op)))))
+  
+  
+  
+  ;; evaluate: sexp -> (values string number)
+  ;; A little driver to test the evalution of expressions, using a browser to help.
+  ;; Returns the captured result of stdout, plus # of milliseconds it took to execute.
+  (define (evaluate e)
+    ;; Send the program to the web browser, and wait for the thread to send back
+    (channel-put ch e)
+    (let ([result (channel-get ch)])
+      (cond [(error-happened? result)
+             (raise result)]
+            [else
+             result])))
+  
+
+  evaluate)

experiment.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+(require compiler/decompile
+         compiler/zo-parse)
+
+;; A little bit of code to see how Racket really compiles code.
+
+(require scheme/pretty)
+
+(provide try)
+
+(define (try e)
+  (let ([out (open-output-bytes)])
+    (write (parameterize ([current-namespace (make-base-namespace)])
+			 (compile e))
+	   out)
+    (let ([inp (open-input-bytes (get-output-bytes out))])
+
+      (pretty-print
+       (zo-parse inp)))))
+

expression-structs.rkt

@@ -0,0 +1,83 @@
+#lang typed/racket/base
+(require "lexical-structs.rkt")
+
+(provide (all-defined-out))
+
+;; Expressions
+
+(define-type Expression (U Top Constant 
+                               ToplevelRef LocalRef
+                               ToplevelSet
+                               Branch Lam Seq Splice App
+                               Let1 
+                               LetVoid 
+                               LetRec
+                               InstallValue
+                               BoxEnv))
+
+(define-struct: Top ([prefix : Prefix]
+                     [code : Expression]) #:transparent)
+
+(define-struct: Constant ([v : Any]) #:transparent)
+
+(define-struct: ToplevelRef ([depth : Natural]
+                             [pos : Natural])
+  #:transparent)
+
+(define-struct: LocalRef ([depth : Natural]
+                          [unbox? : Boolean])
+  #:transparent)
+
+(define-struct: ToplevelSet ([depth : Natural]
+                             [pos : Natural]
+                             [name : Symbol] 
+                             [value : Expression]) #:transparent)
+
+(define-struct: Branch ([predicate : Expression]
+                        [consequent : Expression]
+                        [alternative : Expression]) #:transparent)
+
+(define-struct: Lam ([name : (U Symbol False)]
+                     [num-parameters : Natural]
+                     [body : Expression]
+                     [closure-map : (Listof Natural)]
+                     [entry-label : Symbol]) #:transparent)
+
+(define-struct: Seq ([actions : (Listof Expression)]) #:transparent)
+(define-struct: Splice ([actions : (Listof Expression)]) #:transparent)
+(define-struct: App ([operator : Expression]
+                     [operands : (Listof Expression)]) #:transparent)
+
+(define-struct: Let1 ([rhs : Expression]
+                      [body : Expression])
+  #:transparent)
+(define-struct: LetVoid ([count : Natural]
+                         [body : Expression]
+                         [boxes? : Boolean])
+  #:transparent)
+
+(define-struct: LetRec ([procs : (Listof Lam)]
+                        [body : Expression])
+  #:transparent)
+
+(define-struct: InstallValue ([depth : Natural]
+                              [body : Expression]
+                              [box? : Boolean])
+  #:transparent)
+
+
+(define-struct: BoxEnv ([depth : Natural]
+                        [body : Expression])
+  #:transparent)
+
+
+
+(: last-exp? ((Listof Expression) -> Boolean))
+(define (last-exp? seq) 
+  (null? (cdr seq)))
+
+(: first-exp ((Listof Expression) -> Expression))
+(define (first-exp seq) (car seq))
+
+(: rest-exps ((Listof Expression) -> (Listof Expression)))
+(define (rest-exps seq) (cdr seq))

il-structs.rkt

@@ -0,0 +1,377 @@
+#lang typed/racket/base
+(provide (all-defined-out))
+
+(require "lexical-structs.rkt"
+         "kernel-primitives.rkt")
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Registers of the machine:
+
+(define-type StackRegisterSymbol (U 'control 'env))
+(define-type AtomicRegisterSymbol (U 'val 'proc))
+(define-type RegisterSymbol (U StackRegisterSymbol AtomicRegisterSymbol))
+
+(define-predicate AtomicRegisterSymbol? AtomicRegisterSymbol)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; An operation can refer to the following arguments:
+(define-type OpArg (U Const ;; an constant
+                      Label ;; an label
+                      Reg   ;; an register 
+                      EnvLexicalReference ;; a reference into the stack
+                      EnvPrefixReference  ;; a reference into an element in the toplevel.
+                      EnvWholePrefixReference ;; a reference into a toplevel prefix in the stack.
+                      ))
+
+
+;; Targets: these are the allowable lhs's for an assignment.
+(define-type Target (U AtomicRegisterSymbol 
+                       EnvLexicalReference
+                       EnvPrefixReference
+                       PrimitivesReference))
+
+
+
+(define-struct: Label ([name : Symbol])
+  #:transparent)
+(define-struct: Reg ([name : AtomicRegisterSymbol])
+  #:transparent)
+(define-struct: Const ([const : Any])
+  #:transparent)
+
+
+
+(define-struct: PrimitivesReference ([name : Symbol])
+  #:transparent)
+
+
+
+
+  
+
+
+;; instruction sequences
+(define-type UnlabeledStatement (U 
+                                 
+                                 AssignImmediateStatement
+                                 AssignPrimOpStatement
+                                 
+                                 PerformStatement
+                                 
+                                 GotoStatement
+                                 TestAndBranchStatement
+                                 
+                                 PopEnvironment
+                                 PushEnvironment
+                                 PushControlFrame
+                                 PushControlFrame/Prompt
+
+                                 PopControlFrame
+                                 PopControlFrame/Prompt))
+
+(define-type Statement (U UnlabeledStatement
+                          Symbol  ;; label
+                          PairedLabel
+                          ))
+
+(define-struct: AssignImmediateStatement ([target : Target]
+                                          [value : OpArg])
+  #:transparent)
+(define-struct: AssignPrimOpStatement ([target : Target]
+                                       [op : PrimitiveOperator])
+  #:transparent)
+
+
+;; Pop n slots from the environment, skipping past a few first.
+(define-struct: PopEnvironment ([n : Natural]
+                                [skip : Natural])
+  #:transparent)
+(define-struct: PushEnvironment ([n : Natural]
+                                 [unbox? : Boolean])
+  #:transparent)
+
+
+(define-struct: PopControlFrame () 
+  #:transparent)
+(define-struct: PopControlFrame/Prompt () 
+  #:transparent)
+
+;; Adding a frame for getting back after procedure application.
+;; The 'proc register must hold either #f or a closure at the time of
+;; this call, as the control frame will hold onto the called procedure record.
+(define-struct: PushControlFrame ([label : Symbol]) 
+  #:transparent)
+
+(define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
+                                         [label : Symbol]
+                                         ;; TODO: add handler and arguments
+                                         )
+  #:transparent)
+
+(define-struct: DefaultContinuationPromptTag ()
+  #:transparent)
+(define default-continuation-prompt-tag 
+  (make-DefaultContinuationPromptTag))
+
+
+
+
+(define-struct: GotoStatement ([target : (U Label Reg)]) 
+  #:transparent)
+
+(define-struct: PerformStatement ([op : PrimitiveCommand])
+  #:transparent)
+
+(define-struct: TestAndBranchStatement ([op : PrimitiveTest]
+                                        [register : AtomicRegisterSymbol]
+                                        [label : Symbol])
+  #:transparent)
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Primitive Operators
+
+;; The operators that return values, that are used in AssignPrimopStatement.
+(define-type PrimitiveOperator (U GetCompiledProcedureEntry
+                                  MakeCompiledProcedure
+                                  MakeCompiledProcedureShell
+                                  ApplyPrimitiveProcedure
+
+                                  GetControlStackLabel
+                                  MakeBoxedEnvironmentValue
+
+                                  CaptureEnvironment
+                                  CaptureControl
+                                  
+                                  CallKernelPrimitiveProcedure))
+
+;; Gets the label from the closure stored in the 'proc register and returns it.
+(define-struct: GetCompiledProcedureEntry ()
+  #:transparent)
+
+;; Constructs a closure, given the label, # of expected arguments,
+;; and the set of lexical references into the environment that the
+;; closure needs to close over.
+(define-struct: MakeCompiledProcedure ([label : Symbol]
+                                       [arity : Natural]
+                                       [closed-vals : (Listof Natural)]
+                                       [display-name : (U Symbol False)])
+  #:transparent)
+
+;; Constructs a closure shell.  Like MakeCompiledProcedure, but doesn't
+;; bother with trying to capture the free variables.
+(define-struct: MakeCompiledProcedureShell ([label : Symbol]
+                                            [arity : Natural]
+                                            [display-name : (U Symbol False)])
+  #:transparent)
+
+
+;; Applies the primitive procedure that's stored in the proc register, using
+;; the arity number of values that are bound in the environment as arguments
+;; to that primitive.
+(define-struct: ApplyPrimitiveProcedure ([arity : Natural])
+  #:transparent)
+
+
+
+
+
+
+
+(define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName]
+
+                                              [operands : (Listof OpArg)]
+                                              [expected-operand-types : (Listof OperandDomain)]
+                                              ;; For each operand, #t will add code to typecheck the operand
+                                              [typechecks? : (Listof Boolean)])
+  #:transparent)
+
+
+
+;; Gets the return address embedded at the top of the control stack.
+(define-struct: GetControlStackLabel ()
+  #:transparent)
+
+(define-struct: MakeBoxedEnvironmentValue ([depth : Natural])
+  #:transparent)
+
+
+;; Capture the current environment, skipping skip frames.
+(define-struct: CaptureEnvironment ([skip : Natural]))
+
+;; Capture the control stack, skipping skip frames.
+(define-struct: CaptureControl ([skip : Natural]
+                                [tag : (U DefaultContinuationPromptTag OpArg)]))
+
+
+
+
+;; The following is used with TestStatement: each is passed the register-rand and
+;; is expected to
+(define-type PrimitiveTest (U 
+                            ;; register -> boolean
+                            ;; Meant to branch when the register value is false.
+                            'false?
+                            
+                            ;; register -> boolean
+                            ;; Meant to branch when the register value is a primitive
+                            ;; procedure
+                            'primitive-procedure?
+                            ))
+
+
+
+;; Check that the value in the prefix has been defined.
+;; If not, raise an error and stop evaluation.
+(define-struct: CheckToplevelBound! ([depth : Natural]
+                                     [pos : Natural])
+  #:transparent)
+
+;; Check the closure procedure value in 'proc and make sure it can accept n values.
+(define-struct: CheckClosureArity! ([arity : Natural])
+  #:transparent)
+
+;; Extends the environment with a prefix that holds
+;; lookups to the namespace.
+(define-struct: ExtendEnvironment/Prefix! ([names : (Listof (U Symbol ModuleVariable False))])
+  #:transparent)
+
+;; Adjusts the environment by pushing the values in the
+;; closure (held in the proc register) into itself.
+(define-struct: InstallClosureValues! ()
+  #:transparent)
+
+(define-struct: FixClosureShellMap! (;; depth: where the closure shell is located in the environment
+                                     [depth : Natural] 
+                                     
+                                     [closed-vals : (Listof Natural)])
+  #:transparent)
+
+;; Changes over the control located at the given argument from the structure in env[1]
+(define-struct: RestoreControl! ([tag : (U DefaultContinuationPromptTag OpArg)]))
+
+;; Changes over the environment located at the given argument from the structure in env[0]
+(define-struct: RestoreEnvironment! ())
+
+
+
+(define-type PrimitiveCommand (U                                
+                               CheckToplevelBound!
+                               CheckClosureArity!
+                               ExtendEnvironment/Prefix!
+                               InstallClosureValues!
+                               FixClosureShellMap!
+                               
+                               RestoreEnvironment!
+                               RestoreControl!))
+
+
+
+
+(define-type InstructionSequence (U Symbol instruction-sequence))
+(define-struct: instruction-sequence ([statements : (Listof Statement)])
+  #:transparent)
+(define empty-instruction-sequence (make-instruction-sequence '()))
+
+(: make-label (Symbol -> Symbol))
+(define make-label
+  (let ([n 0])
+    (lambda (l)
+      (set! n (add1 n))
+      (string->symbol (format "~a~a" l n)))))
+
+
+(: statements (InstructionSequence -> (Listof Statement)))
+(define (statements s)
+  (if (symbol? s) (list s) (instruction-sequence-statements s)))
+
+
+
+
+
+;; A PairedLabel is like a regular label, but it knows about
+;; a previous label as well.  Used for efficient implementation 
+;; of multiple return values.
+(define-struct: PairedLabel ([label : Symbol]
+                             [previous : Symbol]))
+
+
+
+(: make-paired-labels (Symbol Symbol -> (values Symbol PairedLabel)))
+(define (make-paired-labels first-name second-name)
+  (let* ([first-label (make-label first-name)]
+         [second-label (make-label second-name)])
+  (values first-label (make-PairedLabel second-label first-label))))
+
+
+
+
+
+
+;; Linkage
+(define-struct: NextLinkage ())
+(define next-linkage (make-NextLinkage))
+
+(define-struct: ReturnLinkage ())
+(define return-linkage (make-ReturnLinkage))
+
+(define-struct: PromptLinkage ())
+(define prompt-linkage (make-PromptLinkage))
+
+(define-struct: LabelLinkage ([label : Symbol]))
+
+(define-type Linkage (U NextLinkage
+                        ReturnLinkage
+                        PromptLinkage
+                        LabelLinkage))
+
+
+
+
+
+
+
+
+
+
+
+
+;; Static knowledge about a value
+
+;; We try to keep at compile time a mapping from environment positions to
+;; statically known things, to generate better code.
+(define-struct: StaticallyKnownLam ([name : (U Symbol False)]
+                                    [entry-point : Symbol]
+                                    [arity : Natural]) #:transparent)
+
+(define-type CompileTimeEnvironmentEntry 
+  (U '?          ;; no knowledge
+     Prefix      ;; placeholder: necessary since the toplevel lives in the environment too
+     StaticallyKnownLam ;; The value is a known lam
+     ModuleVariable     ;; The value is a known module variable
+     Const
+     ))
+
+(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Assembly
+
+(define-struct: BasicBlock ([name : Symbol] 
+                            [stmts : (Listof UnlabeledStatement)]) 
+  #:transparent)
+
+
+
+(define-predicate OpArg? OpArg)

info.rkt

@@ -1,2 +0,0 @@
-#lang setup/infotab
-(define collection 'multi)

kernel-primitives.rkt

@@ -0,0 +1,115 @@
+#lang typed/racket/base
+
+(provide (all-defined-out))
+
+
+(define-type OperandDomain (U 'number
+                              'string
+                              'box
+                              'list
+                              'pair
+                              'any))
+
+
+;; The following are primitives that the compiler knows about:
+(define-type KernelPrimitiveName (U '+
+                                    '-
+                                    '*
+                                    '/
+                                    'add1
+                                    'sub1
+                                    '<
+                                    '<=
+                                    '=
+                                    '>
+                                    '>=
+                                    'cons
+                                    'car
+                                    'cdr
+                                    'list
+                                    'null?
+                                    'not
+                                    'eq?
+                                    ))
+(define-predicate KernelPrimitiveName? KernelPrimitiveName)
+
+
+
+(: kernel-primitive-expected-operand-types (KernelPrimitiveName Natural -> (Listof OperandDomain)))
+;; Given a primitive and the number of arguments, produces the list of expected domains.
+;; TODO: do something more polymorphic.
+(define (kernel-primitive-expected-operand-types prim arity)
+  (cond
+    [(eq? prim '+)
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim '-)
+     (unless (> arity 0)
+       (error '- "expects at least one argument, given ~a" arity))
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim '*)
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim '/)
+     (unless (> arity 0)
+       (error '/ "expects at least one argument, given ~a" arity))
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim 'add1)
+     (unless (= arity 1)
+       (error 'add1 "expects exactly one argument, given ~a" arity))
+     (list 'number)]
+    
+    [(eq? prim 'sub1)
+     (unless (= arity 1)
+       (error 'sub1 "expects exactly one argument, given ~a" arity))
+     (list 'number)]
+    
+    [(eq? prim '<)
+     (build-list arity (lambda (i) 'number))]
+    
+    [(eq? prim '<=)
+     (build-list arity (lambda (i) 'number))]
+    
+    [(eq? prim '=)
+     (build-list arity (lambda (i) 'number))]
+    
+    [(eq? prim '>)
+     (build-list arity (lambda (i) 'number))]
+    
+    [(eq? prim '>=)
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim 'cons)
+     (unless (= arity 2)
+       (error 'cons "expects exactly two arguments, given ~a" arity))
+     (list 'any 'any)]
+
+    [(eq? prim 'car)
+     (unless (= arity 1)
+       (error 'car "expects exactly one argument, given ~a" arity))
+     (list 'pair)]
+    
+    [(eq? prim 'cdr)
+     (unless (= arity 1)
+       (error 'cdr "expects exactly one argument, given ~a" arity))
+     (list 'pair)]
+    
+    [(eq? prim 'list)
+     (build-list arity (lambda (i) 'any))]
+    
+    [(eq? prim 'null?)
+     (unless (= arity 1)
+       (error 'null? "expects exactly one argument, given ~a" arity))
+     (list 'any)]
+
+    [(eq? prim 'not)
+     (unless (= arity 1)
+       (error 'not "expects exactly one argument, given ~a" arity))
+     (list 'any)]
+
+    [(eq? prim 'eq?)
+     (unless (= arity 2)
+       (error 'eq? "expects exactly two arguments, given ~a" arity))
+     (list 'any 'any)]))

lexical-env.rkt

@@ -2,7 +2,7 @@
 
 (require racket/list
          "lexical-structs.rkt"
-         "../sets.rkt")
+         "sets.rkt")
 (provide find-variable 
          extend-lexical-environment
          extend-lexical-environment/names
@@ -40,19 +40,17 @@
                  (cond
                    [(Prefix? elt)
                     (let: prefix-loop : LexicalAddress
-                          ([names : (Listof (U False Symbol GlobalBucket ModuleVariable)) (Prefix-names elt)]
-                           [pos : Natural 0])
+                          ([names : (Listof (U Symbol False ModuleVariable)) (Prefix-names elt)]
+                                       [pos : Natural 0])
                           (cond [(empty? names)
                                  (loop (rest cenv) (add1 depth))]
                                 [else
-                                 (let: ([n : (U False Symbol GlobalBucket ModuleVariable) (first names)])
+                                 (let: ([n : (U Symbol False ModuleVariable) (first names)])
                                        (cond
                                          [(and (symbol? n) (eq? name n))
-                                          (make-EnvPrefixReference depth pos #f)]
+                                          (make-EnvPrefixReference depth pos)]
                                          [(and (ModuleVariable? n) (eq? name (ModuleVariable-name n)))
-                                          (make-EnvPrefixReference depth pos #t)]
-                                         [(and (GlobalBucket? n) (eq? name (GlobalBucket-name n)))
-                                          (make-EnvPrefixReference depth pos #f)]
+                                          (make-EnvPrefixReference depth pos)]
                                          [else
                                           (prefix-loop (rest names) (add1 pos))]))]))]
                    
@@ -116,24 +114,21 @@
           cenv))
   
 
+
+
 (: collect-lexical-references ((Listof LexicalAddress) 
                                -> 
                                (Listof (U EnvLexicalReference EnvWholePrefixReference))))
 ;; Given a list of lexical addresses, computes a set of unique references.
 ;; Multiple lexical addresses to a single prefix should be treated identically.
 (define (collect-lexical-references addresses)
-  (let: ([prefix-references : (Setof EnvWholePrefixReference) ((inst new-set EnvWholePrefixReference))]
-         [lexical-references : (Setof EnvLexicalReference) ((inst new-set EnvLexicalReference))])
+  (let: ([prefix-references : (Setof EnvWholePrefixReference) (new-set)]
+         [lexical-references : (Setof EnvLexicalReference) (new-set)])
         (let: loop : (Listof (U EnvLexicalReference EnvWholePrefixReference)) 
               ([addresses : (Listof LexicalAddress) addresses])
               (cond 
                 [(empty? addresses)
-                 (append (set->list prefix-references)
-                         ((inst sort
-				EnvLexicalReference 
-				EnvLexicalReference)
-			  (set->list lexical-references)
-			  lex-reference<?))]
+                 (append (set->list prefix-references) (set->list lexical-references))]
                 [else
                  (let ([addr (first addresses)])
                    (cond
@@ -148,13 +143,6 @@
 
 
 
-(: lex-reference<? (EnvLexicalReference EnvLexicalReference -> Boolean))
-(define (lex-reference<? x y)
-  (< (EnvLexicalReference-depth x)
-     (EnvLexicalReference-depth y)))
-
-
-
 (: lexical-references->compile-time-environment ((Listof EnvReference) ParseTimeEnvironment ParseTimeEnvironment
                                                                      (Listof Symbol)
                                                                        -> ParseTimeEnvironment))
@@ -191,21 +179,16 @@
 ;; Masks elements of the prefix off.
 (define (place-prefix-mask a-prefix symbols-to-keep)
   (make-Prefix
-   (map (lambda: ([n : (U False Symbol GlobalBucket ModuleVariable)])
-                 (cond [(eq? n #f)
-                        n]
-                       [(symbol? n)
+   (map (lambda: ([n : (U Symbol False ModuleVariable)])
+                 (cond [(symbol? n)
                         (if (member n symbols-to-keep)
                             n
                             #f)]
-                       [(GlobalBucket? n)
-                        (if (member (GlobalBucket-name n) symbols-to-keep)
-                            n
-                            #f)]
                        [(ModuleVariable? n)
                         (if (member (ModuleVariable-name n) symbols-to-keep)
                             n
-                            #f)]))
+                            #f)]
+                       [else n]))
         (Prefix-names a-prefix))))
 
 
@@ -218,8 +201,7 @@
                                (EnvLexicalReference-unbox? target))]
     [(EnvPrefixReference? target)
      (make-EnvPrefixReference (+ n (EnvPrefixReference-depth target))
-                              (EnvPrefixReference-pos target)
-                              (EnvPrefixReference-modvar? target))]
+                              (EnvPrefixReference-pos target))]
     [(EnvWholePrefixReference? target)
      (make-EnvWholePrefixReference (+ n (EnvWholePrefixReference-depth target)))]))
 

lexical-structs.rkt

@@ -9,21 +9,11 @@
 
 ;; A toplevel prefix contains a list of toplevel variables.  Some of the
 ;; names may be masked out by #f.
-(define-struct: Prefix ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))])
+(define-struct: Prefix ([names : (Listof (U Symbol ModuleVariable False))])
   #:transparent)
 
-(define-struct: GlobalBucket ([name : Symbol])
-  #:transparent)
-
-
-;; A ModuleLocator is an identifier for a Module.
-(define-struct: ModuleLocator ([name : Symbol]
-                            [real-path : (U Symbol Path)])
-  #:transparent)
-
-
 (define-struct: ModuleVariable ([name : Symbol]
-                                [module-name : ModuleLocator])
+                                [module-path : Symbol])
   #:transparent)
 
 
@@ -53,8 +43,7 @@
   #:transparent)
 
 (define-struct: EnvPrefixReference ([depth : Natural]
-                                    [pos : Natural]
-                                    [modvar? : Boolean])
+                                    [pos : Natural])
   #:transparent)
 
 (define-struct: EnvWholePrefixReference ([depth : Natural])

package.rkt

@@ -0,0 +1,30 @@
+#lang racket/base
+
+(require "compile.rkt"
+         "assemble.rkt"
+         "typed-parse.rkt"
+         "il-structs.rkt"
+         "bootstrapped-primitives.rkt"
+         racket/runtime-path
+         racket/port)
+
+(provide package
+         package-anonymous)
+
+;; Packager: produce single .js files to be included.
+
+;; package: s-expression output-port -> void
+(define (package source-code op)  
+  (fprintf op "var invoke = ")
+  (assemble/write-invoke (append (get-bootstrapping-code)
+				 (compile (parse source-code)
+					  'val
+					  next-linkage))
+                         op)
+  (fprintf op ";\n"))
+
+
+(define (package-anonymous source-code op)
+  (fprintf op "(function() {\n")
+  (package source-code op)
+  (fprintf op " return invoke; })\n"))

parameters.rkt

@@ -0,0 +1,6 @@
+#lang typed/racket/base
+
+(provide current-defined-name)
+
+(: current-defined-name (Parameterof (U Symbol False)))
+(define current-defined-name (make-parameter #f))

parse.rkt

@@ -1,25 +1,22 @@
 #lang racket/base
 
-(require "../compiler/expression-structs.rkt"
-         "../compiler/lexical-env.rkt"
-         "../compiler/lexical-structs.rkt"
-         "../helpers.rkt"
-         "../parameters.rkt"
+(require "expression-structs.rkt"
+         "lexical-env.rkt"
+         "lexical-structs.rkt"
+         "helpers.rkt"
+         "parameters.rkt"
          racket/list)
 
-(provide (rename-out (-parse parse)))
-
+(provide (rename-out (-parse parse))
+         
+         ;; meant for tests
+         set-private-lam-label-counter!)
 
 (define (-parse exp)
   (let* ([prefix (construct-the-prefix exp)])
     (make-Top prefix (parse exp (extend-lexical-environment '() prefix) #t))))
 
 
-(define (make-lam-label)
-  (make-label 'lamEntry))
-
-  
-
 
 (define (construct-the-prefix exp)
   (let ([unbound-names (find-unbound-names exp)]
@@ -55,7 +52,7 @@
     [(current-language)
      => (lambda (lang)
           (if (member sym lang)
-              (make-ModuleVariable sym (make-ModuleLocator '#%kernel '#%kernel))
+              (make-ModuleVariable sym '#%kernel)
               #f))]
     [else
      #f]))
@@ -91,15 +88,7 @@
                          (EnvLexicalReference-unbox? address))]
          [(EnvPrefixReference? address)
           (make-ToplevelRef (EnvPrefixReference-depth address)
-                            (EnvPrefixReference-pos address)
-                            #f
-                            #t)]))]
-
-    [(define-values? exp)
-     (make-DefValues (map (lambda (id) 
-                            (parse id cenv #f))
-                          (define-values-ids exp))
-                     (parse (define-values-rhs exp) cenv #f))]
+                            (EnvPrefixReference-pos address))]))]
     
     [(definition? exp)
      (let ([address (find-variable (definition-variable exp) cenv)])
@@ -109,6 +98,7 @@
          [(EnvPrefixReference? address)
           (make-ToplevelSet (EnvPrefixReference-depth address)
                             (EnvPrefixReference-pos address)
+                            (definition-variable exp)
                             (parameterize ([current-defined-name (definition-variable exp)])
                               (parse (definition-value exp) cenv #f)))]))]
     
@@ -123,9 +113,6 @@
     [(lambda? exp)
      (parse-lambda exp cenv)]
     
-    [(case-lambda? exp)
-     (parse-case-lambda exp cenv)]
-    
     [(begin? exp)
      (let ([actions (map (lambda (e)
                            (parse e cenv at-toplevel?))
@@ -150,23 +137,15 @@
        ;; extent of the set!-value.
        (make-Seq (list (cond
                          [(EnvLexicalReference? address)
-                          (make-InstallValue 1
-                                             (EnvLexicalReference-depth address)
+                          (make-InstallValue (EnvLexicalReference-depth address)
                                              (parse (set!-value exp) cenv #f)
                                              #t)]
                          [(EnvPrefixReference? address)
                           (make-ToplevelSet (EnvPrefixReference-depth address)
                                             (EnvPrefixReference-pos address)
+                                            (definition-variable exp)
                                             (parse (set!-value exp) cenv #f))])
                        (make-Constant (void)))))]
-    
-    [(with-continuation-mark? exp)
-     (make-WithContMark (parse (with-continuation-mark-key exp) cenv #f)
-                        (parse (with-continuation-mark-value exp) cenv #f)
-                        (parse (with-continuation-mark-body exp) cenv #f))]
-
-    [(call-with-values? exp)
-     (parse-call-with-values exp cenv)]
 
     ;; Remember, this needs to be the last case.
     [(application? exp)
@@ -204,39 +183,20 @@
                                        (parse b body-cenv #f))
                                      (lambda-body exp)))
                            mutated-parameters)])
-      (cond [(lambda-has-rest-parameter? exp)
-             (make-Lam (current-defined-name)
-                       (sub1 (length (lambda-parameters exp)))
-                       #t
-                       lam-body
-                       (map env-reference-depth closure-references)
-                       (make-lam-label))]
-            [else
-             (make-Lam (current-defined-name)
-                       (length (lambda-parameters exp))
-                       #f
-                       lam-body
-                       (map env-reference-depth closure-references)
-                       (make-lam-label))]))))
-
-
-
-
-
-(define (parse-case-lambda exp cenv)
-  (let* ([entry-label (make-lam-label)]
-         [parsed-lams (map (lambda (lam)
-                             (parse-lambda lam cenv))
-                           (case-lambda-clauses exp))])
-    (make-CaseLam (current-defined-name)
-                  parsed-lams
-                  entry-label)))
-
-
-
-
+      (make-Lam (current-defined-name)
+                (length (lambda-parameters exp))
+                lam-body
+                (map env-reference-depth closure-references)
+                (fresh-lam-label)))))
 
 
+(define lam-label-counter 0)
+(define (set-private-lam-label-counter! x)
+  (set! lam-label-counter x))
+(define fresh-lam-label
+    (lambda ()
+      (set! lam-label-counter (add1 lam-label-counter))
+      (string->symbol (format "lamEntry~a" lam-label-counter))))
 
 
 (define (seq codes)
@@ -264,10 +224,6 @@
        [(variable? exp)
         (list exp)]
        
-       [(define-values? exp)
-        (append (define-values-ids exp)
-                (loop (define-values-rhs exp)))]
-       
        [(definition? exp)
         (cons (definition-variable exp)
               (loop (definition-value exp)))]
@@ -284,9 +240,6 @@
         (list-difference (apply append (map loop (lambda-body exp)))
                          (lambda-parameters exp))]
        
-       [(case-lambda? exp)
-        (apply append (map loop (case-lambda-clauses exp)))]
-       
        [(begin? exp)
         (apply append (map loop (begin-actions exp)))]
        
@@ -309,15 +262,6 @@
        [(set!? exp)
         (cons (set!-name exp)
               (loop (set!-value exp)))]
-       
-       [(with-continuation-mark? exp)
-        (append (loop (with-continuation-mark-key exp))
-                (loop (with-continuation-mark-value exp))
-                (loop (with-continuation-mark-body exp)))]
-      
-       [(call-with-values? exp)
-        (append (loop (call-with-values-producer exp))
-                (loop (call-with-values-consumer exp)))]
 
        ;; Remember: this needs to be the last case.
        [(application? exp)
@@ -344,9 +288,6 @@
        [(variable? exp)
         '()]
        
-       [(define-values? exp)
-        (loop (define-values-rhs exp))]
-       
        [(definition? exp)
         (loop (definition-value exp))]
        
@@ -362,9 +303,6 @@
         (list-difference (loop (lambda-body exp))
                          (lambda-parameters exp))]
        
-       [(case-lambda? exp)
-        (apply append (map loop (case-lambda-clauses exp)))]
-       
        [(begin? exp)
         (apply append (map loop (begin-actions exp)))]
        
@@ -387,15 +325,6 @@
        [(set!? exp)
         (cons (set!-name exp)
               (loop (set!-value exp)))]
-
-       [(with-continuation-mark? exp)
-        (append (loop (with-continuation-mark-key exp))
-                (loop (with-continuation-mark-value exp))
-                (loop (with-continuation-mark-body exp)))]
-       
-       [(call-with-values? exp)
-        (append (loop (call-with-values-producer exp))
-                (loop (call-with-values-consumer exp)))]
        
        ;; Remember, this needs to be the last case.
        [(application? exp)
@@ -434,18 +363,6 @@
 (define (assignment-variable exp) (cadr exp))
 (define (assignment-value exp) (caddr exp))
 
-
-
-(define (define-values? exp)
-  (tagged-list? exp 'define-values))
-
-(define (define-values-ids exp)
-  (cadr exp))
-
-(define (define-values-rhs exp)
-  (caddr exp))
-
-
 (define (definition? exp)
   (tagged-list? exp 'define))
 (define (definition-variable exp)
@@ -460,48 +377,12 @@
 
 (define (lambda? exp)
   (tagged-list? exp 'lambda))
-
-
-;; lambda-parameters: lambda-expression -> (listof identifier)
-(define (lambda-parameters exp) 
-  (let loop ([params (cadr exp)])
-    (cond
-      [(null? params)
-       empty]
-      [(pair? params)
-       (cons (car params)
-             (loop (cdr params)))]
-      [else
-       (list params)])))
-
-;; Produces true if the lambda's last parameter is a rest parameter.
-(define (lambda-has-rest-parameter? exp)
-  (let loop ([params (cadr exp)])
-    (cond
-      [(null? params)
-       #f]
-      [(pair? params)
-       (loop (cdr params))]
-      [else
-       #t])))
-
+(define (lambda-parameters exp) (cadr exp))
 (define (lambda-body exp) (cddr exp))
 
 (define (make-lambda parameters body)
   (cons 'lambda (cons parameters body)))
 
-
-
-
-(define (case-lambda? exp)
-  (tagged-list? exp 'case-lambda))
-
-(define (case-lambda-clauses exp)
-  (map (lambda (a-clause)
-         `(lambda ,@a-clause))
-       (cdr exp)))
-
-
 (define (if? exp)
   (tagged-list? exp 'if))
 (define (if-predicate exp)
@@ -551,19 +432,6 @@
               ,(loop (cdr clauses))))])))
 
 
-(define (with-continuation-mark? exp)
-  (tagged-list? exp 'with-continuation-mark))
-
-(define (with-continuation-mark-key exp)
-  (cadr exp))
-(define (with-continuation-mark-value exp)
-  (caddr exp))
-(define (with-continuation-mark-body exp)
-  (cadddr exp))
-
-
-
-
 ;;
 ;; Fixme: see if the parameter is mutated.  If so, box it.
 ;;
@@ -594,8 +462,7 @@
          (make-LetVoid (length vars)
                        (seq (append 
                              (map (lambda (var rhs index) 
-                                    (make-InstallValue 1
-                                                       index 
+                                    (make-InstallValue index 
                                                        (parameterize ([current-defined-name var])
                                                          (parse rhs rhs-cenv #f))
                                                        any-mutated?))
@@ -612,7 +479,7 @@
                        any-mutated?))])))
 
 
-;; Letrec: recursive let bindings
+;; Letrec's currently doing a set! kind of thing.
 (define (parse-letrec exp cenv)
   (let* ([vars (let-variables exp)]
          [rhss (let-rhss exp)]
@@ -627,25 +494,22 @@
                      (append (find-mutated-names body)
                              (apply append (map find-mutated-names rhss))))))
        (let ([new-cenv  (extend-lexical-environment/names cenv 
-                                                          vars
+                                                          (reverse vars)
                                                           (build-list n (lambda (i) #f)))])
          ;; Semantics: allocate a closure shell for each lambda form in procs.
          ;; Install them in reverse order, so that the closure shell for the last element
          ;; in procs is at stack position 0.
-         (make-LetVoid (length vars)
-                       (make-LetRec (map (lambda (rhs name) (parameterize ([current-defined-name name])
-                                                              (parse rhs new-cenv #f)))
-                                         rhss
-                                         vars)
-                                    (parse `(begin ,@body) new-cenv #f))
-                       #f))]
+         (make-LetRec (map (lambda (rhs name) (parameterize ([current-defined-name name])
+                                                (parse rhs new-cenv #f)))
+                           rhss
+                           vars)
+                      (parse `(begin ,@body) new-cenv #f)))]
       [else
-       (let ([new-cenv  (extend-lexical-environment/boxed-names cenv vars)])
+       (let ([new-cenv  (extend-lexical-environment/boxed-names cenv (reverse vars))])
          (make-LetVoid (length vars)
                        (seq (append 
                              (map (lambda (var rhs index) 
-                                    (make-InstallValue 1
-                                                       index
+                                    (make-InstallValue (- n 1 index)
                                                        (parameterize ([current-defined-name var])
                                                          (parse rhs new-cenv #f))
                                                        #t))
@@ -656,26 +520,6 @@
                        #t))])))
 
 
-
-(define (parse-call-with-values exp cenv)
-  (cond
-    [(and (lambda? (call-with-values-producer exp))
-          (empty? (lambda-parameters (call-with-values-producer exp))))
-     (let ([producer (parse `(begin ,@(lambda-body (call-with-values-producer exp)))
-                            cenv #f)]
-           [consumer-proc (parse (call-with-values-consumer exp) cenv #f)])
-              (make-ApplyValues consumer-proc producer))]
-    [else
-     (let ([producer (parse `(,(call-with-values-producer exp)) cenv #f)]
-           [consumer-proc (parse (call-with-values-consumer exp) cenv #f)])
-       (make-ApplyValues consumer-proc producer))]))
-
-
-
-
-
-
-
 (define (desugar-let* exp)
   (let ([body (let-body exp)])
     (let loop ([vars (let-variables exp)]
@@ -698,7 +542,6 @@
 
 
 
-
 (define (named-let? exp)
   (and (tagged-list? exp 'let)
        (symbol? (cadr exp))))
@@ -717,13 +560,6 @@
   (cdddr exp))
 
 
-(define (call-with-values? exp)
-  (tagged-list? exp 'call-with-values))
-(define (call-with-values-producer exp)
-  (cadr exp))
-(define (call-with-values-consumer exp)
-  (caddr exp))
-
 
 ;; any -> boolean
 (define (let? exp)

racket-expander.rkt

@@ -1,16 +1,5 @@
 #lang racket
 
-
-(define (read-code ip)
-  (parameterize ([current-namespace (make-base-namespace)])
-    (expand `(begin ,@(let loop ()
-                        (let ([next (read ip)])
-                          (cond
-                            [(eof-object? next)
-                             empty]
-                            [else
-                             (cons next (loop))])))))))
-
 (define code
 (parameterize ([current-namespace (make-base-namespace)])
   (expand '(begin

relooper.rkt

@@ -0,0 +1,104 @@
+#lang typed/racket/base
+
+(require "sets.rkt"
+         racket/list
+         racket/match)
+
+
+;; What's the input?
+;; What's the output?
+
+;; A label has a name and ends with a branch.
+(define-struct: label ([name : Symbol]
+                       [code : Any]
+                       [branch : Branch]
+                       ;; The values below will be initialized.
+                       [inlabels : (Setof label)]
+                       [outlabels : (Setof label)]
+                       [inlabels* : (Setof label)]
+                       [outlabels* : (Setof label)])
+  #:transparent)
+
+
+(: new-label (Symbol Branch -> label))
+;; Creates a label that's fairly uninitialized.
+(define (new-label a-name a-branch)
+  (make-label a-name #f a-branch (new-seteq) (new-seteq) (new-seteq) (new-seteq)))
+  
+
+;; A branch is either simple, or branching.
+(define-type Branch (U Symbol        ;; simple, direct branch
+                       #f            ;; leaf
+                       branching))
+(define-struct: branching ([consequent : Symbol]
+                           [alternative : Symbol])
+  #:transparent)
+
+
+
+
+;; A soup is a set of labels.
+(define-struct: soup ([labels : (HashTable Symbol label)]) 
+  #:transparent)
+
+(: new-soup ((Listof label) -> soup))
+;; Constructs a new soup.
+(define (new-soup labels)
+  (let: ([ht : (HashTable Symbol label) (make-hash)])
+        ;; First install the labels.
+        (for-each (lambda: ([l : label])
+                           (hash-set! ht (label-name l) l))
+                  labels)
+        ;; Next, initialize the in and out edges.
+        (let: ([a-soup : soup (make-soup ht)])
+              (for-each (lambda: ([l : label])
+                                 (match (label-branch l)
+                                   [(and n (? symbol?))
+                                    (set-insert! (label-outlabels l) (soup-lookup a-soup n))
+                                    (set-insert! (label-inlabels (soup-lookup a-soup n))
+                                                 l)]
+                                   ['#f
+                                    (void)]
+                                   [(struct branching (c a))
+                                    (set-insert! (label-outlabels l) (soup-lookup a-soup c))
+                                    (set-insert! (label-outlabels l) (soup-lookup a-soup a))
+                                    
+                                    (set-insert! (label-inlabels (soup-lookup a-soup c))
+                                                 l)
+                                    (set-insert! (label-inlabels (soup-lookup a-soup a))
+                                                 l)]))
+                        labels)
+              a-soup)))
+
+
+(: soup-lookup (soup Symbol -> label))
+(define (soup-lookup a-soup a-name)
+  (hash-ref (soup-labels a-soup) a-name))
+  
+
+;; What is a sample Soup?
+(define a-soup (new-soup (list
+                           (new-label 'ENTRY 'e2)
+                           (new-label 'e2 (make-branching 'e5 'e12))
+                           (new-label 'e5 'e9)
+                           (new-label 'e9 'e2)
+                           (new-label 'e12 #f))))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+(define-type Block (U basic-block
+                      loop-block
+                      multiple-block))
+
+(define-struct: basic-block ([label : label] 
+                             [next : Block]))
+
+(define-struct: loop-block ([inner : Block]
+                            [next : Block]))
+
+(define-struct: multiple-block ([handled : (Listof Block)]
+                                [next : Block]))

runtime.compressed.js

@@ -0,0 +1,16 @@
+this.plt===void 0&&(this.plt={});
+(function(){this.plt.runtime={};var g=this.plt.runtime,m=function(a){var b=function(){};b.prototype=a;return new b},r=function(a){return function(b){return b instanceof a}},h=function(a){return typeof a==="number"},k=function(a){return typeof a=="object"&&a.length===2},o=function(a){return typeof a=="object"&&a.length!==void 0},p=function(){},t=function(a,b){this.label=a;this.proc=b};t.prototype=m(p.prototype);var u=function(a,b){this.label=a;this.tag=b};u.prototype=m(p.prototype);var n=function(){};
+p=r(n);var s=function(){};s.prototype=m(n.prototype);s.prototype.write=function(a,b){a.params.currentDisplayer(b)};var i=function(){this.buf=[]};i.prototype=m(n.prototype);i.prototype.write=function(a,b){this.buf.push(String(b))};i.prototype.getOutputString=function(){return this.buf.join("")};n=r(i);i=function(a){this.name=a};var w=new i("default-continuation-prompt-tag"),l=[],j=function(a){throw a;},f=function(a,b,c,d,e){if(b(c))return!0;else j(Error(e+": expected "+a+" as argument #"+d+" but received "+
+c+" instead"))},q=function(a,b,c,d){(b<c||b>d)&&j(Error(a+": expected at least "+c+" arguments  but received "+observer))},e={};e.display=function(a,b){q("display",b,1,2);var c=a.env[a.env.length-1],d=a.params.currentOutputPort;b==2&&(d=a.env[a.env.length-2]);d.write(a,c)};e.newline=function(a,b){q("newline",b,0,1);var c=a.params.currentOutputPort;b==1&&(c=a.env[a.env.length-1]);c.write(a,"\n")};e.displayln=function(a,b){q("displayln",b,1,2);var c=a.env[a.env.length-1],d=a.params.currentOutputPort;
+b==2&&(d=a.env[a.env.length-2]);d.write(a,c);d.write(a,"\n")};e.pi=Math.PI;e.e=Math.E;e["="]=function(a){var b=a.env[a.env.length-1];a=a.env[a.env.length-2];f("number",h,b,0,"=");f("number",h,a,1,"=");return b===a};e["<"]=function(a){var b=a.env[a.env.length-1];a=a.env[a.env.length-2];f("number",h,b,0,"<");f("number",h,a,1,"<");return b<a};e[">"]=function(a){var b=a.env[a.env.length-1];a=a.env[a.env.length-2];f("number",h,b,0,">");f("number",h,a,1,">");return b>a};e["<="]=function(a){var b=a.env[a.env.length-
+1];a=a.env[a.env.length-2];f("number",h,b,0,"<=");f("number",h,a,1,"<=");return b<=a};e[">="]=function(a){var b=a.env[a.env.length-1];a=a.env[a.env.length-2];f("number",h,b,0,">=");f("number",h,a,1,">=");return b>=a};e["+"]=function(a,b){var c=0,d=0;for(d=0;d<b;d++)f("number",h,a.env[a.env.length-1-d],d,"+"),c+=a.env[a.env.length-1-d];return c};e["*"]=function(a,b){var c=1,d=0;for(d=0;d<b;d++)f("number",h,a.env[a.env.length-1-d],d,"*"),c*=a.env[a.env.length-1-d];return c};e["-"]=function(a,b){b===
+0&&j(Error());if(b===1)return f("number",h,a.env[a.env.length-1],0,"-"),-a.env[a.env.length-1];for(var c=a.env[a.env.length-1],d=1;d<b;d++)f("number",h,a.env[a.env.length-1-d],d,"-"),c-=a.env[a.env.length-1-d];return c};e["/"]=function(a,b){b===0&&j(Error());f("number",h,a.env[a.env.length-1],0,"/");for(var c=a.env[a.env.length-1],d=1;d<b;d++)c/=a.env[a.env.length-1-d];return c};e.cons=function(a){return[a.env[a.env.length-1],a.env[a.env.length-2]]};e.list=function(a,b){for(var c=l,d=0;d<b;d++)c=
+[a.env[a.env.length-(b-d)],c];return c};e.car=function(a){f("pair",k,a.env[a.env.length-1],0,"car");return a.env[a.env.length-1][0]};e.cdr=function(a){f("pair",k,a.env[a.env.length-1],0,"cdr");return a.env[a.env.length-1][1]};e["pair?"]=function(a){return k(a.env[a.env.length-1])};e["set-car!"]=function(a){f("pair",k,a.env[a.env.length-1],0,"set-car!");a.env[a.env.length-1][0]=a.env[a.env.length-2]};e["set-cdr!"]=function(a){f("pair",k,a.env[a.env.length-1],0,"set-cdr!");a.env[a.env.length-1][1]=
+a.env[a.env.length-2]};e.not=function(a){return!a.env[a.env.length-1]};e["null"]=l;e["null?"]=function(a){return a.env[a.env.length-1]===l};e.add1=function(a){f("number",h,a.env[a.env.length-1],0,"add1");return a.env[a.env.length-1]+1};e.sub1=function(a){f("number",h,a.env[a.env.length-1],0,"sub1");return a.env[a.env.length-1]-1};e["zero?"]=function(a){return a.env[a.env.length-1]===0};e.vector=function(a,b){var c,d=[];for(c=0;c<b;c++)d.push(a.env[a.env.length-1-c]);return d};e["vector->list"]=function(a){f("vector",
+o,a.env[a.env.length-1],0,"vector->list");a=a.env[a.env.length-1];var b,c=l;for(b=0;b<a.length;b++)c=[a[a.length-1-b],c];return c};e["list->vector"]=function(a){a=a.env[a.env.length-1];for(var b=[];a!==l;)b.push(a[0]),a=a[1];return b};e["vector-ref"]=function(a){f("vector",o,a.env[a.env.length-1],0,"vector-ref");return a.env[a.env.length-1][a.env[a.env.length-2]]};e["vector-set!"]=function(a){f("vector",o,a.env[a.env.length-1],0,"vector-set!");a.env[a.env.length-1][a.env[a.env.length-2]]=a.env[a.env.length-
+3];return null};e["symbol?"]=function(a){return typeof a.env[a.env.length-1]==="string"};e["symbol->string"]=function(a){return a.env[a.env.length-1]};e["string-append"]=function(a,b){var c=[],d;for(d=0;d<b;d++)c.push(a.env[a.env.length-1-d]);return c.join("")};e["string-length"]=function(a){return a.env[a.env.length-1].length};e.box=function(a){return[a.env[a.env.length-1]]};e.unbox=function(a){return a.env[a.env.length-1][0]};e["set-box!"]=function(a){a.env[a.env.length-1][0]=a.env[a.env.length-
+2]};e["void"]=function(){};e["eq?"]=function(a){return a.env[a.env.length-1]===a.env[a.env.length-2]};e["equal?"]=function(a){var b=[a.env[a.env.length-1]];for(a=[a.env[a.env.length-2]];b.length!==0&&a.length!==0;){var c=b.pop(),d=a.pop();if(c!==d)if(typeof c==="object"&&typeof d==="object"&&typeof c.length==="number"&&typeof d.length==="number"&&c.length===d.length)b.push.apply(b,c),a.push.apply(a,d);else return!1}return!0};var x=function(a,b){var c=1E3/a.params.desiredYieldsPerSecond;a.params.maxNumBouncesBeforeYield=
+Math.max(a.params.maxNumBouncesBeforeYield+256*((c-b)/c),1)},v=function(a,b){var c=b,d=(new Date).valueOf();a.callsBeforeTrampoline=100;a.params.numBouncesBeforeYield=a.params.maxNumBouncesBeforeYield;for(a.running=!0;c;)try{c(a);break}catch(e){if(typeof e==="function"){if(c=e,a.callsBeforeTrampoline=100,a.params.numBouncesBeforeYield--<0){x(a,(new Date).valueOf()-d);setTimeout(function(){v(a,c)},0);return}}else return a.running=!1,a.params.currentErrorHandler(a,e)}a.running=!1;return a.params.currentSuccessHandler(a)};
+g.Machine=function(){this.callsBeforeTrampoline=100;this.proc=this.val=void 0;this.env=[];this.control=[];this.running=!1;this.params={currentDisplayer:function(){},currentOutputPort:new s,currentSuccessHandler:function(){},currentErrorHandler:function(){},currentNamespace:{},desiredYieldsPerSecond:5,numBouncesBeforeYield:2E3,maxNumBouncesBeforeYield:2E3};this.primitives=e};g.CallFrame=t;g.PromptFrame=u;g.Closure=function(a,b,c,d){this.label=a;this.arity=b;this.closedVals=c;this.displayName=d};g.ContinuationPromptTag=
+i;g.DEFAULT_CONTINUATION_PROMPT_TAG=w;g.NULL=l;g.testArgument=f;g.testArity=q;g.raise=j;g.captureControl=function(a,b,c){var d;for(d=a.control.length-1-b;d>=0;d--)if(a.control[d].tag===c)return a.control.slice(d+1,a.control.length-b);j(Error("captureControl: unable to find tag "+c))};g.restoreControl=function(a,b){var c;for(c=a.control.length-1;c>=0;c--)if(a.control[c].tag===b){a.control=a.control.slice(0,c+1).concat(a.env[a.env.length-1]);return}j(Error("restoreControl: unable to find tag "+b))};
+g.isNumber=h;g.isPair=k;g.isVector=o;g.isOutputPort=p;g.isOutputStringPort=n;g.heir=m;g.makeClassPredicate=r;g.trampoline=v}).call(this);

runtime.js

@@ -0,0 +1,708 @@
+    if(this['plt'] === undefined) {
+	this['plt'] = {};
+    }
+
+
+// All of the values here are namespaced under "plt.runtime".
+
+(function() {
+    this['plt']['runtime'] = {};
+    var exports = this['plt']['runtime'];
+
+
+
+    // Type helpers
+    //
+    // Defines inheritance between prototypes.
+    var heir = function(parentPrototype) {
+	var f = function() {}
+	f.prototype = parentPrototype;
+	return new f();
+    };
+
+    // Consumes a class and creates a predicate that recognizes subclasses.
+    var makeClassPredicate = function(aClass) {
+	return function(x) { return x instanceof aClass; };
+    };
+
+
+    var isNumber = function(x) { return typeof(x) === 'number'; };
+
+    var isPair = function(x) { return (typeof(x) == 'object' && 
+				       x.length === 2) }
+    var isVector = function(x) { return (typeof(x) == 'object' && 
+					 x.length !== undefined) }
+
+    var Machine = function() {
+	this.callsBeforeTrampoline = 100;
+	this.val = undefined;
+	this.proc = undefined;
+	this.env = [];
+	this.control = [];     // Arrayof (U CallFrame PromptFrame)
+	this.running = false;
+	this.params = { 'currentDisplayer': function(v) {},
+			
+			'currentOutputPort': new StandardOutputPort(),
+			'currentSuccessHandler': function(MACHINE) {},
+			'currentErrorHandler': function(MACHINE, exn) {},
+			
+			'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
+		      };
+	this.primitives = Primitives;
+    };
+
+
+
+    var Frame = function() {};
+    // Control stack elements:
+
+    // A CallFrame represents a call stack frame.
+    var CallFrame = function(label, proc) {
+	this.label = label;
+	this.proc = proc;
+    };
+    CallFrame.prototype = heir(Frame.prototype);
+
+    // PromptFrame represents a prompt frame.
+    var PromptFrame = function(label, tag) {
+	this.label = label;
+	this.tag = tag; // ContinuationPromptTag
+    };
+    PromptFrame.prototype = heir(Frame.prototype);
+
+
+
+
+
+
+
+
+    var OutputPort = function() {};
+    var isOutputPort = makeClassPredicate(OutputPort);
+
+
+    var StandardOutputPort = function() {};
+    StandardOutputPort.prototype = heir(OutputPort.prototype);
+    StandardOutputPort.prototype.write = function(MACHINE, v) {
+	MACHINE.params['currentDisplayer'](v);
+    };
+
+
+
+    var OutputStringPort = function() {
+	this.buf = [];
+    };
+    OutputStringPort.prototype = heir(OutputPort.prototype);
+    OutputStringPort.prototype.write = function(MACHINE, v) {
+	this.buf.push(String(v));
+    };
+    OutputStringPort.prototype.getOutputString = function() {
+	return this.buf.join('');
+    };
+    var isOutputStringPort = makeClassPredicate(OutputStringPort);
+
+
+
+
+    // Function types: a function is either a Primitive or a Closure.
+
+    // A Primitive is a function that's expected to return.  It is not
+    // allowed to call into Closures.  Its caller is expected to pop off
+    // its argument stack space.
+    //
+    //
+    // A Closure is a function that takes on more responsibilities: it is
+    // responsible for popping off stack space before it finishes, and it
+    // is also explicitly responsible for continuing the computation by 
+    // popping off the control stack and doing the jump.  Because of this,
+    // closures can do pretty much anything to the machine.
+
+
+
+    // A closure consists of its free variables as well as a label
+    // into its text segment.
+    var Closure = function(label, arity, closedVals, displayName) {
+	this.label = label;              // (MACHINE -> void)
+	this.arity = arity;              // number
+	this.closedVals = closedVals;    // arrayof number
+	this.displayName = displayName;  // string
+    };
+
+
+
+
+
+
+
+
+    // A continuation prompt tag labels a prompt frame.
+    var ContinuationPromptTag = function(name) {
+	this.name = name;
+    };
+
+
+
+    // There is a single, distinguished default continuation prompt tag
+    // that's used to wrap around toplevel prompts.
+    var DEFAULT_CONTINUATION_PROMPT_TAG = 
+	new ContinuationPromptTag("default-continuation-prompt-tag");
+
+
+    var NULL = [];
+
+
+    var raise = function(e) { throw e; }
+
+
+
+
+    // testArgument: (X -> boolean) X number string string -> boolean
+    // Produces true if val is true, and otherwise raises an error.
+    var testArgument = function(expectedTypeName,
+				predicate, 			    
+				val, 
+				position, 
+				callerName) {
+	if (predicate(val)) {
+	    return true;
+	}
+	else {
+	    raise(new Error(callerName + ": expected " + expectedTypeName
+			    + " as argument #" + position 
+			    + " but received " + val + " instead"));
+	}
+    };
+
+    var testArity = function(callerName, observed, minimum, maximum) {
+	if (observed < minimum || observed > maximum) {
+	    raise(new Error(callerName + ": expected at least " + minimum
+			    + " arguments "
+			    + " but received " + observer));
+
+	}
+    };
+
+
+
+    // captureControl implements the continuation-capturing part of
+    // call/cc.  It grabs the control frames up to (but not including) the
+    // prompt tagged by the given tag.
+    var captureControl = function(MACHINE, skip, tag) {
+	var i;
+	for (i = MACHINE.control.length - 1 - skip; i >= 0; i--) {
+	    if (MACHINE.control[i].tag === tag) {
+		return MACHINE.control.slice(i + 1,
+					     MACHINE.control.length - skip);
+	    }
+	} 
+	raise(new Error("captureControl: unable to find tag " + tag));
+    };
+
+
+
+    // restoreControl clears the control stack (up to, but not including the
+    // prompt tagged by tag), and then appends the rest of the control frames.
+    // At the moment, the rest of the control frames is assumed to be in the 
+    // top of the environment.
+    var restoreControl = function(MACHINE, tag) {
+	var i;
+	for (i = MACHINE.control.length - 1; i >= 0; i--) {
+	    if (MACHINE.control[i].tag === tag) {
+		MACHINE.control = 
+		    MACHINE.control.slice(0, i+1).concat(
+			MACHINE.env[MACHINE.env.length - 1]);
+		return;
+	    }
+	}
+	raise(new Error("restoreControl: unable to find tag " + tag));     
+
+    }
+
+
+
+
+
+
+    
+
+    // Primtitives are the set of primitive values.  Not all primitives
+    // are coded here; several of them (including call/cc) are injected by
+    // the bootstrapping code.
+    var Primitives = {};
+    Primitives['display'] = function(MACHINE, arity) {
+	testArity('display', arity, 1, 2);
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var outputPort = MACHINE.params.currentOutputPort;
+	if (arity == 2) { 
+	    outputPort = MACHINE.env[MACHINE.env.length-2];
+	}
+	outputPort.write(MACHINE, firstArg);
+    };
+
+    Primitives['newline'] = function(MACHINE, arity) {
+	testArity('newline', arity, 0, 1);
+	var outputPort = MACHINE.params.currentOutputPort;
+	if (arity == 1) { 
+	    outputPort = MACHINE.env[MACHINE.env.length-1];
+	}
+	outputPort.write(MACHINE, "\n");
+    };
+
+    Primitives['displayln'] = function(MACHINE, arity){
+	testArity('displayln', arity, 1, 2);
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var outputPort = MACHINE.params.currentOutputPort;
+	if (arity == 2) { 
+	    outputPort = MACHINE.env[MACHINE.env.length-2];
+	}
+	outputPort.write(MACHINE, firstArg);
+	outputPort.write(MACHINE, "\n");
+    };
+
+    Primitives['pi'] = Math.PI;
+
+    Primitives['e'] = Math.E;
+
+    Primitives['='] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	testArgument('number', isNumber, firstArg, 0, '=');
+	testArgument('number', isNumber, secondArg, 1, '=');
+	return firstArg === secondArg;
+    };
+
+    Primitives['<'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	testArgument('number', isNumber, firstArg, 0, '<');
+	testArgument('number', isNumber, secondArg, 1, '<');
+	return firstArg < secondArg;
+    };
+
+    Primitives['>'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	testArgument('number', isNumber, firstArg, 0, '>');
+	testArgument('number', isNumber, secondArg, 1, '>');
+	return firstArg > secondArg;
+    };
+
+    Primitives['<='] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	testArgument('number', isNumber, firstArg, 0, '<=');
+	testArgument('number', isNumber, secondArg, 1, '<=');
+	return firstArg <= secondArg;
+    };
+
+    Primitives['>='] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	testArgument('number', isNumber, firstArg, 0, '>=');
+	testArgument('number', isNumber, secondArg, 1, '>=');
+	return firstArg >= secondArg;
+    };
+    
+    Primitives['+'] = function(MACHINE, arity) {
+	var result = 0;
+	var i = 0;
+	for (i=0; i < arity; i++) {
+	    testArgument(
+		'number',
+		isNumber, 
+		MACHINE.env[MACHINE.env.length - 1 - i],
+		i,
+		'+');
+	    result += MACHINE.env[MACHINE.env.length - 1 - i];
+	};
+	return result;
+    };
+    
+    Primitives['*'] = function(MACHINE, arity) {
+	var result = 1;
+	var i = 0;
+	for (i=0; i < arity; i++) {
+	    testArgument(
+		'number',
+		isNumber, 
+		MACHINE.env[MACHINE.env.length - 1 - i],
+		i,
+		'*');
+	    result *= MACHINE.env[MACHINE.env.length - 1 - i];
+	}
+	return result;
+    };
+    
+    Primitives['-'] = function(MACHINE, arity) {
+	if (arity === 0) { raise(new Error()); }
+	if (arity === 1) { 
+	    testArgument('number',
+			 isNumber,
+			 MACHINE.env[MACHINE.env.length-1],
+			 0,
+			 '-');
+	    return -(MACHINE.env[MACHINE.env.length-1]);
+	}
+	var result = MACHINE.env[MACHINE.env.length - 1];
+	for (var i = 1; i < arity; i++) {
+	    testArgument('number',
+			 isNumber,
+			 MACHINE.env[MACHINE.env.length-1-i],
+			 i,
+			 '-');
+	    result -= MACHINE.env[MACHINE.env.length - 1 - i];
+	}
+	return result;
+    };
+    
+    Primitives['/'] = function(MACHINE, arity) {
+	if (arity === 0) { raise(new Error()); }
+	testArgument('number',
+		     isNumber,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     '/');
+	var result = MACHINE.env[MACHINE.env.length - 1];
+	for (var i = 1; i < arity; i++) {
+	    result /= MACHINE.env[MACHINE.env.length - 1 - i];
+	}
+	return result;
+    };
+
+    Primitives['cons'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	return [firstArg, secondArg];
+    };
+
+    Primitives['list'] = function(MACHINE, arity) {
+	var result = NULL;
+	for (var i = 0; i < arity; i++) {
+	    result = [MACHINE.env[MACHINE.env.length - (arity - i)],
+		      result];
+	}
+	return result;
+    };
+
+    Primitives['car'] = function(MACHINE, arity) {
+	testArgument('pair',
+		     isPair,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'car');
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg[0];
+    };
+
+    Primitives['cdr'] = function(MACHINE, arity) {
+	testArgument('pair',
+		     isPair,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'cdr');
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg[1];
+    };
+
+    Primitives['pair?'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return isPair(firstArg);
+    };
+
+    Primitives['set-car!'] = function(MACHINE, arity) {
+	testArgument('pair',
+		     isPair,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'set-car!');
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	firstArg[0] = secondArg;
+    };
+
+    Primitives['set-cdr!'] = function(MACHINE, arity) {
+	testArgument('pair',
+		     isPair,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'set-cdr!');
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	firstArg[1] = secondArg;
+    };
+    
+    Primitives['not'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return (!firstArg);
+    };
+
+    Primitives['null'] = NULL;
+
+    Primitives['null?'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg === NULL;
+    };
+
+    Primitives['add1'] = function(MACHINE, arity) {
+	testArgument('number',
+		     isNumber,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'add1');
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg + 1;
+    };
+
+    Primitives['sub1'] = function(MACHINE, arity) {
+	testArgument('number',
+		     isNumber,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'sub1');
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg - 1;
+    };
+
+    Primitives['zero?'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg === 0;
+    };
+
+    Primitives['vector'] = function(MACHINE, arity) {
+	var i;
+	var result = [];
+	for (i = 0; i < arity; i++) {
+	    result.push(MACHINE.env[MACHINE.env.length-1-i]);
+	}
+	return result;
+    };
+
+    Primitives['vector->list'] = function(MACHINE, arity) {
+	testArgument('vector',
+		     isVector,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'vector->list');
+	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;
+    };
+    
+    Primitives['list->vector'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var result = [];
+	while (firstArg !== NULL) {
+	    result.push(firstArg[0]);
+	    firstArg = firstArg[1];
+	}
+	return result;
+    };
+
+    Primitives['vector-ref'] = function(MACHINE, arity) {
+	testArgument('vector',
+		     isVector,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'vector-ref');
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	return firstArg[secondArg];
+    };
+
+    Primitives['vector-set!'] = function(MACHINE, arity) {
+	testArgument('vector',
+		     isVector,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'vector-set!');
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	var thirdArg = MACHINE.env[MACHINE.env.length-3];
+	firstArg[secondArg] = thirdArg;
+	return null;
+    };
+
+    Primitives['symbol?'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return typeof(firstArg) === 'string';
+    };
+
+    Primitives['symbol->string'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg;
+    };
+
+    Primitives['string-append'] = function(MACHINE, arity) {
+	var buffer = [];
+	var i;
+	for (i = 0; i < arity; i++) {
+	    buffer.push(MACHINE.env[MACHINE.env.length - 1 - i]);
+	}
+	return buffer.join('');
+    };
+
+    Primitives['string-length'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg.length;
+    };
+    
+    Primitives['box'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var result = [firstArg];
+	return result;
+    };
+
+    Primitives['unbox'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg[0];
+    };
+
+    Primitives['set-box!'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	firstArg[0] = secondArg;
+	return;
+    };
+
+    Primitives['void'] = function(MACHINE, arity) {
+	return;
+    };
+
+    Primitives['eq?'] = function(MACHINE, arity) {
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	var secondArg = MACHINE.env[MACHINE.env.length-2];
+	return firstArg === secondArg;
+    };
+
+    Primitives['equal?'] = function(MACHINE, arity) {
+	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;
+    };
+
+
+
+
+    // recomputeGas: state number -> number
+    var recomputeMaxNumBouncesBeforeYield = function(MACHINE, 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(MACHINE, initialJump) {
+	var thunk = initialJump;
+	var startTime = (new Date()).valueOf();
+	MACHINE.callsBeforeTrampoline = 100;
+	MACHINE.params.numBouncesBeforeYield = 
+	    MACHINE.params.maxNumBouncesBeforeYield;
+	MACHINE.running = true;
+
+	while(thunk) {
+            try {
+		thunk(MACHINE);
+		break;
+            } catch (e) {
+		if (typeof(e) === 'function') {
+                    thunk = e;
+                    MACHINE.callsBeforeTrampoline = 100;
+
+		    if (MACHINE.params.numBouncesBeforeYield-- < 0) {
+			recomputeMaxNumBouncesBeforeYield(
+			    MACHINE,
+			    (new Date()).valueOf() - startTime);
+			setTimeout(
+			    function() {
+				trampoline(MACHINE, thunk);
+			    },
+			    0);
+			return;
+		    }
+		} else {
+		    MACHINE.running = false;
+	            return MACHINE.params.currentErrorHandler(MACHINE, e);
+		}
+            }
+	}
+	MACHINE.running = false;
+	return MACHINE.params.currentSuccessHandler(MACHINE);
+    };
+
+
+
+
+    // Exports
+    exports['Machine'] = Machine;
+    exports['CallFrame'] = CallFrame;
+    exports['PromptFrame'] = PromptFrame;
+    exports['Closure'] = Closure;
+    exports['ContinuationPromptTag'] = ContinuationPromptTag;
+    exports['DEFAULT_CONTINUATION_PROMPT_TAG'] = 
+	DEFAULT_CONTINUATION_PROMPT_TAG;
+    exports['NULL'] = NULL;
+
+    exports['testArgument'] = testArgument;
+    exports['testArity'] = testArity;
+    exports['raise'] = raise;
+
+    exports['captureControl'] = captureControl;
+    exports['restoreControl'] = restoreControl;
+
+    exports['isNumber'] = isNumber;
+    exports['isPair'] = isPair;
+    exports['isVector'] = isVector;
+    exports['isOutputPort'] = isOutputPort;
+    exports['isOutputStringPort'] = isOutputStringPort;
+
+    exports['heir'] = heir;
+    exports['makeClassPredicate'] = makeClassPredicate;
+
+    exports['trampoline'] = trampoline;
+
+}).call(this);

simulator-helpers.rkt

@@ -0,0 +1,113 @@
+#lang racket/base
+
+(require "simulator-structs.rkt")
+(provide ensure-primitive-value-box
+         ensure-primitive-value
+         ensure-list
+         PrimitiveValue->racket
+         racket->PrimitiveValue)
+(define (ensure-primitive-value-box x)
+  (if (and (box? x)
+           (PrimitiveValue? (unbox x)))
+      x
+      (error 'ensure-primitive-value-box "~s" x)))
+
+
+
+;; Make sure the value is primitive.
+(define (ensure-primitive-value val)
+  (let loop ([v val])
+    (cond
+      [(string? v)
+       v]
+      [(symbol? v)
+       v]
+      [(number? v)
+       v]
+      [(boolean? v)
+       v]
+      [(null? v)
+       v]
+      [(VoidValue? v)
+       v]
+      [(MutablePair? v)
+       v]
+      [(primitive-proc? v)
+       v]
+      [(closure? v)
+       v]
+      [(undefined? v)
+       v]
+      [(vector? v)
+       v]
+      [else
+       (error 'ensure-primitive-value "~s" v)])))
+
+
+(define (ensure-list v)
+  (cond
+    [(null? v)
+     v]
+    [(and (MutablePair? v)
+          (PrimitiveValue? (MutablePair-h v))
+          (PrimitiveValue? (MutablePair-t v)))
+     v]
+    [else
+     (error 'ensure-list)]))
+
+
+(define (PrimitiveValue->racket v)
+  (cond
+    [(string? v)
+     v]
+    [(number? v)
+     v]
+    [(symbol? v)
+     v]
+    [(boolean? v)
+     v]
+    [(null? v)
+     v]
+    [(VoidValue? v)
+     (void)]
+    [(undefined? v)
+     (letrec ([x x]) x)]
+    [(primitive-proc? v)
+     v]
+    [(closure? v)
+     v]
+    [(vector? v)
+     (apply vector (map PrimitiveValue->racket (vector->list v)))]
+    [(MutablePair? v)
+     (cons (PrimitiveValue->racket (MutablePair-h v))
+           (PrimitiveValue->racket (MutablePair-t v)))]))
+
+
+(define (racket->PrimitiveValue v)
+  (cond
+    [(string? v)
+     v]
+    [(number? v)
+     v]
+    [(symbol? v)
+     v]
+    [(boolean? v)
+     v]
+    [(null? v)
+     v]
+    [(void? v)
+     the-void-value]
+    [(eq? v (letrec ([x x]) x))
+     (make-undefined)]
+    [(procedure? v)
+     (error 'racket->PrimitiveValue "Can't coerse procedure")]
+    [(primitive-proc? v)
+     v]
+    [(closure? v)
+     v]
+    [(vector? v)
+     (apply vector (map racket->PrimitiveValue (vector->list v)))]
+    [(pair? v)
+     (make-MutablePair (racket->PrimitiveValue (car v))
+                       (racket->PrimitiveValue (cdr v)))]))
+

simulator-primitives.rkt

@@ -0,0 +1,180 @@
+#lang racket/base
+(require "simulator-structs.rkt"
+         racket/math
+         (for-syntax racket/base))
+
+(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)
+  (syntax-case stx ()
+    [(_ #:functions (name ...)
+        #:constants (cname ...))
+     (with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))]
+                   [((name exported-name) ...)
+                    (map (lambda (name)
+                           (syntax-case name ()
+                             [(real-name exported-name)
+                              (list #'real-name #'exported-name)]
+                             [_ 
+                              (identifier? name)
+                              (list name name)]))
+                         (syntax->list #'(name ...)))])
+       (syntax/loc stx
+         (let ([prim-name (make-primitive-proc 
+                           (lambda (machine . args)
+                             (apply name args)))]
+               ...)
+           (lambda (n)
+             (cond
+               [(hash-has-key? mutated-primitives n)
+                (hash-ref mutated-primitives n)]
+               [(eq? n 'exported-name)
+                prim-name]
+               ...
+               [(eq? n 'cname)
+                cname]
+               ...
+               [else
+                (make-undefined)]
+               )))))]))
+
+;(define call/cc
+;  (make-closure call/cc-label
+;                1
+;                '()
+;                'call/cc))
+;(define call-with-current-continuation call/cc)
+
+(define e (exp 1))
+
+(define my-cons (lambda (x y)
+                  (make-MutablePair x y)))
+
+(define my-list (lambda args
+                   (let loop ([args args])
+                     (cond
+                       [(null? args)
+                        null]
+                       [else
+                        (make-MutablePair (car args)
+                                          (loop (cdr args)))]))))
+(define my-car (lambda (x)
+                  (MutablePair-h x)))
+
+(define my-cdr (lambda (x)
+                  (MutablePair-t x)))
+
+(define my-pair? (lambda (x)
+                   (MutablePair? x)))
+
+(define my-box (lambda (x)
+                 (vector x)))
+
+(define my-unbox (lambda (x)
+                   (vector-ref x 0)))
+
+(define my-set-box! (lambda (x v)
+                      (vector-set! x 0 v)
+                      the-void-value))
+
+(define my-vector->list (lambda (v)
+                          (apply my-list (vector->list v))))
+
+(define my-list->vector (lambda (l)
+                          (apply vector
+                          (let loop ([l l])
+                            (cond
+                              [(null? l)
+                               null]
+                              [else
+                               (cons (MutablePair-h l)
+                                     (loop (MutablePair-t l)))])))))
+                                
+
+(define my-set-car! (lambda (p v)
+                      (set-MutablePair-h! p v)
+                      the-void-value))
+
+(define my-set-cdr! (lambda (p v)
+                      (set-MutablePair-t! p v)
+                      the-void-value))
+
+(define my-void (lambda args
+                  the-void-value))
+
+(define my-display (lambda args
+                     (apply display args)
+                     the-void-value))
+
+(define my-displayln (lambda args
+                       (apply displayln args)
+                       the-void-value))
+
+(define my-newline (lambda args
+                     (apply newline args)
+                     the-void-value))
+
+(define my-vector-set! (lambda args
+                         (apply vector-set! args)
+                         the-void-value))
+
+
+(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= 
+                                                     sub1
+                                                     not
+                                                     null?
+                                                     eq?
+                                                     add1
+                                                     sub1
+                                                     zero?
+                                                     abs
+                                                     (my-void void)
+                                                     quotient
+                                                     remainder
+ 
+                                                     (my-display display)
+                                                     (my-displayln displayln)
+                                                     (my-newline newline)
+                                                    
+                                                     symbol->string
+                                                     string-append
+                                                     string-length
+                                                     
+                                                     (my-cons cons)
+                                                     (my-list list)
+                                                     (my-car car)
+                                                     (my-cdr cdr)
+                                                     (my-pair? pair?)
+                                                     (my-set-car! set-car!)
+                                                     (my-set-cdr! set-cdr!)
+                                                     
+                                                     
+                                                     
+                                                     (my-box box)
+                                                     (my-unbox unbox)
+                                                     (my-set-box! set-box!)
+                                                     
+                                                     vector
+                                                     (my-vector-set! vector-set!)
+                                                     vector-ref
+                                                     (my-vector->list vector->list)
+                                                     (my-list->vector list->vector)
+                                                     
+                                                     
+                                                     
+                                                     equal?
+                                                     
+                                                     
+                                                    
+                                                     
+                                                     symbol?)
+                                      #:constants (null pi e 
+                                                        #;call/cc
+                                                        #;call-with-current-continuation)))
+
+

simulator-structs.rkt

@@ -0,0 +1,112 @@
+#lang typed/racket/base
+
+(provide (all-defined-out))
+
+(require "il-structs.rkt"
+         "lexical-structs.rkt")
+
+
+(define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean
+                                                   Null VoidValue
+                                                   undefined
+                                                   
+                                                   primitive-proc 
+                                                   closure
+                                                   
+                                                   (Vectorof PrimitiveValue)
+                                                   MutablePair
+                                                   
+                                                   )))
+(define-type SlotValue (U PrimitiveValue 
+                          (Boxof PrimitiveValue)
+                          toplevel
+                          CapturedControl
+                          CapturedEnvironment))
+
+
+(define-struct: VoidValue () #:transparent)
+(define the-void-value (make-VoidValue))
+
+
+(define-struct: MutablePair ([h : PrimitiveValue]
+                             [t : PrimitiveValue])
+  #:mutable #:transparent)
+
+;; For continuation capture:
+(define-struct: CapturedControl ([frames : (Listof frame)]))
+(define-struct: CapturedEnvironment ([vals : (Listof SlotValue)]))
+
+
+(define-struct: machine ([val : SlotValue]
+                         [proc : SlotValue]
+                         [env : (Listof SlotValue)]
+                         [control : (Listof frame)]
+
+                         [pc : Natural]                  ;; program counter
+                         [text : (Vectorof Statement)]   ;; text of the program
+
+                         ;; other metrics for debugging
+                         [stack-size : Natural]
+                         
+                         ;; compute position from label
+                         [jump-table : (HashTable Symbol Natural)]
+                         )
+  #:transparent
+  #:mutable)
+
+
+(define-type frame (U CallFrame PromptFrame))
+
+(define-struct: CallFrame ([return : Symbol]
+                           ;; The procedure being called.  Used to optimize self-application
+                           [proc : (U closure #f)]
+                           ;; TODO: add continuation marks
+                           )
+  #:transparent)
+(define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
+                             [return : Symbol])
+  #:transparent)
+
+(define-struct: ContinuationPromptTagValue ([name : Symbol])
+  #:transparent)
+
+(define default-continuation-prompt-tag-value 
+  (make-ContinuationPromptTagValue 'default-continuation-prompt))
+
+
+
+(define-struct: toplevel ([names : (Listof (U #f Symbol ModuleVariable))]
+                          [vals : (Listof PrimitiveValue)])
+  #:transparent
+  #:mutable)
+
+
+
+
+
+;; Primitive procedure wrapper
+(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)])
+  #:transparent)
+
+
+
+;; Compiled procedure closures
+(define-struct: closure ([label : Symbol]
+                         [arity : Natural]
+                         [vals : (Listof SlotValue)]
+                         [display-name : (U Symbol False)])
+  #:transparent
+  #:mutable)
+
+
+
+
+
+;; undefined value
+(define-struct: undefined ()
+  #:transparent)
+
+
+
+(define-predicate PrimitiveValue? PrimitiveValue)
+(define-predicate frame? frame)

simulator.rkt

@@ -0,0 +1,778 @@
+#lang typed/racket/base
+
+;; An evaluator for the intermediate language, so I can do experiments.
+;;
+;; For example, I'll need to be able to count the number of statements executed by an evaluation.
+;; I also need to do things like count pushes and pops.  Basically, low-level benchmarking.
+
+(require "il-structs.rkt"
+         "lexical-structs.rkt"
+         "simulator-structs.rkt"
+         "bootstrapped-primitives.rkt"
+         "kernel-primitives.rkt"
+         racket/list
+         racket/match
+         (for-syntax racket/base))
+
+(require/typed "simulator-primitives.rkt"
+               [lookup-primitive (Symbol -> PrimitiveValue)]
+               [set-primitive! (Symbol PrimitiveValue -> Void)])
+
+(require/typed "simulator-helpers.rkt"
+               [ensure-primitive-value-box (SlotValue -> (Boxof PrimitiveValue))]
+               [ensure-primitive-value (SlotValue -> PrimitiveValue)]
+               [ensure-list (Any -> PrimitiveValue)]
+               [racket->PrimitiveValue (Any -> PrimitiveValue)])
+             
+
+(provide new-machine can-step? step! current-instruction
+         current-simulated-output-port
+         machine-control-size)
+
+
+(define current-simulated-output-port (make-parameter (current-output-port)))
+
+
+(: new-machine (case-lambda [(Listof Statement) -> machine]
+                            [(Listof Statement) Boolean -> machine]))
+(define new-machine
+  (case-lambda: 
+    [([program-text : (Listof Statement)])
+     (new-machine program-text #f)]
+    [([program-text : (Listof Statement)]
+      [with-bootstrapping-code? : Boolean])
+     (let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)]
+             [program-text : (Listof Statement)
+                           (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))
+                                (when (PairedLabel? stmt)
+                                  (hash-set! (machine-jump-table m) (PairedLabel-label stmt) i))
+                                (loop (add1 i)))))
+                  m))]))
+
+
+
+(: machine-control-size (machine -> Natural))
+(define (machine-control-size m)
+  (length (machine-control m)))
+
+
+
+
+(: can-step? (machine -> Boolean))
+;; Produces true if we can make a further step in the simulation.
+(define (can-step? m)
+  (< (machine-pc m)
+     (vector-length (machine-text m))))
+
+
+(: step! (machine -> 'ok))
+;; Take one simulation step.
+(define (step! m)
+  (let*: ([i : Statement (current-instruction m)]
+          [result : 'ok
+                  (cond
+                    [(symbol? i)
+                     'ok]
+                    [(PairedLabel? i)
+                     'ok]
+                    [(AssignImmediateStatement? i)
+                     (step-assign-immediate! m i)]
+                    [(AssignPrimOpStatement? i)
+                     (step-assign-primitive-operation! m i)]
+                    [(PerformStatement? i)
+                     (step-perform! m i)]
+                    [(GotoStatement? i)
+                     (step-goto! m i)]
+                    [(TestAndBranchStatement? i)
+                     (step-test-and-branch! m i)]
+                    [(PopEnvironment? i)
+                     (step-pop-environment! m i)]
+                    [(PushEnvironment? i)
+                     (step-push-environment! m i)]
+                    [(PushControlFrame? i)
+                     (step-push-control-frame! m i)]
+                    [(PushControlFrame/Prompt? i)
+                     (step-push-control-frame/prompt! m i)]
+                    [(PopControlFrame? i)
+                     (step-pop-control-frame! m i)]
+                    [(PopControlFrame/Prompt? i)
+                     (step-pop-control-frame! m i)])])
+         (increment-pc! m)))
+
+
+
+
+(: step-goto! (machine GotoStatement -> 'ok))
+(define (step-goto! m a-goto)
+  (let: ([t : (U Label Reg) (GotoStatement-target a-goto)])
+        (cond [(Label? t)
+               (jump! m (Label-name t))]
+              [(Reg? t)
+               (let: ([reg : AtomicRegisterSymbol (Reg-name t)])
+                     (cond [(AtomicRegisterSymbol? reg)
+                            (cond [(eq? reg 'val)
+                                   (jump! m (ensure-symbol (machine-val m)))]
+                                  [(eq? reg 'proc)
+                                   (jump! m (ensure-symbol (machine-proc m)))])]))])))
+
+(: step-assign-immediate! (machine AssignImmediateStatement -> 'ok))
+(define (step-assign-immediate! m stmt)
+  (let: ([t : Target (AssignImmediateStatement-target stmt)]
+         [v : SlotValue (evaluate-oparg m (AssignImmediateStatement-value stmt))])
+        ((get-target-updater t) m v)))
+
+
+(: step-push-environment! (machine PushEnvironment -> 'ok))
+(define (step-push-environment! m stmt)
+  (let: loop : 'ok ([n : Natural (PushEnvironment-n stmt)])
+        (cond
+          [(= n 0)
+           'ok]
+          [else
+           (env-push! m (if (PushEnvironment-unbox? stmt)
+                            (box (make-undefined))
+                            (make-undefined)))
+           (loop (sub1 n))])))
+
+(: step-pop-environment! (machine PopEnvironment -> 'ok))
+(define (step-pop-environment! m stmt)
+  (env-pop! m (PopEnvironment-n stmt) (PopEnvironment-skip stmt)))
+
+
+(: step-push-control-frame! (machine PushControlFrame -> 'ok))
+(define (step-push-control-frame! m stmt)
+  (control-push! m (make-CallFrame (PushControlFrame-label stmt)
+                                   (ensure-closure-or-false (machine-proc m)))))
+
+(: step-push-control-frame/prompt! (machine PushControlFrame/Prompt -> 'ok))
+(define (step-push-control-frame/prompt! m stmt)
+  (control-push! m (make-PromptFrame
+                    (let ([tag (PushControlFrame/Prompt-tag stmt)])
+                      (cond 
+                        [(DefaultContinuationPromptTag? tag)
+                         default-continuation-prompt-tag-value]
+                        [(OpArg? tag)
+                         (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))
+                    (PushControlFrame/Prompt-label stmt))))
+                        
+  
+
+(: step-pop-control-frame! (machine (U PopControlFrame PopControlFrame/Prompt) -> 'ok))
+(define (step-pop-control-frame! m stmt)
+  (let: ([l : Symbol (control-pop! m)])
+        'ok))
+
+(: step-test-and-branch! (machine TestAndBranchStatement -> 'ok))
+(define (step-test-and-branch! m stmt)
+  (let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]
+         [argval : SlotValue (lookup-atomic-register m (TestAndBranchStatement-register stmt))])
+        (if (cond
+              [(eq? test 'false?)
+               (not argval)]
+              [(eq? test 'primitive-procedure?)
+               (primitive-proc? argval)])
+            (jump! m (TestAndBranchStatement-label stmt))
+            'ok)))
+
+
+(: lookup-atomic-register (machine AtomicRegisterSymbol -> SlotValue))
+(define (lookup-atomic-register m reg)
+  (cond [(eq? reg 'val)
+         (machine-val m)]
+        [(eq? reg 'proc)
+         (machine-proc m)]))
+
+
+(: lookup-env-reference/closure-capture (machine EnvReference -> SlotValue))
+;; Capture values for the closure, given a set of environment references.
+(define (lookup-env-reference/closure-capture m ref)
+  (cond [(EnvLexicalReference? ref)
+         (if (EnvLexicalReference-unbox? ref)
+             (ensure-primitive-value-box (env-ref m (EnvLexicalReference-depth ref)))
+             (env-ref m (EnvLexicalReference-depth ref)))]
+        [(EnvWholePrefixReference? ref)
+         (env-ref m (EnvWholePrefixReference-depth ref))]))
+
+
+(: step-perform! (machine PerformStatement -> 'ok))
+(define (step-perform! m stmt)
+  (let: ([op : PrimitiveCommand (PerformStatement-op stmt)])
+        (cond
+          
+          [(CheckToplevelBound!? op)
+           (let: ([a-top : toplevel (ensure-toplevel (env-ref m (CheckToplevelBound!-depth op)))])
+                 (cond
+                   [(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op)))
+                    (error 'check-toplevel-bound! "Unbound identifier ~s" 
+                           (list-ref (toplevel-names a-top) (CheckToplevelBound!-pos op)))]
+                   [else
+                    'ok]))]
+          
+          [(CheckClosureArity!? op)
+           (let: ([clos : SlotValue (machine-proc m)])
+                 (cond
+                   [(closure? clos)
+                    (if (= (closure-arity clos)
+                           (CheckClosureArity!-arity op))
+                        'ok
+                        (error 'check-closure-arity "arity mismatch: passed ~s args to ~s"
+                               (CheckClosureArity!-arity op)
+                               (closure-display-name clos)))]
+                   [else
+                    (error 'check-closure-arity "not a closure: ~s" clos)]))]
+          
+          [(ExtendEnvironment/Prefix!? op)
+           (env-push! m 
+                      (make-toplevel (ExtendEnvironment/Prefix!-names op)
+                                     (map (lambda: ([name : (U Symbol ModuleVariable False)])
+                                                   (cond [(symbol? name)
+                                                          (lookup-primitive name)]
+                                                         [(ModuleVariable? name)
+                                                          (lookup-primitive (ModuleVariable-name name))]
+                                                         [(eq? name #f)
+                                                          (make-undefined)]))
+                                          (ExtendEnvironment/Prefix!-names op))))]
+          
+          [(InstallClosureValues!? op)
+           (let: ([a-proc : SlotValue (machine-proc m)])
+                 (cond
+                   [(closure? a-proc)
+                    (env-push-many! m (closure-vals a-proc))]
+                   [else
+                    (error 'step-perform "Procedure register doesn't hold a procedure: ~s"
+                           a-proc)]))]
+          
+          [(FixClosureShellMap!? op)
+           (let: ([a-closure-shell : closure (ensure-closure (env-ref m (FixClosureShellMap!-depth op)))])
+                 (set-closure-vals! a-closure-shell
+                                    (map (lambda: ([d : Natural]) (env-ref m d))
+                                         (FixClosureShellMap!-closed-vals op)))
+                 'ok)]
+          
+          [(RestoreControl!? op)
+           (let: ([tag-value : ContinuationPromptTagValue
+                             (let ([tag (RestoreControl!-tag op)])
+                               (cond
+                                 [(DefaultContinuationPromptTag? tag)
+                                  default-continuation-prompt-tag-value]
+                                 [(OpArg? tag)
+                                  (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))])
+                 (set-machine-control! m (compose-continuation-frames 
+                                          (CapturedControl-frames (ensure-CapturedControl (env-ref m 0)))
+                                          (drop-continuation-to-tag (machine-control m)
+                                                                    tag-value)))
+                 'ok)]
+
+          [(RestoreEnvironment!? op)
+           (set-machine-env! m (CapturedEnvironment-vals (ensure-CapturedEnvironment (env-ref m 1))))
+           (set-machine-stack-size! m (length (machine-env m)))
+           'ok])))
+
+
+
+(: compose-continuation-frames ((Listof frame) (Listof frame) -> (Listof frame)))
+;; Stitch together the continuation.  A PromptFrame must exist at the head of frames-2.
+(define (compose-continuation-frames frames-1 frames-2)
+  (append frames-1 frames-2))
+
+
+
+
+
+(: get-target-updater (Target -> (machine SlotValue -> 'ok)))
+(define (get-target-updater t)
+  (cond
+    [(eq? t 'proc)
+     proc-update!]
+    [(eq? t 'val)
+     val-update!]
+    [(EnvLexicalReference? t)
+     (lambda: ([m : machine] [v : SlotValue])
+              (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)
+     (lambda: ([m : machine] [v : SlotValue])
+              (toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t)))
+                                (EnvPrefixReference-pos t)
+                                (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))
+(define (step-assign-primitive-operation! m stmt)
+  (let: ([op : PrimitiveOperator (AssignPrimOpStatement-op stmt)]
+         [target-updater! : (machine SlotValue -> 'ok)
+                          (get-target-updater (AssignPrimOpStatement-target stmt))])
+        (cond
+          [(GetCompiledProcedureEntry? op)
+           (let: ([a-proc : SlotValue (machine-proc m)])
+                 (cond
+                   [(closure? a-proc)
+                    (target-updater! m (closure-label a-proc))]
+                   [else
+                    (error 'get-compiled-procedure-entry)]))]
+          
+          [(MakeCompiledProcedure? op)
+           (target-updater! m (make-closure (MakeCompiledProcedure-label op)
+                                            (MakeCompiledProcedure-arity op)
+                                            (map (lambda: ([d : Natural]) (env-ref m d))
+                                                 (MakeCompiledProcedure-closed-vals op))
+                                            (MakeCompiledProcedure-display-name op)))]
+
+          [(MakeCompiledProcedureShell? op)
+           (target-updater! m (make-closure (MakeCompiledProcedureShell-label op)
+                                            (MakeCompiledProcedureShell-arity op)
+                                            '()
+                                            (MakeCompiledProcedureShell-display-name op)))]
+          
+          [(ApplyPrimitiveProcedure? op)
+           (let: ([prim : SlotValue (machine-proc m)]
+                  [args : (Listof PrimitiveValue)
+                        (map ensure-primitive-value (take (machine-env m)
+                                                          (ApplyPrimitiveProcedure-arity op)))])
+                 (cond
+                   [(primitive-proc? prim)
+                    (target-updater! m (ensure-primitive-value 
+                                        (parameterize ([current-output-port
+                                                        (current-simulated-output-port)])
+                                          (apply (primitive-proc-f prim)
+                                                 m
+                                                 args))))]
+                   [else
+                    (error 'apply-primitive-procedure)]))]
+          
+          [(GetControlStackLabel? op)
+           (target-updater! m (let ([frame (ensure-frame (first (machine-control m)))])
+                                (cond
+                                  [(PromptFrame? frame)
+                                   (PromptFrame-return frame)]
+                                  [(CallFrame? frame)
+                                   (CallFrame-return frame)])))]
+
+          [(CaptureEnvironment? op)
+           (target-updater! m (make-CapturedEnvironment (drop (machine-env m)
+                                                              (CaptureEnvironment-skip op))))]
+          [(CaptureControl? op)
+           (target-updater! m (evaluate-continuation-capture m op))]
+          
+          [(MakeBoxedEnvironmentValue? op)
+           (target-updater! m (box (ensure-primitive-value
+                                    (env-ref m (MakeBoxedEnvironmentValue-depth op)))))]
+          
+          [(CallKernelPrimitiveProcedure? op)
+           (target-updater! m (evaluate-kernel-primitive-procedure-call m op))])))
+
+
+(: evaluate-continuation-capture (machine CaptureControl -> SlotValue))
+(define (evaluate-continuation-capture m op)
+  (let: ([frames : (Listof frame) (drop (machine-control m)
+                                        (CaptureControl-skip op))]
+         [tag : ContinuationPromptTagValue
+              (let ([tag (CaptureControl-tag op)])
+                (cond
+                  [(DefaultContinuationPromptTag? tag)
+                   default-continuation-prompt-tag-value]
+                  [(OpArg? tag)
+                   (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))])
+        (make-CapturedControl (take-continuation-to-tag frames tag))))
+
+
+(: take-continuation-to-tag ((Listof frame) ContinuationPromptTagValue -> (Listof frame)))
+(define (take-continuation-to-tag frames tag)
+  (cond
+    [(empty? frames)
+     (error 'trim-continuation-at-tag "Unable to find continuation tag value ~s" tag)]
+    [else
+     (let ([a-frame (first frames)])
+       (cond
+         [(CallFrame? a-frame)
+          (cons a-frame (take-continuation-to-tag (rest frames) tag))]
+         [(PromptFrame? a-frame)
+          (cond
+            [(eq? (PromptFrame-tag a-frame) tag)
+             '()]
+            [else
+             (cons a-frame (take-continuation-to-tag (rest frames) tag))])]))]))
+
+
+(: drop-continuation-to-tag ((Listof frame) ContinuationPromptTagValue -> (Listof frame)))
+;; Drops continuation frames until we reach the appropriate one.
+(define (drop-continuation-to-tag frames tag)
+  (cond
+    [(empty? frames)
+     (error 'trim-continuation-at-tag "Unable to find continuation tag value ~s" tag)]
+    [else
+     (let ([a-frame (first frames)])
+       (cond
+         [(CallFrame? a-frame)
+          (drop-continuation-to-tag (rest frames) tag)]
+         [(PromptFrame? a-frame)
+          (cond
+            [(eq? (PromptFrame-tag a-frame) tag)
+             frames]
+            [else
+             (drop-continuation-to-tag (rest frames) tag)])]))]))
+
+
+
+
+
+
+(: evaluate-kernel-primitive-procedure-call (machine CallKernelPrimitiveProcedure -> PrimitiveValue))
+(define (evaluate-kernel-primitive-procedure-call m op)
+  (let: ([op : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
+         [rand-vals : (Listof PrimitiveValue)
+                    (map (lambda: ([a : OpArg])
+                                  (ensure-primitive-value (evaluate-oparg m a)))
+                         (CallKernelPrimitiveProcedure-operands op))])
+        (case op
+          [(+)
+           (apply + (map ensure-number rand-vals))]
+          [(-)
+           (apply - (ensure-number (first rand-vals)) (map ensure-number (rest rand-vals)))]
+          [(*)
+           (apply * (map ensure-number rand-vals))]
+          [(/)
+           (apply / (ensure-number (first rand-vals)) (map ensure-number (rest rand-vals)))]
+          [(add1)
+           (add1 (ensure-number (first rand-vals)))]
+          [(sub1)
+           (sub1 (ensure-number (first rand-vals)))]
+          [(<)
+           (chain-compare < (map ensure-real-number rand-vals))]
+          [(<=)   
+           (chain-compare <= (map ensure-real-number rand-vals))]
+          [(=)
+           (chain-compare = (map ensure-real-number rand-vals))]
+          [(>)
+           (chain-compare > (map ensure-real-number rand-vals))]
+          [(>=)   
+           (chain-compare >= (map ensure-real-number rand-vals))]
+          [(cons)
+           (make-MutablePair (first rand-vals) (second rand-vals))]
+          [(car)
+           (MutablePair-h (ensure-mutable-pair (first rand-vals)))]
+          [(cdr)
+           (MutablePair-t (ensure-mutable-pair (first rand-vals)))]
+          [(list)
+           (let: loop : PrimitiveValue ([rand-vals : (Listof PrimitiveValue) rand-vals])
+             (cond [(empty? rand-vals)
+                    null]
+                   [else
+                    (make-MutablePair (first rand-vals)
+                                      (loop (rest rand-vals)))]))]
+          [(null?)
+           (null? (first rand-vals))]
+          [(not)
+           (not (first rand-vals))]
+          [(eq?)
+           (eq? (first rand-vals) (second rand-vals))]
+          [else
+           (error 'evaluate-kernel-primitive-procedure-call "missing operator: ~s\n" op)])))
+
+(: chain-compare (All (A) (A A -> Boolean) (Listof A) -> Boolean))
+(define (chain-compare f vals)
+  (cond
+    [(empty? vals)
+     #t]
+    [(empty? (rest vals))
+     #t]
+    [else
+     (and (f (first vals) (second vals))
+          (chain-compare f (rest vals)))]))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(: evaluate-oparg (machine OpArg -> SlotValue))
+(define (evaluate-oparg m an-oparg)
+  (cond
+    [(Const? an-oparg)
+     (racket->PrimitiveValue (Const-const an-oparg))]
+    
+    [(Label? an-oparg)
+     (Label-name an-oparg)]
+    
+    [(Reg? an-oparg)
+     (let: ([n : AtomicRegisterSymbol (Reg-name an-oparg)])
+           (cond
+             [(eq? n 'proc)
+              (machine-proc m)]
+             [(eq? n 'val)
+              (machine-val m)]))]
+    
+    [(EnvLexicalReference? an-oparg)
+     (let*: ([v : SlotValue
+                (env-ref m (EnvLexicalReference-depth an-oparg))]
+             [v : SlotValue
+                (if (EnvLexicalReference-unbox? an-oparg)
+                    (unbox (ensure-primitive-value-box v))
+                    v)])
+           (cond
+             [(toplevel? v)
+              (error 'evaluate-oparg
+                     "Unexpected toplevel at depth ~s"
+                     (EnvLexicalReference-depth an-oparg))]
+             [else v]))]
+    
+    [(EnvPrefixReference? an-oparg)
+     (let: ([a-top : SlotValue (env-ref m (EnvPrefixReference-depth an-oparg))])
+           (cond
+             [(toplevel? a-top)
+              (list-ref (toplevel-vals a-top)
+                        (EnvPrefixReference-pos an-oparg))]
+             [else
+              (error 'evaluate-oparg "not a toplevel: ~s" a-top)]))]
+    
+    
+    [(EnvWholePrefixReference? an-oparg)
+     (let: ([v : SlotValue
+               (list-ref (machine-env m) (EnvWholePrefixReference-depth an-oparg))])
+           (cond
+             [(toplevel? v)
+              v]
+             [else
+              (error 'evaluate-oparg "Internal error: not a toplevel at depth ~s: ~s"
+                     (EnvWholePrefixReference-depth an-oparg)
+                     v)]))]))
+
+
+(: ensure-closure-or-false (SlotValue -> (U closure #f)))
+(define (ensure-closure-or-false v)
+  (if (or (closure? v) (eq? v #f))
+      v
+      (error 'ensure-closure)))
+
+(: ensure-closure (SlotValue -> closure))
+(define (ensure-closure v)
+  (if (closure? v)
+      v
+      (error 'ensure-closure)))
+
+(: ensure-CallFrame (Any -> CallFrame))
+(define (ensure-CallFrame v)
+  (if (CallFrame? v)
+      v
+      (error 'ensure-CallFrame "not a CallFrame: ~s" v)))
+
+(: ensure-continuation-prompt-tag-value (Any -> ContinuationPromptTagValue))
+(define (ensure-continuation-prompt-tag-value v)
+  (if (ContinuationPromptTagValue? v)
+      v
+      (error 'ensure-ContinuationPromptTagValue "not a ContinuationPromptTagValue: ~s" v)))
+
+
+(: ensure-symbol (Any -> Symbol))
+;; Make sure the value is a symbol.
+(define (ensure-symbol v)
+  (cond
+    [(symbol? v)
+     v]
+    [else
+     (error 'ensure-symbol)]))
+
+
+(: ensure-toplevel (Any -> toplevel))
+(define (ensure-toplevel v)
+  (cond
+    [(toplevel? v)
+     v]
+    [else
+     (error 'ensure-toplevel)]))
+
+(: ensure-natural (Integer -> Natural))
+(define (ensure-natural x)
+  (if (>= x 0)
+      x
+      (error 'ensure-natural)))
+
+(: ensure-number (Any -> Number))
+(define (ensure-number x)
+  (if (number? x)
+      x
+      (error 'ensure-number "Not a number: ~s" x)))
+
+
+
+(: ensure-real-number (Any -> Real))
+(define (ensure-real-number x)
+  (if (real? x)
+      x
+      (error 'ensure-number "Not a number: ~s" x)))
+
+
+(: ensure-mutable-pair (Any -> MutablePair))
+(define (ensure-mutable-pair x)
+  (if (MutablePair? x)
+      x
+      (error 'ensure-mutable-pair "not a mutable pair: ~s" x)))
+
+(: ensure-prompt-frame (Any -> PromptFrame))
+(define (ensure-prompt-frame x)
+  (if (PromptFrame? x)
+      x
+      (error 'ensure-prompt-frame "not a PromptFrame: ~s" x)))
+
+(: ensure-frame (Any -> frame))
+(define (ensure-frame x)
+  (if (frame? x)
+      x
+      (error 'ensure-frame "not a frame: ~s" x)))
+
+
+(: ensure-CapturedControl (Any -> CapturedControl))
+(define (ensure-CapturedControl x)
+  (if (CapturedControl? x)
+      x
+      (error 'ensure-CapturedControl "~s" x)))
+
+
+
+
+(: ensure-CapturedEnvironment (Any -> CapturedEnvironment))
+(define (ensure-CapturedEnvironment x)
+  (if (CapturedEnvironment? x)
+      x
+      (error 'ensure-CapturedEnvironment "~s" x)))
+
+
+(: current-instruction (machine -> Statement))
+(define (current-instruction m)
+  (match m
+    [(struct machine (val proc env control pc text
+                          stack-size jump-table))
+     (vector-ref text pc)]))
+
+
+
+(: val-update! (machine SlotValue -> 'ok))
+(define (val-update! m v)
+  (set-machine-val! m v)
+  'ok)
+
+
+(: proc-update! (machine SlotValue -> 'ok))
+(define (proc-update! m v)
+  (set-machine-proc! m v)
+  'ok)
+
+
+(: env-push! (machine SlotValue -> 'ok))
+(define (env-push! m v)
+  (match m
+    [(struct machine (val proc env control pc text stack-size jump-table))
+     (set-machine-env! m (cons v env))
+     (set-machine-stack-size! m (add1 stack-size))
+     'ok]))
+
+(: env-push-many! (machine (Listof SlotValue) -> 'ok))
+(define (env-push-many! m vs)
+  (match m
+    [(struct machine (val proc env control pc text stack-size jump-table))
+     (set-machine-env! m (append vs env))
+     (set-machine-stack-size! m (+ stack-size (length vs)))
+     'ok]))
+
+
+(: env-ref (machine Natural -> SlotValue))
+(define (env-ref m i)  
+  (match m
+    [(struct machine (val proc env control pc text stack-size jump-table))
+     (list-ref env i)]))
+
+(: env-mutate! (machine Natural SlotValue -> 'ok))
+(define (env-mutate! m i v)
+  (match m
+    [(struct machine (val proc env control pc text stack-size jump-table))
+     (set-machine-env! m (list-replace env i v))
+     'ok]))
+
+
+(: list-replace (All (A) (Listof A) Natural A -> (Listof A)))
+(define (list-replace l i v)
+  (cond
+    [(= i 0)
+     (cons v (rest l))]
+    [else
+     (cons (first l)
+           (list-replace (rest l) (sub1 i) v))]))
+
+
+(: env-pop! (machine Natural Natural -> 'ok))
+(define (env-pop! m n skip)     
+  (match m
+    [(struct machine (val proc env control pc text stack-size jump-table))
+     (set-machine-env! m (append (take env skip)
+                                 (drop env (+ skip n))))
+     (set-machine-stack-size! m (ensure-natural (- stack-size n)))
+     'ok]))
+
+
+(: control-push! (machine frame -> 'ok))
+(define (control-push! m a-frame)
+  (match m
+    [(struct machine (val proc env control pc text stack-size jump-table))
+     (set-machine-control! m (cons a-frame control))
+     'ok]))
+
+
+(: control-pop! (machine -> 'ok))
+(define (control-pop! m)
+  (match m
+    [(struct machine (val proc env control pc text stack-size jump-table))
+     (set-machine-control! m (rest control))
+     'ok]))
+
+
+
+(: increment-pc! (machine -> 'ok))
+(define (increment-pc! m)
+  (set-machine-pc! m (add1 (machine-pc m)))
+  'ok)
+
+
+
+(: jump! (machine Symbol -> 'ok))
+;; Jumps directly to the instruction at the given label.
+(define (jump! m l)
+  (match m
+    [(struct machine (val proc env control pc text stack-size jump-table))
+     (set-machine-pc! m (hash-ref jump-table l))
+     'ok]))
+
+
+
+
+(: toplevel-mutate! (toplevel Natural PrimitiveValue -> 'ok))
+(define (toplevel-mutate! a-top index v)
+  (set-toplevel-vals! a-top (append (take (toplevel-vals a-top) index)
+                                    (list v)
+                                    (drop (toplevel-vals a-top) (add1 index))))
+  'ok)

test-all.rkt

@@ -0,0 +1,10 @@
+#lang racket
+
+(require "test-parse.rkt"
+         "test-simulator.rkt"
+         "test-compiler.rkt"
+         "test-assemble.rkt"
+         "test-browser-evaluate.rkt"
+         "test-package.rkt"
+         "test-conform-browser.rkt")
+#;"test-conform.rkt"

test-assemble.rkt

@@ -0,0 +1,368 @@
+#lang racket
+
+(require "assemble.rkt"
+         "browser-evaluate.rkt"
+         "lexical-structs.rkt"
+         "il-structs.rkt"
+         racket/port
+         racket/promise
+         racket/runtime-path)
+
+(define-runtime-path runtime.js "runtime.js")
+(define runtime (call-with-input-file runtime.js
+                  (lambda (ip) (port->string ip))))
+
+; Test out the compiler, using the simulator.
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ expr expected)
+     (with-syntax ([stx stx])
+       (syntax/loc #'stx
+         (begin
+           (printf "Running ~s ...\n" (syntax->datum #'expr))
+           (let ([actual 
+                  (with-handlers ([void
+                                   (lambda (exn)
+                                     (raise-syntax-error #f (format "Runtime error: got ~s" exn)
+                                                         #'stx))])
+                    expr)])
+             (unless (equal? actual expected)
+               (raise-syntax-error #f (format "Expected ~s, got ~s" expected actual)
+                                   #'stx))
+             (printf "ok.\n\n")))))]))
+
+
+;; evaluating single expression
+(define -E (delay (make-evaluate
+                   (lambda (a-statement+inspector op)
+                     (let* ([a-statement (car a-statement+inspector)]
+                            [inspector (cdr a-statement+inspector)]
+                            [snippet (assemble-statement a-statement)]
+                            [code
+                             (string-append
+                              "(function() { "
+
+                              runtime
+                              "var MACHINE = new plt.runtime.Machine();\n"
+
+                              "return function(success, fail, params){" 
+			      snippet
+                              (format "success(String(~a)); };" inspector)
+                              "});")])
+                       (displayln snippet)
+                       (display code op))))))
+(define (E-single a-statement (inspector "MACHINE.val"))
+  (evaluated-value ((force -E) (cons a-statement inspector))))
+
+;; evaluating many expressions[.
+(define -E-many (delay (make-evaluate
+                        (lambda (a-statement+inspector op)
+                          (let* ([a-statement (car a-statement+inspector)]
+                                 [inspector (cdr a-statement+inspector)])
+
+                            (display runtime op)
+                            (display "var MACHINE = new plt.runtime.Machine();\n" op)                           
+                            (display "(function() { " op)
+                            (display "var myInvoke = " op)
+                            (assemble/write-invoke a-statement op)
+                            (display ";" op)
+                            
+                            (fprintf op 
+                                     "return function(succ, fail, params) { myInvoke(MACHINE, function(v) { succ(String(~a));}, fail, params); }"
+                                     inspector)
+                            (display "})" op))))))
+(define (E-many stmts (inspector "MACHINE.val"))
+  (evaluated-value ((force -E-many) (cons stmts inspector))))
+
+
+
+
+
+
+
+
+;; Assigning a number
+(test (E-single (make-AssignImmediateStatement 'val (make-Const 42)))
+      "42")
+;; Assigning a string
+(test (E-single (make-AssignImmediateStatement 'val (make-Const "Danny")))
+      "Danny")
+;; Assigning a cons
+(test (E-single (make-AssignImmediateStatement 'val (make-Const (cons 1 2))))
+      "1,2")
+;; Assigning a void
+(test (E-single (make-AssignImmediateStatement 'val (make-Const (void))))
+      "null")
+;; Assigning to proc means val should still be uninitialized.
+(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny")))
+      "undefined")
+;; But we should see the assignment if we inspect MACHINE.proc.
+(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny"))
+                "MACHINE.proc")
+      "Danny")
+
+
+(test (E-single (make-PushEnvironment 1 #f)
+                "MACHINE.env.length")
+      "1")
+(test (E-single (make-PushEnvironment 20 #f)
+                "MACHINE.env.length")
+      "20")
+
+;; PopEnvironment
+(test (E-many (list (make-PushEnvironment 2 #f))
+              "MACHINE.env.length")
+      "2")
+(test (E-many (list (make-PushEnvironment 2 #f)
+                    (make-PopEnvironment 1 0))
+              "MACHINE.env.length")
+      "1")
+
+
+
+;; Assigning to the environment
+(test (E-many (list (make-PushEnvironment 2 #f)
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
+                                                   (make-Const 12345)))
+              "MACHINE.env[1]")
+      "12345")
+(test (E-many (list (make-PushEnvironment 2 #f)
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
+                                                   (make-Const 12345)))
+              "MACHINE.env[0]")
+      "undefined")
+(test (E-many (list (make-PushEnvironment 2 #f)
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
+                                                   (make-Const 12345)))
+              "MACHINE.env[0]")
+      "12345")
+
+
+;; Toplevel Environment loading
+(test (E-single (make-PerformStatement (make-ExtendEnvironment/Prefix! '(pi)))
+                "String(MACHINE.env[0]).slice(0, 5)")
+      "3.141")
+
+
+
+;; Simple application
+(test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
+                    (make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
+                    (make-PushEnvironment 2 #f)
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
+                                                   (make-Const 3))
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
+                                                   (make-Const 4))
+                    (make-AssignPrimOpStatement 'val
+                                                (make-ApplyPrimitiveProcedure 2))
+                    'done))
+      "7")
+
+
+
+
+;; A do-nothing closure
+(test (E-many (list (make-GotoStatement (make-Label 'afterLambda))
+                    'closureStart
+                    (make-GotoStatement (make-Label 'afterLambda))
+                    'afterLambda
+                    (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart)))
+              "MACHINE.val.displayName")
+      "closureStart")
+
+
+;; A do-nothing closure with a few values
+(test (E-many (list (make-GotoStatement (make-Label 'afterLambda))
+                    'closureStart
+                    (make-GotoStatement (make-Label 'afterLambda))
+                    'afterLambda
+                    (make-PushEnvironment 2 #f)
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
+                                                   (make-Const "hello"))
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
+                                                   (make-Const "world"))
+                    (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 
+                                                                                 (list 0 1)
+                                                                                 'closureStart)))
+              "MACHINE.val.closedVals[1] + ',' + MACHINE.val.closedVals[0]")
+      "hello,world")
+
+;; Let's try to install the closure values.
+(test (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
+                    
+                    'closureStart
+                    (make-PerformStatement (make-InstallClosureValues!))
+                    (make-GotoStatement (make-Label 'theEnd))
+
+                    'afterLambdaBody
+                    (make-PushEnvironment 2 #f)
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
+                                                   (make-Const "hello"))
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
+                                                   (make-Const "world"))
+                    (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 
+                                                                                 (list 0 1)
+                                                                                 'closureStart))
+                    (make-PopEnvironment 2 0)
+                    (make-GotoStatement (make-Label 'closureStart))
+                    'theEnd)
+              "String(MACHINE.env.length) + ',' + MACHINE.env[1] + ',' + MACHINE.env[0]")
+      "2,hello,world")
+
+
+
+;; get-compiled-procedure-entry
+(test (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
+                    
+                    'closureStart
+                    (make-PerformStatement (make-InstallClosureValues!))
+                    (make-GotoStatement (make-Label 'theEnd))
+
+                    'afterLambdaBody
+                    (make-PushEnvironment 2 #f)
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
+                                                   (make-Const "hello"))
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
+                                                   (make-Const "world"))
+                    (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 
+                                                                                 (list 0 1)
+                                                                                 'closureStart))
+                    (make-PopEnvironment 2 0)
+                    (make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)))
+              "typeof(MACHINE.val) + ',' + (MACHINE.val === MACHINE.proc.label)")
+      "function,true")
+
+
+;; check-closure-arity.  This should succeed.
+(void (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
+                    
+                    'closureStart
+                    (make-PerformStatement (make-InstallClosureValues!))
+                    (make-GotoStatement (make-Label 'theEnd))
+
+                    'afterLambdaBody
+                    (make-PushEnvironment 2 #f)
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
+                                                   (make-Const "hello"))
+                    (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
+                                                   (make-Const "world"))
+                    (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 
+                                                                                  (list 0 1)
+                                                                                  'closureStart))
+                    (make-PopEnvironment 2 0)
+                    (make-PerformStatement (make-CheckClosureArity! 5)))))
+
+;; this should fail, since the check is for 1, but the closure expects 5.
+(let/ec return
+  (with-handlers ([void
+                   (lambda (exn) (return))])
+    (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
+                  
+                  'closureStart
+                  (make-PerformStatement (make-InstallClosureValues!))
+                  (make-GotoStatement (make-Label 'theEnd))
+                  
+                  'afterLambdaBody
+                  (make-PushEnvironment 2 #f)
+                  (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
+                                                 (make-Const "hello"))
+                  (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
+                                                 (make-Const "world"))
+                  (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 
+                                                                                (list 0 1)
+                                                                                'closureStart))
+                  (make-PopEnvironment 2 0)
+                  (make-PerformStatement (make-CheckClosureArity! 1)))))
+  (error 'expected-failure))
+
+
+
+
+
+(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const 42))
+                ,(make-TestAndBranchStatement 'false? 'val 'onFalse)
+                ,(make-AssignImmediateStatement 'val (make-Const 'ok))
+                ,(make-GotoStatement (make-Label 'end))
+                onFalse
+                ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
+                end))
+      "ok")
+
+;; TestAndBranch: try the false branch
+(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const #f))
+                ,(make-TestAndBranchStatement 'false? 'val 'onFalse)
+                ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
+                ,(make-GotoStatement (make-Label 'end))
+                onFalse
+                ,(make-AssignImmediateStatement 'val (make-Const 'ok))
+                end))
+      "ok")
+
+;; Test for primitive procedure
+(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+))
+                ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
+                ,(make-AssignImmediateStatement 'val (make-Const 'ok))
+                ,(make-GotoStatement (make-Label 'end))
+                onTrue
+                ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
+                end))
+      "ok")
+
+;; Give a primitive procedure in val
+(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
+                ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))
+                ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
+                ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
+                ,(make-GotoStatement (make-Label 'end))
+                onTrue
+                ,(make-AssignImmediateStatement 'val (make-Const 'ok))
+                end))
+      "ok")
+
+;; Give a primitive procedure in proc, but test val
+(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
+                ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
+                ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
+                ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
+                ,(make-GotoStatement (make-Label 'end))
+                onTrue
+                ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
+                end))
+      "not-a-procedure")
+
+;; Give a primitive procedure in proc and test proc
+(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
+                ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
+                ,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'onTrue)
+                ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
+                ,(make-GotoStatement (make-Label 'end))
+                onTrue
+                ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
+                end))
+      "a-procedure")
+
+
+
+;; Set-toplevel
+(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor)))
+                ,(make-AssignImmediateStatement 'val (make-Const "Kathi"))
+                ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)))
+              "MACHINE.env[0][0]")
+      "Kathi")
+
+
+;; check-toplevel-bound
+(let/ec return
+  (let ([dont-care 
+         (with-handlers ([void (lambda (exn) (return))])
+           (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
+                     ,(make-PerformStatement (make-CheckToplevelBound! 0 0)))))])
+    (raise "I expected an error")))
+  
+;; check-toplevel-bound shouldn't fail here.
+(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor)))
+                ,(make-AssignImmediateStatement 'val (make-Const "Shriram"))
+                ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
+                ,(make-PerformStatement (make-CheckToplevelBound! 0 0)))
+              "MACHINE.env[0][0]")
+      "Shriram")

test-browser-evaluate.rkt

@@ -0,0 +1,329 @@
+#lang racket
+(require "browser-evaluate.rkt"
+         "package.rkt"
+         racket/runtime-path)
+
+
+(define-runtime-path runtime.js 
+  "runtime.js" 
+  #;"runtime.compressed.js")
+
+(define evaluate (make-evaluate 
+                  (lambda (program op)
+
+                    (fprintf op "(function () {")
+                    
+                    ;; The runtime code
+                    (call-with-input-file* runtime.js
+                      (lambda (ip)
+                        (copy-port ip op)))
+                    
+                    (newline op)
+                    
+                    (fprintf op "var innerInvoke = ")
+                    (package-anonymous program op)
+                    (fprintf op "();\n")
+                    
+                    (fprintf op #<<EOF
+return (function(succ, fail, params) {
+            return innerInvoke(new plt.runtime.Machine(), succ, fail, params);
+        });
+});
+EOF
+                             )
+                    
+                    )))
+
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ s exp)
+     (with-syntax ([stx stx])
+       (syntax/loc #'stx
+         (begin
+           (printf "running test... ~s" (syntax->datum #'stx))
+           (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))))))]))
+
+(define-syntax (test/exn stx)
+  (syntax-case stx ()
+    [(_ s exp)
+     (with-syntax ([stx stx])
+       (syntax/loc #'stx
+         (begin
+           (printf "running test...")
+           (let ([an-error-happened 
+                  (with-handlers ([error-happened?
+                                   (lambda (exn)
+                                     exn)])
+                    (let ([r (evaluate s)])
+                      (raise-syntax-error #f (format "Expected exception, but got ~s" r)
+                                          #'stx)))]) 
+             (unless (string=? exp (error-happened-str an-error-happened))
+               (printf " error!\n")
+               (raise-syntax-error #f (format "Expected ~s, got ~s" exp (error-happened-str an-error-happened))
+                                   #'stx))
+             (printf " ok (~a milliseconds)\n" (error-happened-t an-error-happened))))))]))
+
+
+
+
+(test '(display 42)
+      "42")
+
+(test '(display (+ 3 4))
+      "7")
+
+(test/exn (evaluate '(+ "hello" 3))
+          "Error: Expected number as argument 1 but received hello")
+
+
+(test '(display (/ 100 4))
+      "25")
+(test/exn (evaluate '(/ 3 'four))
+          "Error: Expected number as argument 2 but received four")
+
+
+(test '(display (- 1))
+      "-1")
+
+(test/exn '(- 'one)
+          "Error: Expected number as argument 1 but received one")
+
+(test '(display (- 5 4))
+      "1")
+
+(test '(display (* 3 17))
+      "51")
+
+(test/exn '(* "three" 17)
+          "Error: Expected number as argument 1 but received three")
+
+(test '(display '#t)
+      "true")
+
+(test '(display '#f)
+      "false")
+
+(test '(displayln (not #t))
+      "false\n")
+
+(test '(displayln (not #f))
+      "true\n")
+
+(test '(displayln (not 3))
+      "false\n")
+
+(test '(displayln (not (not 3)))
+      "true\n")
+
+(test '(displayln (add1 1))
+      "2\n")
+
+(test/exn '(displayln (add1 "0"))
+          "Error: Expected number as argument 1 but received 0")
+
+(test '(displayln (sub1 1))
+      "0\n")
+
+(test/exn '(displayln (sub1 "0"))
+          "Error: Expected number as argument 1 but received 0")
+
+(test '(displayln (< 1 2))
+      "true\n")
+
+(test '(displayln (<= 1 2))
+      "true\n")
+
+(test '(displayln (= 1 2))
+      "false\n")
+
+(test '(displayln (> 1 2))
+      "false\n")
+
+(test '(displayln (>= 1 2))
+      "false\n")
+
+(test '(displayln (car (cons 3 4)))
+      "3\n")
+
+(test '(displayln (cdr (cons 3 4)))
+      "4\n")
+
+(test '(displayln (let ([x (cons 5 6)])
+                    (car x)))
+      "5\n")
+
+(test '(displayln (let ([x (cons 5 6)])
+                    (cdr x)))
+      "6\n")
+
+(test '(displayln (length (list 'hello 4 5)))
+      "3\n")
+
+
+
+(test '(begin (define (f x) 
+                (if (= x 0)
+                    0
+                    (+ x (f (- x 1)))))
+              (display (f 3))
+              (display "\n")
+              (display (f 4))
+              (display "\n")
+              (display (f 10000)))
+      "6\n10\n50005000")
+
+(test '(begin (define (length l)
+                (if (null? l)
+                    0
+                    (+ 1 (length (cdr l)))))
+              (display (length (list 1 2 3 4 5 6)))
+              (newline)
+              (display (length (list "hello" "world")))
+              (newline))
+              
+      "6\n2\n")
+
+(test '(begin (define (tak x y z)
+                (if (< y x)
+                    (tak (tak (- x 1) y z)
+                         (tak (- y 1) z x)
+                         (tak (- z 1) x y))
+                    z))
+              (display (tak 18 12 6)))
+      "7")
+
+
+(test '(begin (define (fib x)
+                (if (< x 2)
+                    x
+                    (+ (fib (- x 1))
+                       (fib (- x 2)))))
+              (displayln (fib 3))
+              (displayln (fib 4))
+              (displayln (fib 5))
+              (displayln (fib 6)))
+      "2\n3\n5\n8\n")
+      
+
+(test '(begin (define (tak x y z)
+               (if (>= y x)
+                   z
+                   (tak (tak (- x 1) y z)
+                        (tak (- y 1) z x)
+                        (tak (- z 1) x y))))
+             (displayln (tak 18 12 6)))
+        "7\n")
+
+
+
+(test '(begin (displayln (+ 42 (call/cc (lambda (k) 3)))) )
+      "45\n")
+
+
+(test '(begin (displayln (+ 42 (call/cc (lambda (k) (k 100) 3)))) )
+      "142\n")
+
+(test '(begin (displayln (+ 42 (call/cc (lambda (k) 100 (k 3))))) )
+      "45\n")
+
+
+(test '(begin (define program (lambda ()
+                                (let ((y (call/cc (lambda (c) c))))
+                                  (display 1)
+                                  (call/cc (lambda (c) (y c)))
+                                  (display 2)
+                                  (call/cc (lambda (c) (y c)))
+                                  (display 3))))
+              (program))
+      "11213")
+
+
+(test '(begin (define (f return)
+                (return 2)
+                3)
+              (display (f (lambda (x) x))) ; displays 3
+              (display (call/cc f)) ;; displays 2
+              )
+      "32")
+
+(test  '(begin
+          (define (ctak x y z)
+            (call-with-current-continuation
+             (lambda (k)
+               (ctak-aux k x y z))))
+          
+          (define (ctak-aux k x y z)
+            (cond ((not (< y x))  ;xy
+                   (k z))
+                  (else (call-with-current-continuation
+                         (ctak-aux
+                          k
+                          (call-with-current-continuation
+                           (lambda (k)
+                             (ctak-aux k
+                                       (- x 1)
+                                       y
+                                       z)))
+                          (call-with-current-continuation
+                           (lambda (k)
+                             (ctak-aux k
+                                       (- y 1)
+                                       z
+                                       x)))
+                          (call-with-current-continuation
+                           (lambda (k)
+                             (ctak-aux k
+                                       (- z 1)
+                                       x
+                                       y))))))))
+          (displayln (ctak 18 12 6)))
+       "7\n")
+
+(test '(letrec ([f (lambda (x)
+                    (if (= x 0)
+                        1
+                        (* x (f (sub1 x)))))])
+         (display (f 10)))
+      "3628800")
+
+(test '(letrec ([tak (lambda (x y z)
+                       (if (>= y x)
+                           z
+                           (tak (tak (- x 1) y z)
+                                (tak (- y 1) z x)
+                                (tak (- z 1) x y))))])
+         (displayln (tak 18 12 6)))
+        "7\n")
+
+
+
+
+(test '(begin (define counter 0)
+              (set! counter (add1 counter))
+              (displayln counter))
+      "1\n")
+
+(test '(begin (define x 16)
+              (define (f x)
+                (set! x (add1 x))
+                x)
+              (displayln (f 3))
+              (displayln (f 4))
+              (displayln x))
+      "4\n5\n16\n")
+      
+
+(test/exn '(let ([x 0])
+             (set! x "foo")
+             (add1 x))
+          "Error: Expected number as argument 1 but received foo")
+
+
+#;(test (read (open-input-file "tests/conform/program0.sch"))
+      (port->string (open-input-file "tests/conform/expected0.txt")))

test-conform-browser.rkt

@@ -0,0 +1,52 @@
+#lang racket
+(require "browser-evaluate.rkt"
+         "package.rkt"
+         racket/port
+         racket/runtime-path)
+
+(define-runtime-path runtime.js "runtime.js")
+
+(define evaluate (make-evaluate 
+                  (lambda (program op)
+
+                    (fprintf op "(function () {")
+                    
+                    ;; The runtime code
+                    (call-with-input-file* runtime.js
+                      (lambda (ip)
+                        (copy-port ip op)))
+                    
+                    (newline op)
+                    
+                    (fprintf op "var innerInvoke = ")
+                    (package-anonymous program op)
+                    (fprintf op "();\n")
+                    
+                    (fprintf op #<<EOF
+return (function(succ, fail, params) {
+            return innerInvoke(new plt.runtime.Machine(), succ, fail, params);
+        });
+});
+EOF
+                             )
+                    
+                    )))
+
+(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-conform.rkt

@@ -1,13 +1,14 @@
 #lang racket
 
-(require "../simulator/simulator.rkt"
-         "../simulator/simulator-structs.rkt"
-         "test-helpers.rkt"
-         racket/runtime-path)
+(require "simulator.rkt"
+         "simulator-structs.rkt"
+         "compile.rkt"
+         "parse.rkt"
+         "il-structs.rkt")
 
 
-(define-runtime-path conform-path "conform")
-
+(define (run-compiler code)
+  (compile (parse code) 'val next-linkage))
   
 ;; run: machine -> (machine number)
 ;; Run the machine to completion.
@@ -55,7 +56,7 @@
              (printf "ok. ~s steps.\n\n" num-steps)))))]))
 
 
-(test (read (open-input-file (build-path conform-path "program0.sch")))
-      (port->string (open-input-file (build-path conform-path "expected0.txt")))
+(test (read (open-input-file "tests/conform/program0.sch"))
+      (port->string (open-input-file "tests/conform/expected0.txt"))
       ;;#:debug? #t
       )

test-package.rkt

@@ -1,18 +1,9 @@
 #lang racket/base
 
-(require "../js-assembler/package.rkt"
-         "../make/make-structs.rkt")
-
-(printf "test-package.rkt\n")
-
-
-(define (follow? src)
-  #t)
+(require "package.rkt")
 
 (define (test s-exp)
-  (package (make-SexpSource s-exp)
-           #:should-follow-children? follow?
-           #:output-port (open-output-string) #;(current-output-port)))
+  (package s-exp (open-output-string) #;(current-output-port)))
 
 
 (test '(define (factorial n)
@@ -20,14 +11,13 @@
                1
                (* (factorial (- n 1))
                   n))))
-(test '(let ()
+(test '(begin
          (define (factorial n)
            (fact-iter n 1))
          (define (fact-iter n acc)
            (if (= n 0)
                acc
-               (fact-iter (- n 1) (* acc n))))
-         'ok))
+               (fact-iter (- n 1) (* acc n))))))
 
 (test '(define (gauss n)
          (if (= n 0)

test-parse.rkt

@@ -1,19 +1,10 @@
 #lang racket/base
-(require (rename-in "../parser/baby-parser.rkt"
-                    [parse baby-parse])
-         "../compiler/lexical-structs.rkt"
-         "../compiler/expression-structs.rkt"
+
+(require "parse.rkt"
+         "lexical-structs.rkt"
+         "expression-structs.rkt"
          (for-syntax racket/base))
 
-
-(define (parse x)
-  (parameterize ([current-short-labels? #f])
-    (reset-make-label-counter)
-    (baby-parse x)))
-
-
-(printf "test-parse.rkt\n");
-
 ; Test out the compiler, using the simulator.
 (define-syntax (test stx)
   (syntax-case stx ()
@@ -22,6 +13,7 @@
        (syntax/loc #'stx
          (begin
            (printf "Running ~s ...\n" (syntax->datum #'expr))
+           (set-private-lam-label-counter! 0)
            (let ([expected expt]
                  [actual 
                   (with-handlers ([void
@@ -30,8 +22,8 @@
                                                          #'stx))])
                     expr)])
              (unless (equal? actual expected)
-               (printf (format "Expected ~s, got ~s, at	~s" expected actual
-                                   (syntax-line #'stx))))
+               (raise-syntax-error #f (format "Expected ~s, got ~s" expected actual)
+                                   #'stx))
              (printf "ok.\n\n")))))]))
 
 
@@ -46,101 +38,71 @@
 
 (test (parse 'hello) 
       (make-Top (make-Prefix '(hello)) 
-                (make-ToplevelRef 0 0 #f #t)))
+                (make-ToplevelRef 0 0)))
 
 (test (parse '(begin hello world))
       (make-Top (make-Prefix '(hello world)) 
-                (make-Splice (list (make-ToplevelRef 0 0 #f #t)
-                                (make-ToplevelRef 0 1 #f #t)))))
+                (make-Splice (list (make-ToplevelRef 0 0)
+                                (make-ToplevelRef 0 1)))))
 
 (test (parse '(define x y))
       (make-Top (make-Prefix '(x y))
-                (make-ToplevelSet 0 0  (make-ToplevelRef 0 1 #f #t))))
+                (make-ToplevelSet 0 0 'x (make-ToplevelRef 0 1))))
 
 (test (parse '(begin (define x 42)
                      (define y x)))
       (make-Top (make-Prefix '(x y))
-                (make-Splice (list (make-ToplevelSet 0 0 (make-Constant 42))
-                                   (make-ToplevelSet 0 1 (make-ToplevelRef 0 0 #f #t))))))
+                (make-Splice (list (make-ToplevelSet 0 0 'x (make-Constant 42))
+                                   (make-ToplevelSet 0 1 'y (make-ToplevelRef 0 0))))))
 
 (test (parse '(if x y z))
       (make-Top (make-Prefix '(x y z))
-                (make-Branch (make-ToplevelRef 0 0 #f #t)
-                             (make-ToplevelRef 0 1 #f #t)
-                             (make-ToplevelRef 0 2 #f #t))))
+                (make-Branch (make-ToplevelRef 0 0)
+                             (make-ToplevelRef 0 1)
+                             (make-ToplevelRef 0 2))))
 
 (test (parse '(if x (if y z 1) #t))
       (make-Top (make-Prefix '(x y z))
-                (make-Branch (make-ToplevelRef 0 0 #f #t)
-                             (make-Branch (make-ToplevelRef 0 1 #f #t)
-                                          (make-ToplevelRef 0 2 #f #t)
+                (make-Branch (make-ToplevelRef 0 0)
+                             (make-Branch (make-ToplevelRef 0 1)
+                                          (make-ToplevelRef 0 2)
                                           (make-Constant 1))
                              (make-Constant #t))))
 
 (test (parse '(if x y))
       (make-Top (make-Prefix '(x y))
-                (make-Branch (make-ToplevelRef 0 0 #f #t)
-                             (make-ToplevelRef 0 1 #f #t)
+                (make-Branch (make-ToplevelRef 0 0)
+                             (make-ToplevelRef 0 1)
                              (make-Constant (void)))))
 
 (test (parse '(cond [x y]))
       (make-Top (make-Prefix '(x y))
-                (make-Branch (make-ToplevelRef 0 0 #f #t)
-                             (make-ToplevelRef 0 1 #f #t)
+                (make-Branch (make-ToplevelRef 0 0)
+                             (make-ToplevelRef 0 1)
                              (make-Constant (void)))))
 
 (test (parse '(cond [x y] [else "ok"]))
       (make-Top (make-Prefix '(x y))
-                (make-Branch (make-ToplevelRef 0 0 #f #t)
-                             (make-ToplevelRef 0 1 #f #t)
+                (make-Branch (make-ToplevelRef 0 0)
+                             (make-ToplevelRef 0 1)
                              (make-Constant "ok"))))
 
-(test (parse '(lambda () x))
-      (make-Top (make-Prefix '(x))
-                (make-Lam 'unknown 0 #f (make-ToplevelRef 0 0 #f #t) 
-                          '(0) 'lamEntry1)))
-
-(test (parse '(lambda args args))
-      (make-Top (make-Prefix '())
-                (make-Lam 'unknown 0 #t (make-LocalRef 0 #f) 
-                          '() 'lamEntry1)))
-
-(test (parse '(lambda (x y . z) x))
-      (make-Top (make-Prefix '())
-                (make-Lam 'unknown 2 #t 
-                          (make-LocalRef 0 #f)
-                          '() 'lamEntry1)))
-
-(test (parse '(lambda (x y . z) y))
-      (make-Top (make-Prefix '())
-                (make-Lam 'unknown 2 #t 
-                          (make-LocalRef 1 #f)
-                          '() 'lamEntry1)))
-
-
-(test (parse '(lambda (x y . z) z))
-      (make-Top (make-Prefix '())
-                (make-Lam 'unknown 2 #t 
-                          (make-LocalRef 2 #f)
-                          '() 'lamEntry1)))
-
-
 (test (parse '(lambda (x y z) x))
       (make-Top (make-Prefix '())
-                (make-Lam 'unknown 3 #f (make-LocalRef 0 #f) '() 'lamEntry1)))
+                (make-Lam #f 3 (make-LocalRef 0 #f) '() 'lamEntry1)))
 
 (test (parse '(lambda (x y z) y))
       (make-Top (make-Prefix '())
-                (make-Lam 'unknown 3 #f (make-LocalRef 1 #f) '() 'lamEntry1)))
+                (make-Lam #f 3 (make-LocalRef 1 #f) '() 'lamEntry1)))
 
 (test (parse '(lambda (x y z) z))
       (make-Top (make-Prefix '())
-                (make-Lam 'unknown 3 #f (make-LocalRef 2 #f) '() 'lamEntry1)))
+                (make-Lam #f 3 (make-LocalRef 2 #f) '() 'lamEntry1)))
 
 
 (test (parse '(lambda (x y z) x y z))
       (make-Top (make-Prefix '())
-                (make-Lam 'unknown 3 #f (make-Seq (list (make-LocalRef 0 #f)
+                (make-Lam #f 3 (make-Seq (list (make-LocalRef 0 #f)
                                             (make-LocalRef 1 #f)
                                             (make-LocalRef 2 #f)))
                           '()
@@ -148,19 +110,16 @@
 
 (test (parse '(lambda (x y z) k))
       (make-Top (make-Prefix '(k))
-                (make-Lam 'unknown 
+                (make-Lam #f 
                           3 
-                          #f
-                          (make-ToplevelRef 0 0 #f #t)
+                          (make-ToplevelRef 0 0 )
                           '(0)
                           'lamEntry1)))
 
 (test (parse '(lambda (x y z) k x y z))
       (make-Top (make-Prefix '(k))
-                (make-Lam 'unknown
-                          3 
-                          #f
-                          (make-Seq (list (make-ToplevelRef 0 0 #f #t)
+                (make-Lam #f
+                          3 (make-Seq (list (make-ToplevelRef 0 0 )
                                             (make-LocalRef 1 #f)
                                             (make-LocalRef 2 #f)
                                             (make-LocalRef 3 #f)))
@@ -175,14 +134,14 @@
                     z
                     w))))
       (make-Top (make-Prefix '(w))
-                (make-Lam 'unknown 1 #f 
-                          (make-Lam 'unknown 1 #f
-                                    (make-Lam 'unknown 1 #f
+                (make-Lam #f 1 
+                          (make-Lam #f 1
+                                    (make-Lam #f 1
                                               (make-Seq (list 
                                                          (make-LocalRef 1 #f)
                                                          (make-LocalRef 2 #f)
                                                          (make-LocalRef 3 #f)
-                                                         (make-ToplevelRef 0 0 #f #t)))
+                                                         (make-ToplevelRef 0 0)))
                                               '(0 1 2) ;; w x y
                                               'lamEntry1)
                                     
@@ -195,8 +154,8 @@
                 (lambda (y)
                   x)))
       (make-Top (make-Prefix '())
-                (make-Lam 'unknown 1 #f
-                          (make-Lam 'unknown 1 #f
+                (make-Lam #f 1
+                          (make-Lam #f 1
                                     (make-LocalRef 0 #f)
                                     '(0)
                                     'lamEntry1)
@@ -207,8 +166,8 @@
                 (lambda (y)
                   y)))
       (make-Top (make-Prefix '())
-                (make-Lam 'unknown 1 #f
-                          (make-Lam 'unknown 1 #f
+                (make-Lam #f 1
+                          (make-Lam #f 1
                                     (make-LocalRef 0 #f)
                                     (list)
                                     'lamEntry1)
@@ -216,17 +175,17 @@
                           'lamEntry2)))
 
 (test (parse '(+ x x))
-      (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleLocator '#%kernel '#%kernel))
+      (make-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel) 
                                x))
-                (make-App (make-ToplevelRef 2 0 #f #t)
-                          (list (make-ToplevelRef 2 1 #f #t)
-                                (make-ToplevelRef 2 1 #f #t)))))
+                (make-App (make-ToplevelRef 2 0)
+                          (list (make-ToplevelRef 2 1)
+                                (make-ToplevelRef 2 1)))))
   
 
 (test (parse '(lambda (x) (+ x x)))
-      (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleLocator '#%kernel '#%kernel))))
-                (make-Lam 'unknown 1 #f
-                          (make-App (make-ToplevelRef 2 0 #f #t)
+      (make-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel)))
+                (make-Lam #f 1
+                          (make-App (make-ToplevelRef 2 0)
                                     (list (make-LocalRef 3 #f)
                                           (make-LocalRef 3 #f)))
                           '(0)
@@ -234,14 +193,14 @@
 
 (test (parse '(lambda (x) 
                 (+ (* x x) x)))
-      (make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleLocator '#%kernel '#%kernel))
-                               ,(make-ModuleVariable '+ (make-ModuleLocator '#%kernel '#%kernel))))
-                (make-Lam 'unknown 1 #f
+      (make-Top (make-Prefix `(,(make-ModuleVariable '* '#%kernel)
+                               ,(make-ModuleVariable '+ '#%kernel)))
+                (make-Lam #f 1
                           ;; stack layout: [???, ???, prefix, x]
-                          (make-App (make-ToplevelRef 2 1 #f #t)
+                          (make-App (make-ToplevelRef 2 1)
                                     (list
                                      ;; stack layout: [???, ???, ???, ???, prefix, x]
-                                     (make-App (make-ToplevelRef 4 0 #f #t)
+                                     (make-App (make-ToplevelRef 4 0)
                                                (list (make-LocalRef 5 #f)
                                                      (make-LocalRef 5 #f)))
                                      (make-LocalRef 3 #f)))
@@ -251,7 +210,7 @@
 (test (parse '(let ()
                 x))
       (make-Top (make-Prefix '(x))
-                (make-ToplevelRef 0 0 #f #t)))
+                (make-ToplevelRef 0 0)))
 
 (test (parse '(let ([x 3])
                 x))
@@ -265,8 +224,8 @@
                 y))
       (make-Top (make-Prefix '())
                 (make-LetVoid 2
-                              (make-Seq (list (make-InstallValue 1 0 (make-Constant 3) #f)
-                                              (make-InstallValue 1 1 (make-Constant 4) #f)
+                              (make-Seq (list (make-InstallValue 0 (make-Constant 3) #f)
+                                              (make-InstallValue 1 (make-Constant 4) #f)
                                               (make-Seq (list (make-LocalRef 0 #f)
                                                               (make-LocalRef 1 #f)))))
                               #f)))
@@ -279,11 +238,11 @@
                   y)))
       (make-Top (make-Prefix '())
                 (make-LetVoid 2
-                              (make-Seq (list (make-InstallValue 1 0 (make-Constant 3) #f)
-                                              (make-InstallValue 1 1 (make-Constant 4) #f)
+                              (make-Seq (list (make-InstallValue 0 (make-Constant 3) #f)
+                                              (make-InstallValue 1 (make-Constant 4) #f)
                                               (make-LetVoid 2
-                                                            (make-Seq (list (make-InstallValue 1 0 (make-LocalRef 3 #f) #f)
-                                                                            (make-InstallValue 1 1 (make-LocalRef 2 #f) #f)
+                                                            (make-Seq (list (make-InstallValue 0 (make-LocalRef 3 #f) #f)
+                                                                            (make-InstallValue 1 (make-LocalRef 2 #f) #f)
                                                                             (make-Seq (list (make-LocalRef 0 #f)
                                                                                             (make-LocalRef 1 #f)))))
                                                             #f)))
@@ -294,7 +253,7 @@
 (test (parse '(let* ([x 3]
                      [x (add1 x)])
                 (add1 x)))
-      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleLocator '#%kernel '#%kernel))))
+      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
                 
                 ;; stack layout: [prefix]
                 
@@ -309,10 +268,10 @@
                             (make-App 
                              
                              ;; stack layout: [???, ???, x_0, prefix]
-                             (make-ToplevelRef 3 0 #f #t) (list (make-LocalRef 2 #f)))
+                             (make-ToplevelRef 3 0) (list (make-LocalRef 2 #f)))
                             
                             ;; stack layout [???, x_1, x_0, prefix]
-                            (make-App (make-ToplevelRef 3 0 #f #t)
+                            (make-App (make-ToplevelRef 3 0)
                                       (list (make-LocalRef 1 #f)))))))
 
 
@@ -326,11 +285,9 @@
 (test (parse '(letrec ([omega (lambda () (omega))])
                 (omega)))
       (make-Top (make-Prefix '())
-                (make-LetVoid 1
-                              (make-LetRec (list (make-Lam 'omega 0 #f (make-App (make-LocalRef 0 #f) 
-                                                                                 (list)) '(0) 'lamEntry1))
-                                           (make-App (make-LocalRef 0 #f) (list)))
-                              #f)))
+                (make-LetRec (list (make-Lam 'omega 0 (make-App (make-LocalRef 0 #f) 
+                                                                (list)) '(0) 'lamEntry1))
+                             (make-App (make-LocalRef 0 #f) (list)))))
 
 
 
@@ -339,13 +296,11 @@
                        [c (lambda () (a))])
                 (a)))
       (make-Top (make-Prefix '())
-                (make-LetVoid 3
-                              (make-LetRec (list (make-Lam 'a 0 #f (make-App (make-LocalRef 0 #f) '()) '(1) 'lamEntry1)
-                                                 (make-Lam 'b 0 #f (make-App (make-LocalRef 0 #f) '()) '(2) 'lamEntry2)
-                                                 (make-Lam 'c 0 #f (make-App (make-LocalRef 0 #f) '()) '(0) 'lamEntry3))
-                                           (make-App (make-LocalRef 0 #f) '()))
-                              #f)))
-      
+                (make-LetRec (list (make-Lam 'a 0 (make-App (make-LocalRef 0 #f) '()) '(1) 'lamEntry1)
+                                   (make-Lam 'b 0 (make-App (make-LocalRef 0 #f) '()) '(0) 'lamEntry2)
+                                   (make-Lam 'c 0 (make-App (make-LocalRef 0 #f) '()) '(2) 'lamEntry3))
+                             (make-App (make-LocalRef 2 #f) '()))))
+
 
 
 (test (parse '(letrec ([x (lambda (x) x)]
@@ -356,17 +311,17 @@
                 (make-LetVoid 2
                               (make-Seq 
                                (list 
-                                (make-InstallValue 1 0
-                                                   (make-Lam 'x 1 #f (make-LocalRef 0 #f) '() 'lamEntry1)
+                                (make-InstallValue 1
+                                                   (make-Lam 'x 1 (make-LocalRef 0 #f) '() 'lamEntry1)
                                                    #t)
-                                (make-InstallValue 1 1 
-                                                   (make-Lam 'y 1 #f (make-LocalRef 0 #f) '() 'lamEntry2)
+                                (make-InstallValue 0 
+                                                   (make-Lam 'y 1 (make-LocalRef 0 #f) '() 'lamEntry2)
                                                    #t)
                                 ;; stack layout: ??? x y
-                                (make-Seq (list (make-Seq (list (make-InstallValue 1 0 (make-LocalRef 0 #t) #t)
+                                (make-Seq (list (make-Seq (list (make-InstallValue 1 (make-LocalRef 1 #t) #t)
                                                                 (make-Constant (void))))
-                                                (make-App (make-LocalRef 1 #t)
-                                                          (list (make-LocalRef 2 #t)))))))
+                                                (make-App (make-LocalRef 2 #t)
+                                                          (list (make-LocalRef 1 #t)))))))
                               #t)))
 
 
@@ -401,15 +356,15 @@
                   (make-LetVoid 2
                                 (make-Seq 
                                  (list 
-                                  (make-InstallValue 1 0
-                                                     (make-Lam 'x 1 #f
+                                  (make-InstallValue 0
+                                                     (make-Lam 'x 1
                                                                (make-App (make-LocalRef 1 #t) 
                                                                          (list (make-LocalRef 2 #f)))
                                                                '(1)
                                                                'lamEntry1)
                                                      #t)
-                                  (make-InstallValue 1 1 
-                                                     (make-Lam 'y 1 #f
+                                  (make-InstallValue 1 
+                                                     (make-Lam 'y 1 
                                                                (make-App (make-LocalRef 2 #f)
                                                                          (list (make-LocalRef 1 #t)))
                                                                '(1)
@@ -423,13 +378,13 @@
 (test (parse '(let ([x 0])
                 (lambda ()
                   (set! x (add1 x)))))
-      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleLocator '#%kernel '#%kernel))))
+      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
                 (make-Let1 (make-Constant 0)
                            (make-BoxEnv 0
-                                        (make-Lam 'unknown 0 #f
+                                        (make-Lam #f 0 
                                                   (make-Seq (list (make-InstallValue 
-                                                                   1 1 
-                                                                   (make-App (make-ToplevelRef 1 0 #f #t)
+                                                                   1 
+                                                                   (make-App (make-ToplevelRef 1 0)
                                                                              (list (make-LocalRef 2 #t)))
                                                                    #t)
                                                                   (make-Constant (void))))
@@ -442,16 +397,16 @@
                     [y 1])
                 (lambda ()
                   (set! x (add1 x)))))
-      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleLocator '#%kernel '#%kernel))))
+      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
                 (make-LetVoid 2
                               (make-Seq (list
-                                         (make-InstallValue 1 0 (make-Constant 0) #t)
-                                         (make-InstallValue 1 1 (make-Constant 1) #t)
-                                         (make-Lam 'unknown 0 #f
+                                         (make-InstallValue 0 (make-Constant 0) #t)
+                                         (make-InstallValue 1 (make-Constant 1) #t)
+                                         (make-Lam #f 0 
                                                    (make-Seq
                                                     (list (make-InstallValue 
-                                                           1 1 
-                                                           (make-App (make-ToplevelRef 1 0 #f #t)
+                                                           1 
+                                                           (make-App (make-ToplevelRef 1 0)
                                                                      (list (make-LocalRef 2 #t)))
                                                            #t)
                                                           (make-Constant (void))))
@@ -470,107 +425,23 @@
                      (reset!)
                      (list a b)))
       (make-Top
-       (make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleLocator '#%kernel '#%kernel)) reset!))
+       (make-Prefix `(a b ,(make-ModuleVariable 'list '#%kernel) reset!))
        (make-Splice
         (list
-         (make-ToplevelSet 0 0 (make-Constant '(hello)))
-         (make-ToplevelSet 0 1 (make-Constant '(world)))
+         (make-ToplevelSet 0 0 'a (make-Constant '(hello)))
+         (make-ToplevelSet 0 1 'b (make-Constant '(world)))
          (make-ToplevelSet
           0
           3
+          'reset!
           (make-Lam
            'reset!
            0
-           #f
            (make-Seq
              (list
-              (make-Seq (list (make-ToplevelSet 0 0 (make-Constant '())) (make-Constant (void))))
-              (make-Seq (list (make-ToplevelSet 0 1 (make-Constant '())) (make-Constant (void))))))
+              (make-Seq (list (make-ToplevelSet 0 0 'a (make-Constant '())) (make-Constant (void))))
+              (make-Seq (list (make-ToplevelSet 0 1 'b (make-Constant '())) (make-Constant (void))))))
            '(0)
            'lamEntry1))
-         (make-App (make-ToplevelRef 0 3 #f #t) '())
-         (make-App (make-ToplevelRef 2 2 #f #t) (list (make-ToplevelRef 2 0 #f #t) (make-ToplevelRef 2 1 #f #t)))))))
-
-
-
-(test (parse '(with-continuation-mark x y z))
-      (make-Top (make-Prefix '(x y z))
-                (make-WithContMark (make-ToplevelRef 0 0 #f #t)
-                                   (make-ToplevelRef 0 1 #f #t)
-                                   (make-ToplevelRef 0 2 #f #t))))
-
-
-
-(test (parse '(call-with-values x y))
-      (make-Top (make-Prefix '(x y))
-                (make-ApplyValues (make-ToplevelRef 0 1 #f #t)
-                                  (make-App (make-ToplevelRef 0 0 #f #t) (list)))))
-
-(test (parse '(call-with-values (lambda () x) y))
-      (make-Top (make-Prefix '(x y))
-                (make-ApplyValues (make-ToplevelRef 0 1 #f #t)
-                                  (make-ToplevelRef 0 0 #f #t))))
-
-
-
-(test (parse '(define-values () (values)))
-      (make-Top (make-Prefix '(values))
-                (make-DefValues '()
-                                (make-App (make-ToplevelRef 0 0 #f #t) '()))))
-
-(test (parse '(define-values (x y z) (values 'hello 'world 'testing)))
-      (make-Top (make-Prefix '(values x y z))
-                (make-DefValues (list (make-ToplevelRef 0 1 #f #t)
-                                      (make-ToplevelRef 0 2 #f #t)
-                                      (make-ToplevelRef 0 3 #f #t))
-                                (make-App (make-ToplevelRef 3 0 #f #t) 
-                                          (list (make-Constant 'hello)
-                                                (make-Constant 'world)
-                                                (make-Constant 'testing))))))
-
-
-
-
-
-;; CaseLam
-(test (parse '(case-lambda))
-      (make-Top (make-Prefix '())
-                (make-CaseLam 'unknown (list) 'lamEntry1)))
-
-
-(test (parse '(case-lambda [(x) x]))
-      (make-Top (make-Prefix '())
-                (make-CaseLam 
-                 'unknown
-                 (list (make-Lam 'unknown 1 #f (make-LocalRef 0 #f) '() 'lamEntry2))
-                 'lamEntry1)))
-
-
-(test (parse '(case-lambda [(x) x]
-                           [(x y) x]))
-      (make-Top (make-Prefix '())
-                (make-CaseLam 
-                 'unknown
-                 (list (make-Lam 'unknown 1 #f (make-LocalRef 0 #f) '() 'lamEntry2)
-                       (make-Lam 'unknown 2 #f (make-LocalRef 0 #f) '() 'lamEntry3))
-                 'lamEntry1)))
-
-(test (parse '(case-lambda [(x) x]
-                           [(x y) y]))
-      (make-Top (make-Prefix '())
-                (make-CaseLam 
-                 'unknown
-                 (list (make-Lam 'unknown 1 #f (make-LocalRef 0 #f) '() 'lamEntry2)
-                       (make-Lam 'unknown 2 #f (make-LocalRef 1 #f) '() 'lamEntry3))
-                 'lamEntry1)))
-
-
-(test (parse '(case-lambda [(x y) y]
-                           [(x) x]))
-      (make-Top (make-Prefix '())
-                (make-CaseLam 
-                 'unknown
-                 (list (make-Lam 'unknown 2 #f (make-LocalRef 1 #f) '() 'lamEntry2)
-                       (make-Lam 'unknown 1 #f (make-LocalRef 0 #f) '() 'lamEntry3))
-                       
-                 'lamEntry1)))
+         (make-App (make-ToplevelRef 0 3) '())
+         (make-App (make-ToplevelRef 2 2) (list (make-ToplevelRef 2 0) (make-ToplevelRef 2 1)))))))

test-simulator.rkt

@@ -1,13 +1,10 @@
 #lang racket
 
-(require "../compiler/il-structs.rkt"
-         "../compiler/lexical-structs.rkt"
-         "../compiler/arity-structs.rkt"
-         "../simulator/simulator-structs.rkt"
-         "../simulator/simulator-primitives.rkt"
-         "../simulator/simulator.rkt")
-
-(printf "test-simulator.rkt\n")
+(require "il-structs.rkt"
+         "lexical-structs.rkt"
+         "simulator-structs.rkt"
+         "simulator-primitives.rkt"
+         "simulator.rkt")
 
 
 (define-syntax (test stx)
@@ -36,11 +33,11 @@
 
 ;; run: machine -> machine
 ;; Run the machine to completion.
-(define (run! m)
+(define (run m)
   (cond
     [(can-step? m)
      (step! m)
-     (run! m)]
+     (run m)]
     [else
      m]))
 
@@ -75,13 +72,13 @@
 (let* ([m (new-machine `(,(make-PushEnvironment 1 #f)
                          ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42)))
                        #f)]
-       [m (run! m)])
+       [m (run m)])
   (test (machine-env m) '(42)))
 
 ;; Assigning to a boxed environment reference
 (let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
                          ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #t) (make-Const 42))))]
-       [m (run! m)])
+       [m (run m)])
   (test (machine-env m) (list (box 42))))
 
 
@@ -92,13 +89,13 @@
                          ,(make-PushEnvironment 1 #f)
                          ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                          (make-EnvLexicalReference 1 #t))))]
-       [m (run! m)])
+       [m (run m)])
   (test (machine-env m) (list 42 (box 42))))
 
 (let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
                          ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #t) (make-Const 42))
                          ,(make-PushEnvironment 1 #f)))]
-       [m (run! m)])
+       [m (run m)])
   (test (machine-env m) (list (make-undefined)
                               (box 42))))
 (let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
@@ -106,7 +103,7 @@
                          ,(make-PushEnvironment 1 #f)
                          ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                          (make-EnvLexicalReference 1 #f))))]
-       [m (run! m)])
+       [m (run m)])
   (test (machine-env m) (list (box 42)
                               (box 42))))
 
@@ -116,92 +113,92 @@
 ;; Assigning to another environment reference
 (let* ([m (new-machine `(,(make-PushEnvironment 2 #f)
                          ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42))))]
-       [m (run! m)])
+       [m (run m)])
   (test (machine-env m) `(,(make-undefined) 42)))
 
 
 ;; Assigning to another environment reference
 (let* ([m (new-machine `(,(make-PushEnvironment 2 #f)
                          ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42))))]
-       [m (run! m)])
+       [m (run m)])
   (test (machine-env m) `(42 ,(make-undefined))))
 
 
 ;; PushEnv
 (let ([m (new-machine `(,(make-PushEnvironment 20 #f)))])
-  (test (machine-env (run! m)) (build-list 20 (lambda (i) (make-undefined)))))
+  (test (machine-env (run m)) (build-list 20 (lambda (i) (make-undefined)))))
 
 
 ;; PopEnv
 (let ([m (new-machine `(,(make-PushEnvironment 20 #f)
-                        ,(make-PopEnvironment (make-Const 20) (make-Const 0))))])
-  (test (machine-env (run! m)) '()))
+                        ,(make-PopEnvironment 20 0)))])
+  (test (machine-env (run m)) '()))
 
 (let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
-                        ,(make-PopEnvironment (make-Const 1) (make-Const 0))))])
-  (test (machine-env (run! m)) '("dewey" "louie")))
+                        ,(make-PopEnvironment 1 0)))])
+  (test (machine-env (run m)) '("dewey" "louie")))
 
 (let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
-                        ,(make-PopEnvironment (make-Const 1) (make-Const 1))))])
-  (test (machine-env (run! m)) '("hewie" "louie")))
+                        ,(make-PopEnvironment 1 1)))])
+  (test (machine-env (run m)) '("hewie" "louie")))
 
 (let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
-                        ,(make-PopEnvironment (make-Const 1) (make-Const 2))))])
-  (test (machine-env (run! m)) '("hewie" "dewey")))
+                        ,(make-PopEnvironment 1 2)))])
+  (test (machine-env (run m)) '("hewie" "dewey")))
 
 (let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
-                        ,(make-PopEnvironment (make-Const 2) (make-Const 1))))])
-  (test (machine-env (run! m)) '("hewie")))
+                        ,(make-PopEnvironment 2 1)))])
+  (test (machine-env (run m)) '("hewie")))
 
 
 
 ;; PushControl
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                         foo 
-                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
+                        ,(make-PushControlFrame 'foo)
                         bar
-                        ,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
+                        ,(make-PushControlFrame 'bar)
                         baz
                         ))])
-  (test (machine-control (run! m))
-        (list (make-CallFrame (make-LinkedLabel 'bar 'bar) #f (make-hasheq) (make-hasheq))
-              (make-CallFrame (make-LinkedLabel 'foo 'foo) #f (make-hasheq) (make-hasheq)))))
+  (test (machine-control (run m))
+        (list (make-CallFrame 'bar #f)
+              (make-CallFrame 'foo #f))))
 
 
 
 ;; PopControl
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                         foo 
-                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
+                        ,(make-PushControlFrame 'foo)
                         bar
-                        ,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
+                        ,(make-PushControlFrame 'bar)
                         baz
                         ,(make-PopControlFrame)
                         ))])
-  (test (machine-control (run! m))
-        (list (make-CallFrame (make-LinkedLabel 'foo 'foo) #f (make-hasheq) (make-hasheq)))))
+  (test (machine-control (run m))
+        (list (make-CallFrame 'foo #f))))
 
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                         foo 
-                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
+                        ,(make-PushControlFrame 'foo)
                         bar
-                        ,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
+                        ,(make-PushControlFrame 'bar)
                         baz
                         ,(make-PopControlFrame)
                         ,(make-PopControlFrame)))])
-  (test (machine-control (run! m))
+  (test (machine-control (run m))
         (list)))
 
 
@@ -210,66 +207,64 @@
 
 ;; TestAndBranch: try the true branch
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))
-                        ,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'on-false)
+                        ,(make-TestAndBranchStatement 'false? 'val 'on-false)
                         ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                         ,(make-GotoStatement (make-Label 'end))
                         on-false
                         ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
                         end))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         'ok))
 ;; TestAndBranch: try the false branch
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const #f))
-                        ,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'on-false)
+                        ,(make-TestAndBranchStatement 'false? 'val 'on-false)
                         ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
                         ,(make-GotoStatement (make-Label 'end))
                         on-false
                         ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                         end))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         'ok))
 ;; Test for primitive procedure
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const '+))
-                        ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'on-true)
+                        ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'on-true)
                         ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                         ,(make-GotoStatement (make-Label 'end))
                         on-true
                         ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
                         end))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         'ok))
-
-
-;; ;; Give a primitive procedure in val
-;; (let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const (lookup-primitive '+)))
-;;                         ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'on-true)
-;;                         ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
-;;                         ,(make-GotoStatement (make-Label 'end))
-;;                         on-true
-;;                         ,(make-AssignImmediateStatement 'val (make-Const 'ok))
-;;                         end))])
-;;   (test (machine-val (run! m))
-;;         'ok))
-;; ;; Give a primitive procedure in proc, but test val
-;; (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
-;;                         ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'on-true)
-;;                         ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
-;;                         ,(make-GotoStatement (make-Label 'end))
-;;                         on-true
-;;                         ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
-;;                         end))])
-;;   (test (machine-val (run! m))
-;;         'not-a-procedure))
-;; ;; Give a primitive procedure in proc and test proc
-;; (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
-;;                         ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'on-true)
-;;                         ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
-;;                         ,(make-GotoStatement (make-Label 'end))
-;;                         on-true
-;;                         ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
-;;                         end))])
-;;   (test (machine-val (run! m))
-;;         'a-procedure))
+;; Give a primitive procedure in val
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const (lookup-primitive '+)))
+                        ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'on-true)
+                        ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
+                        ,(make-GotoStatement (make-Label 'end))
+                        on-true
+                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
+                        end))])
+  (test (machine-val (run m))
+        'ok))
+;; Give a primitive procedure in proc, but test val
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
+                        ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'on-true)
+                        ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
+                        ,(make-GotoStatement (make-Label 'end))
+                        on-true
+                        ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
+                        end))])
+  (test (machine-val (run m))
+        'not-a-procedure))
+;; Give a primitive procedure in proc and test proc
+(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
+                        ,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'on-true)
+                        ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
+                        ,(make-GotoStatement (make-Label 'end))
+                        on-true
+                        ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
+                        end))])
+  (test (machine-val (run m))
+        'a-procedure))
 
 
 
@@ -277,7 +272,7 @@
 
 ;; AssignPrimOpStatement
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))])
-  (test (first (machine-env (run! m)))
+  (test (first (machine-env (run m)))
         (make-toplevel '(+ - * =)
                        (list (lookup-primitive '+)
                              (lookup-primitive '-)
@@ -287,20 +282,20 @@
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
                         ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                         ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))))])
-  (test (machine-env (run! m))
+  (test (machine-env (run m))
         (list (make-toplevel '(some-variable) (list "Danny")))))
 
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable another)))
                         ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                         ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val))))])
-  (test (machine-env (run! m))
+  (test (machine-env (run m))
         (list (make-toplevel '(some-variable another) (list (make-undefined) "Danny")))))
 
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
                         ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                         ,(make-PushEnvironment 5 #f)
                         ,(make-AssignImmediateStatement (make-EnvPrefixReference 5 0) (make-Reg 'val))))])
-  (test (machine-env (run! m))
+  (test (machine-env (run m))
         (list (make-undefined) (make-undefined) (make-undefined) (make-undefined) (make-undefined)
               (make-toplevel '(some-variable) (list "Danny")))))
 
@@ -314,7 +309,7 @@
   (with-handlers ((exn:fail? (lambda (exn)
                                (void))))
     
-    (run! m)
+    (run m)
     (raise "I expected an error")))
 
 ;; check-toplevel-bound shouldn't fail here.
@@ -322,27 +317,24 @@
                         ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                         ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
                         ,(make-PerformStatement (make-CheckToplevelBound! 0 0))))])
-  (void (run! m)))
+  (void (run m)))
 
 
 
 ;; install-closure-values
 (let ([m  
-       (make-machine (make-undefined) 
-                     (make-closure 'procedure-entry
-                                   0
-                                   (list 1 2 3)
-                                   'procedure-entry)
-                     (make-undefined)
+       (make-machine (make-undefined) (make-closure 'procedure-entry
+                                                    0
+                                                    (list 1 2 3)
+                                                    'procedure-entry)
                      (list true false) ;; existing environment holds true, false
                      '() 
                      0 
                      (list->vector `(,(make-PerformStatement (make-InstallClosureValues!))
                                      procedure-entry))
-                     (make-hash)
                      0
                      (make-hash))])
-  (test (machine-env (run! m))
+  (test (machine-env (run m))
         ;; Check that the environment has installed the expected closure values.
         (list 1 2 3 true false)))
 
@@ -351,15 +343,13 @@
 (let ([m 
        (make-machine (make-undefined) 
                      (make-closure 'procedure-entry 0 (list 1 2 3) 'procedure-entry)
-                     (make-undefined)
                      (list true false) ;; existing environment holds true, false
                      '() 
                      0 
                      (list->vector `(,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))))
-                     (make-hash)
                      0
                      (make-hash))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         'procedure-entry))
 
 
@@ -371,7 +361,7 @@
                         procedure-entry
                         end
                         ))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         (make-closure 'procedure-entry 0 (list) 'procedure-entry)))
 
 ;; make-compiled-procedure: Capturing a few variables.
@@ -389,7 +379,7 @@
                         procedure-entry
                         end
                         ))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         (make-closure 'procedure-entry 0 (list 'larry 'moe)
                       'procedure-entry)))
 
@@ -411,7 +401,7 @@
                         procedure-entry
                         end
                         ))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         (make-closure 'procedure-entry 0 (list (make-toplevel '(x y z) (list "x" "y" "z")))
                       'procedure-entry)))
 
@@ -434,12 +424,12 @@
                                                       0
                                                       (list 3 0 2)
                                                       'procedure-entry))
-                        ,(make-PopEnvironment (make-Const 3) (make-Const 0))
+                        ,(make-PopEnvironment 3 0)
                         ,(make-GotoStatement (make-Label 'end))
                         procedure-entry
                         end
                         ))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         (make-closure 'procedure-entry 
                       0
                       (list (make-toplevel '(x y z) (list "x" "y" "z"))
@@ -451,7 +441,7 @@
 ;; Test toplevel lookup
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
                         ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         (lookup-primitive '+)))
 
 ;; Test lexical lookup
@@ -462,7 +452,7 @@
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const 'moe))
                         
                         ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         'larry))
 ;; Another lexical lookup test
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
@@ -472,7 +462,7 @@
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const 'moe))
                         
                         ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 1 #f))))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         'curly))
 
 ;; ApplyPrimitiveProcedure
@@ -482,258 +472,19 @@
                         ,(make-PushEnvironment 2 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 126389))
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42))
-                        ,(make-AssignImmediateStatement 'argcount (make-Const 2))
-                        ,(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
+                        ,(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure 2))
                         after))])
-  (test (machine-val (run! m))
+  (test (machine-val (run m))
         (+ 126389 42))
   
-  (test (machine-env (run! m))
+  (test (machine-env (run m))
         (list 126389 42 (make-toplevel '(+) (list (lookup-primitive '+))))))
 
 
-;; ControlStackLabel
+;; GetControlStackLabel
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                         foo
-                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
-                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))))])
-  (test (machine-proc (run! m))
-        'foo))
-
-
-;; ControlStackLabel
-(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
-                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo-single 'foo-multiple))
-                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
-                        ,(make-GotoStatement (make-Reg 'proc))
-                        foo-single
-                        ,(make-AssignImmediateStatement 'val (make-Const "single"))
-                        ,(make-GotoStatement (make-Label 'end))
-                        foo-multiple
-                        ,(make-AssignImmediateStatement 'val (make-Const "multiple"))
-                        ,(make-GotoStatement (make-Label 'end))
-                        end))])
-  (test (machine-val (run! m))
-        "single"))
-(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
-                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo-single 'foo-multiple))
-                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
-                        ,(make-GotoStatement (make-Reg 'proc))
-                        foo-single
-                        ,(make-AssignImmediateStatement 'val (make-Const "single"))
-                        ,(make-GotoStatement (make-Label 'end))
-                        foo-multiple
-                        ,(make-AssignImmediateStatement 'val (make-Const "multiple"))
-                        ,(make-GotoStatement (make-Label 'end))
-                        end))])
-  (test (machine-val (run! m))
-        "multiple"))
-
-
-(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
-                        ,(make-PushControlFrame/Prompt default-continuation-prompt-tag
-                                                       (make-LinkedLabel 'foo-single 'foo-multiple))
-                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
-                        ,(make-GotoStatement (make-Reg 'proc))
-                        foo-single
-                        ,(make-AssignImmediateStatement 'val (make-Const "single"))
-                        ,(make-GotoStatement (make-Label 'end))
-                        foo-multiple
-                        ,(make-AssignImmediateStatement 'val (make-Const "multiple"))
-                        ,(make-GotoStatement (make-Label 'end))
-                        end))])
-  (test (machine-val (run! m))
-        "single"))
-(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
-                        ,(make-PushControlFrame/Prompt default-continuation-prompt-tag
-                                                       (make-LinkedLabel 'foo-single 'foo-multiple))
-                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
-                        ,(make-GotoStatement (make-Reg 'proc))
-                        foo-single
-                        ,(make-AssignImmediateStatement 'val (make-Const "single"))
-                        ,(make-GotoStatement (make-Label 'end))
-                        foo-multiple
-                        ,(make-AssignImmediateStatement 'val (make-Const "multiple"))
-                        ,(make-GotoStatement (make-Label 'end))
-                        end))])
-  (test (machine-val (run! m))
-        "multiple"))
-
-
-
-;; Splicing
-(let ([m (new-machine `(,(make-PushEnvironment 1 #f)
-                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
-                                                        (make-Const '(1 2 3)))
-                        ,(make-AssignImmediateStatement 'argcount (make-Const 1))
-                        ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0)))))])
-  (run! m)
-  (test (machine-argcount m)
-        3)
-  (test (machine-env m)
-        '(1 2 3)))
-                      
-
-
-(let ([m (new-machine `(,(make-PushEnvironment 3 #f)
-                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
-                                                        (make-Const "hello"))
-                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
-                                                        (make-Const "world"))
-                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
-                                                        (make-Const '(1 2 3)))
-                        ,(make-AssignImmediateStatement 'argcount (make-Const 3))
-                        ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 2)))))])
-  (run! m)
-  (test (machine-argcount m)
-        5)
-  (test (machine-env m)
-        '("hello" "world" 1 2 3)))
-
-
-
-
-;; Testing immediate pushing
-(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
-                                                            #f)))])
-  (run! m)
-  (test (machine-env m)
-        '("this is a message")))
-
-(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
-                                                            #t)))])
-  (run! m)
-  (test (machine-env m)
-        `(,(box "this is a message"))))
-
-
-(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
-                                                            #f)
-                        ,(make-PushImmediateOntoEnvironment (make-Const "again")
-                                                            #f)
-                        ))])
-  (run! m)
-  (test (machine-env m)
-        '("again" "this is a message")))
-
-(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
-                                                            #f)
-                        ,(make-PushImmediateOntoEnvironment (make-Const "again")
-                                                            #t)
-                        ))])
-  (run! m)
-  (test (machine-env m)
-        `(,(box "again") "this is a message")))
-                           
-
-
-
-
-
-;; testing rest splicing
-(let ([m (new-machine `(,(make-PushEnvironment 1 #f)
-                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
-                                                        (make-Const "hello"))
-                        ,(make-AssignImmediateStatement 'argcount (make-Const 1))
-                        ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0)
-                                                                             (make-Const 1)))))])
-  (run! m)
-  (test (machine-argcount m)
-        1)
-  (test (machine-env m)
-        (list (make-MutablePair "hello" null))))
-
-
-(let ([m (new-machine 
-          `(,(make-PushEnvironment 5 #f)
-            ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
-                                            (make-Const "hello"))
-            ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
-                                            (make-Const "world"))
-            ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
-                                            (make-Const 'x))
-            ,(make-AssignImmediateStatement (make-EnvLexicalReference 3 #f)
-                                                        (make-Const 'y))
-            ,(make-AssignImmediateStatement (make-EnvLexicalReference 4 #f)
-                                            (make-Const 'z))
-            ,(make-AssignImmediateStatement 'argcount (make-Const 5))
-            ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2)  (make-Const 3)))))])
-  (run! m)
-  (test (machine-argcount m)
-        3)
-  (test (machine-env m)
-        (list "hello"
-              "world"
-              (make-MutablePair 'x (make-MutablePair 'y (make-MutablePair 'z null))))))
-
-
-
-
-
-
-
-;; Check closure mismatch.  Make sure we're getting the right values from the test.
-(let ([m (new-machine `(procedure-entry
-                        ;; doesn't matter about the procedure entry...
-                        ,(make-AssignPrimOpStatement 
-                          'proc
-                          (make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
-                        ,(make-TestAndJumpStatement
-                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
-                          'bad)
-                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
-                        ,(make-GotoStatement (make-Label 'end))
-                        bad
-                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
-                        end))])
-  (test (machine-val (run! m))
-        'ok))
-
-(let ([m (new-machine `(procedure-entry
-                        ;; doesn't matter about the procedure entry...
-                        ,(make-AssignPrimOpStatement 
-                          'proc
-                          (make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
-                        ,(make-TestAndJumpStatement
-                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 1))
-                          'ok)
-                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
-                        ,(make-GotoStatement (make-Label 'end))
-                        ok
-                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
-                        end))])
-  (test (machine-val (run! m))
-        'ok))
-
-(let ([m (new-machine `(procedure-entry
-                        ;; doesn't matter about the procedure entry...
-                        ,(make-AssignPrimOpStatement 
-                          'proc
-                          (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
-                        ,(make-TestAndJumpStatement
-                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
-                          'ok)
-                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
-                        ,(make-GotoStatement (make-Label 'end))
-                        ok
-                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
-                        end))])
-  (test (machine-val (run! m))
-        'ok))
-
-(let ([m (new-machine `(procedure-entry
-                        ;; doesn't matter about the procedure entry...
-                        ,(make-AssignPrimOpStatement 
-                          'proc
-                          (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
-                        ,(make-TestAndJumpStatement
-                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 2))
-                          'bad)
-                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
-                        ,(make-GotoStatement (make-Label 'end))
-                        bad
-                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
-                        end))])
-  (test (machine-val (run! m))
-        'ok))
-
+                        ,(make-PushControlFrame 'foo)
+                        ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))])
+  (test (machine-proc (run m))
+        'foo))

tests/conform/program0.sch

@@ -1,5 +1,4 @@
-#lang whalesong/base
-(let ()
+(begin
 
 ;; (define (caar l)
 ;;   (car (car l)))
@@ -129,8 +128,7 @@
 (define set-internal-node-name! (lambda (node name) (vector-set! node '0 name)))
 (define set-internal-node-green-edges! (lambda (node edges) (vector-set! node '1 edges)))
 (define set-internal-node-red-edges! (lambda (node edges) (vector-set! node '2 edges)))
-(define set-internal-node-blue-edges! (lambda (node edges)
-                                        (vector-set! node '3 edges)))
+(define set-internal-node-blue-edges! (lambda (node edges) (vector-set! node '3 edges)))
 (define make-node
   (lambda (name blue-edges)
     (let ((name (if (symbol? name) (symbol->string name) name))
@@ -515,4 +513,4 @@
       (newline))))
 
 
-(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) 1)))
+(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) 1)))

typed-parse.rkt

@@ -0,0 +1,6 @@
+#lang typed/racket/base
+(require "expression-structs.rkt")
+(require/typed "parse.rkt"
+               [parse (Any -> Expression)])
+
+(provide parse)

whalesong/Makefile

@@ -1,52 +0,0 @@
-all: build
-
-build: planet-link launcher setup
-
-bump-version:
-	racket bump-version.rkt
-
-launcher: 
-	racket make-launcher.rkt
-
-test: test-more
-
-test-all: test 
-
-
-## TODO: fix the tests harness in tests/test-all.  I have to remove references
-## to deleted files.
-# test-analyzer:
-# 	raco make -v --disable-inline test-analyzer.rkt
-# 	racket test-analyzer.rkt
-# test-all: 
-# 	racket tests/test-all.rkt
-# test-browser-evaluate: 
-# 	racket tests/test-browser-evaluate.rkt
-# test-compiler: 
-# 	racket tests/test-compiler.rkt
-# test-parse-bytecode-on-collects: 
-# 	racket tests/test-parse-bytecode-on-collects.rkt
-# test-earley: 
-# 	racket tests/test-earley.rkt
-# test-conform: 
-# 	racket tests/test-conform.rkt
-
-test-more: bump-version build
-	racket tests/run-more-tests.rkt
-
-doc:
-	scribble  ++xref-in setup/xref load-collections-xref --redirect-main http://docs.racket-lang.org/ --dest generated-docs  --dest-name index.html scribblings/manual.scrbl
-
-
-cs019-doc:
-	scribble  ++xref-in setup/xref load-collections-xref --redirect-main http://docs.racket-lang.org/ --dest generated-docs  scribblings/cs019.scrbl
-
-
-
-setup:
-
-	raco setup --no-docs -P dyoo whalesong.plt 1 19
-
-
-planet-link:
-	raco planet link dyoo whalesong.plt 1 19 .

whalesong/README

@@ -1,199 +0,0 @@
-======================================================================
-Whalesong: a compiler from Racket to JavaScript.
-
-Danny Yoo (dyoo@hashcollision.org)
-
-
-======================================================================
-
-
-See:  http://hashcollision.org/whalesong/index.html for documentation.
-
-The rest of the content in this document will migrate there shortly.
-
-
-======================================================================
-
-
-
-
-
-Prerequisite: Racket 5.1.1.  The majority of the project is written
-Typed Racket, and I highly recommend you use a version of Racket
-that's at least 5.1.1; otherwise, compilation may take an unusual
-amount of time.
-
-
-======================================================================
-
-Example usage
-
-
-Create a simple, executable of your program.  At the moment, the program must
-be written in the base language of whalesong.  (This restriction currently
-prevents arbitrary racket/base programs from compiling, and we'll be working to
-remove this restriction.)
-
-    $ cat hello.rkt 
-    #lang whalesong
-    (display "hello world")
-    (newline)
-
-    $ ./whalesong.rkt build hello.rkt
-
-    $ ls -l hello.html
-    -rw-rw-r-- 1 dyoo nogroup 692213 Jun  7 18:00 hello.html
-
-To build standalone executable of your program, provide --as-standalone-html
-flag.
-
-    $ ./whalesong.rkt build --as-standalone-html hello.rkt
-
-    $ ls -l
-    -rw-rw-r-- 1 dyoo nogroup 692213 Jun  7 18:00 hello.html
-
-NOTE: Earlier versions had --as-standalone-xhtml flag, which is now removed.
-
-
-[FIXME: add more examples]
-
-
-======================================================================
-
-Architecture:
-
-The basic idea is to reuse most of the Racket compiler infrastructure.
-We use the underlying Racket compiler to produce bytecode from Racket
-source; it also performs macro expansion and module-level
-optimizations for us.  We parse that bytecode using the
-compiler/zo-parse collection to get an AST, compile that to an
-intermediate language, and finally assemble JavaScript.
-
-
-                        AST          IL                     JS
- parse-bytecode.rkt ----------> compiler.rkt --------> assembler.rkt ------->
-    (todo)
-
-
-The IL is intended to be translated straightforwardly.  We currently
-have an assembler to JavaScript, as well as a simulator
-(simulator.rkt).  The simulator allows us to test the compiler in a
-controlled environment.
-
-
-
-======================================================================
-
-parser/parse-bytecode.rkt
-
-This is intended to reuse the Racket compiler to produce the AST
-structures defined in compiler/zo-parse.
-
-
-======================================================================
-
-compiler/compiler.rkt
-
-translates the AST to the intermediate language.  The compiler has its
-origins in the register compiler in Structure and Interpretation of
-Computer Programs:
-
-    http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-35.html#%_sec_5.5
-
-with some significant modifications.  Since this is a stack machine,
-we don't need any of the register-saving infrastructure in the
-original compiler.  We also need to support slightly different linkage
-structures, since we want to support multiple value contexts.  We're
-trying to generate code that works effectively on a machine like the
-one described in:
-
-    http://plt.eecs.northwestern.edu/racket-machine/
-
-
-
-The intermediate language is defined in il-structs.rkt, and a
-simulator for the IL in simulator/simulator.rkt.  See
-test-simulator.rkt to see the simulator in action, and
-test-compiler.rkt to see how the output of the compiler can be fed
-into the simulator.
-
-
-
-The assumed machine is a stack machine with the following atomic
-registers:
-
-    val: value
-    proc: procedure
-    argcount: number of arguments
-
-and two stack registers:
-
-    env: environment stack
-    control: control stack
-
-
-
-======================================================================
-
-js-assembler/assemble.rkt
-
-The JavaScript assembler plays a few tricks to make things like tail
-calls work:
-
-   * Each basic block is translated to a function taking a MACHINE
-     argument.
-
-   * Every GOTO becomes a function call.
-
-   * The head of each basic-blocked function checks to see if we
-     should trampoline
-     (http://en.wikipedia.org/wiki/Trampoline_(computers))
-
-   * We support a limited form of computed jump by assigning an
-     attribute to the function corresponding to a return point.  See
-     the code related to the LinkedLabel structure for details.
-
-
-Otherwise, the assembler is fairly straightforward.  It depends on
-library functions defined in mini-runtime.js.  As soon as the compiler
-stabilizes, we will be pulling in the runtime library in Moby Scheme
-into this project.
-
-
-The assembled output distinguishes between Primitives and Closures.
-Primitives are only allowed to return single values back, and are not
-allowed to do any higher-order procedure calls.  Closures, on the
-other hand, have full access to the machine, but they are responsible
-for calling the continuation and popping off their arguments when
-they're finished.
-
-
-
-
-======================================================================
-
-Tests
-
-The test suite in test-all.rkt runs the test suite.  You'll need to
-run this on a system with a web browser, as the suite will evaluate
-JavaScript and make sure it is producing values.  A bridge module
-(planet dyoo/browser-evaluate) brings up a temporary web server that allows us
-to pass values between Racket and the JavaScript evaluator on the
-browser.
-
-
-
-======================================================================
-
-Acknowledgements and Thanks
-
-
-This uses code from the following projects:
-
-   jshashtable (http://www.timdown.co.uk/jshashtable/)
-   js-numbers (http://github.com/dyoo/js-numbers/)
-   JSON (http://www.json.org/js.html)
-   jquery (http://jquery.com/)
-
-
-   [FIXME: add more]

whalesong/base/lang/reader.rkt

@@ -1,9 +0,0 @@
-#lang s-exp syntax/module-reader
-
-;; http://docs.racket-lang.org/planet/hash-lang-planet.html
-
-#:language (lambda (ip)
-	    `(file ,(path->string base-lang-path)))
-
-(require racket/runtime-path)
-(define-runtime-path base-lang-path "../../lang/base.rkt")

whalesong/bf/lang/reader.rkt

@@ -1,30 +0,0 @@
-#lang s-exp syntax/module-reader
-#:language (lambda () 'whalesong/bf/language)
-#:read my-read
-#:read-syntax my-read-syntax
-#:info my-get-info
-(require "../parser.rkt")
-
-(define (my-read in)
-  (syntax->datum (my-read-syntax #f in)))
-
-(define (my-read-syntax src in)
-  (parse-expr src in))
-
-
-
-;; Extension: we'd like to cooperate with DrRacket and tell
-;; it to use the default, textual lexer and color scheme when
-;; editing bf programs.
-;;
-;; See: http://docs.racket-lang.org/guide/language-get-info.html
-;; for more details, as well as the documentation in
-;; syntax/module-reader.
-(define (my-get-info key default default-filter)
-  (case key
-    [(color-lexer)
-     (dynamic-require 'syntax-color/default-lexer
-                      'default-lexer)]
-    [else
-     (default-filter key default)]))
-

whalesong/bf/language.rkt

@@ -1,103 +0,0 @@
-#lang whalesong
-
-(require "semantics.rkt"
-         (for-syntax racket/base))
-
-(provide greater-than
-         less-than
-         plus
-         minus
-         period
-         comma
-         brackets
-         (rename-out [my-module-begin #%module-begin]))
-
-
-
-
-;; Every module in this language will make sure that it
-;; uses a fresh state.  We create one, and then within
-;; the lexical context of a my-module-begin, all the
-;; other forms will refer to current-state.
-(define-syntax (my-module-begin stx)
-  (syntax-case stx ()
-    [(_ body ...)
-     (with-syntax ([current-data (datum->syntax stx 'current-data)]
-                   [current-ptr (datum->syntax stx 'current-ptr)])
-       (syntax/loc stx
-         (#%plain-module-begin
-          (define-values (current-data current-ptr) (new-state))
-          (define (run)
-            (begin body ... (void)))
-          (run))))]))
-
-
-;; In order to produce good runtime error messages
-;; for greater-than and less-than, we latch onto 
-;; the syntax object for dear life, since it has
-;; information about where it came from in the
-;; source syntax.
-;;
-;; The #'#,stx nonsense below allows us to pass the
-;; syntax object.  The semantics can then raise an
-;; appropriate syntactic error with raise-syntax-error
-;; if it sees anything bad happen at runtime.
-(define-syntax (greater-than stx)
-  (with-syntax ([current-data (datum->syntax stx 'current-data)]
-                [current-ptr (datum->syntax stx 'current-ptr)])
-    (syntax-case stx ()
-      [(_)
-       (quasisyntax/loc stx
-         (increment-ptr current-data current-ptr
-                        (srcloc '#,(syntax-source stx)
-                                '#,(syntax-line stx)
-                                '#,(syntax-column stx)
-                                '#,(syntax-position stx)
-                                '#,(syntax-span stx))))])))
-
-
-(define-syntax (less-than stx)
-  (syntax-case stx ()
-    [(_)
-     (with-syntax ([current-data (datum->syntax stx 'current-data)]
-                   [current-ptr (datum->syntax stx 'current-ptr)])
-       (quasisyntax/loc stx
-         (decrement-ptr current-data current-ptr
-                        (srcloc '#,(syntax-source stx)
-                                '#,(syntax-line stx)
-                                '#,(syntax-column stx)
-                                '#,(syntax-position stx)
-                                '#,(syntax-span stx)))))]))
-
-
-(define-syntax (plus stx)
-  (with-syntax ([current-data (datum->syntax stx 'current-data)]
-                [current-ptr (datum->syntax stx 'current-ptr)])
-    (syntax/loc stx
-      (increment-byte current-data current-ptr))))
-
-(define-syntax (minus stx)
-  (with-syntax ([current-data (datum->syntax stx 'current-data)]
-                [current-ptr (datum->syntax stx 'current-ptr)])
-    (syntax/loc stx
-      (decrement-byte current-data current-ptr))))
-
-(define-syntax (period stx)
-  (with-syntax ([current-data (datum->syntax stx 'current-data)]
-                [current-ptr (datum->syntax stx 'current-ptr)])
-    (syntax/loc stx 
-      (write-byte-to-stdout current-data current-ptr))))
-
-(define-syntax (comma stx)
-  (with-syntax ([current-data (datum->syntax stx 'current-data)]
-                [current-ptr (datum->syntax stx 'current-ptr)])
-    (syntax/loc stx
-      (read-byte-from-stdin current-data current-ptr))))
-
-(define-syntax (brackets stx)
-  (syntax-case stx ()
-    [(_ body ...)
-     (with-syntax ([current-data (datum->syntax stx 'current-data)]
-                   [current-ptr (datum->syntax stx 'current-ptr)])
-       (syntax/loc stx
-         (loop current-data current-ptr body ...)))]))

whalesong/bf/parser.rkt

@@ -1,114 +0,0 @@
-#lang racket
-(require rackunit)
-
-(provide parse-expr)
-
-;; While loops...
-(define-syntax-rule (while test body ...)
-  (let loop ()
-    (when test
-      body ...
-      (loop))))
-
-
-;; ignorable-next-char?: input-port -> boolean
-;; Produces true if the next character is something we should ignore.
-(define (ignorable-next-char? in)
-  (let ([next-ch (peek-char in)])
-    (cond
-      [(eof-object? next-ch)
-       #f]
-      [else
-       (not (member next-ch '(#\< #\> #\+ #\- #\, #\. #\[ #\])))])))
-
-
-;; parse-expr: any input-port -> (U syntax eof)
-;; Either produces a syntax object or the eof object.
-(define (parse-expr source-name in)
-  (while (ignorable-next-char? in) (read-char in))
-  (let*-values ([(line column position) (port-next-location in)]
-                [(next-char) (read-char in)])
-    
-    ;; We'll use this function to generate the syntax objects by
-    ;; default.
-    ;; The only category this doesn't cover are brackets.
-    (define (default-make-syntax type)
-      (datum->syntax #f 
-                     (list type)
-                     (list source-name line column position 1)))
-    (cond
-      [(eof-object? next-char) eof]
-      [else
-       (case next-char
-         [(#\<) (default-make-syntax 'less-than)]
-         [(#\>) (default-make-syntax 'greater-than)]
-         [(#\+) (default-make-syntax 'plus)]
-         [(#\-) (default-make-syntax 'minus)]
-         [(#\,) (default-make-syntax 'comma)]
-         [(#\.) (default-make-syntax 'period)]
-         [(#\[)
-          ;; The slightly messy case is bracket.  We keep reading
-          ;; a list of exprs, and then construct a wrapping bracket
-          ;; around the whole thing.
-          (let*-values ([(elements) (parse-exprs source-name in)]
-                        [(following-line following-column 
-                                         following-position) 
-                         (port-next-location in)])
-            (datum->syntax #f 
-                           `(brackets ,@elements)
-                           (list source-name
-                                 line 
-                                 column 
-                                 position 
-                                 (- following-position
-                                    position))))]
-         [(#\])
-          eof])])))
-
-
-;; parse-exprs: input-port -> (listof syntax)
-;; Parse a list of expressions.
-(define (parse-exprs source-name in)
-  (let ([next-expr (parse-expr source-name in)])
-    (cond
-      [(eof-object? next-expr)
-       empty]
-      [else
-       (cons next-expr (parse-exprs source-name in))])))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Tests
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; simple tests
-(check-equal? eof (parse-expr 'test (open-input-string "")))
-(check-equal? '(greater-than) 
-              (syntax->datum (parse-expr 'test (open-input-string ">"))))
-(check-equal? '(less-than) 
-              (syntax->datum (parse-expr 'test (open-input-string "<"))))
-(check-equal? '(plus) 
-              (syntax->datum (parse-expr 'test (open-input-string "+"))))
-(check-equal? '(minus)
-              (syntax->datum (parse-expr 'test (open-input-string "-"))))
-(check-equal? '(comma)
-              (syntax->datum (parse-expr 'test (open-input-string ","))))
-(check-equal? '(period)
-              (syntax->datum (parse-expr 'test (open-input-string "."))))
-
-
-;; bracket tests
-(check-equal? '(brackets) 
-              (syntax->datum (parse-expr 'test (open-input-string "[]"))))
-(check-equal? '(brackets (brackets))
-              (syntax->datum (parse-expr 'test (open-input-string "[[]]"))))
-
-
-;; Parsing the "cat" function
-(let ([port (open-input-string ",[.,]")])
-  (check-equal? '(comma) 
-                (syntax->datum (parse-expr 'test port)))
-  (check-equal? '(brackets (period) (comma))
-                (syntax->datum (parse-expr 'test port)))
-  (check-equal? eof
-                (parse-expr 'test port)))

whalesong/bf/semantics.rkt

@@ -1,81 +0,0 @@
-#lang whalesong
-
-;; This is a second semantics for the language that tries to go for speed,
-;; at the expense of making things a little more complicated.
-;;
-;; It uses features in: http://docs.racket-lang.org/reference/unsafe.html
-;; to reduce the number of runtime checks.
-;;
-;; We also manage the state as two separate values.
-;;
-;; Tape out-of-bounds errors at runtime should be properly reported with
-;; source location.
-
-(require (for-syntax racket/base)) 
-
-
-(provide (all-defined-out))
-
-
-
-(define-syntax MAX-DATA-SIZE
-  (lambda (stx) #'30000))
-
-
-
-;; Creates a new state, with a byte array of 30000 zeros, and
-;; the pointer at index 0.
-(define-syntax-rule (new-state) 
-  (values (make-vector MAX-DATA-SIZE 0)
-          0))
-
-
-;; increment the data pointer
-(define-syntax-rule (increment-ptr data ptr loc)
-  (begin
-    (set! ptr (+ ptr 1))))
-
-
-;; decrement the data pointer
-(define-syntax-rule (decrement-ptr data ptr loc)
-  (set! ptr (- ptr 1)))
-
-
-;; increment the byte at the data pointer
-(define-syntax-rule (increment-byte data ptr)
-  (vector-set! data ptr
-                     (modulo
-                      (+ (vector-ref data ptr)
-                                  1)
-                      256)))
-
-;; decrement the byte at the data pointer
-(define-syntax-rule (decrement-byte data ptr)
-  (vector-set! data ptr
-                     (modulo
-                      (- (vector-ref data ptr)
-                                  1)
-                      256)))
-
-;; print the byte at the data pointer
-(define-syntax-rule (write-byte-to-stdout data ptr)
-  (write-byte (vector-ref data ptr)))
-
-
-;; ;; read a byte from stdin into the data pointer
-;; (define-syntax-rule (read-byte-from-stdin data ptr)
-;;   (vector-set! data ptr (let ([v (read-byte (current-input-port))])
-;;                                  (if (eof-object? v)
-;;                                      0
-;;                                      v))))
-
-;; Loops
-(define-syntax-rule (loop data ptr body ...)
-  (unless (= (vector-ref data ptr)
-                      0)
-    (let loop ()
-      body ...
-      (unless (= (vector-ref data ptr)
-                          0)
-        (loop)))))
-

whalesong/bump-version.rkt

@@ -1,20 +0,0 @@
-#lang racket/base
-
-(require racket/runtime-path
-	 racket/port
-	 racket/list)
-
-(define-runtime-path version.rkt "version.rkt")
-
-(define version-text (call-with-input-file version.rkt port->string))
-
-(define revised-text (regexp-replace #px"\\.(\\d+)"
-				     version-text
-				     (lambda (whole sub)
-				       (string-append 
-					"."
-					(number->string 
-					 (add1 (string->number sub)))))))
-  
-(call-with-output-file version.rkt (lambda (op) (display revised-text op))
-		       #:exists 'replace)

whalesong/call-with-timeout.rkt

@@ -1,44 +0,0 @@
-#lang racket/base
-
-(provide (struct-out exn:fail:timeout)
-         call-with-timeout)
-
-
-(define-struct (exn:fail:timeout exn:fail) (msecs))
-
-
-(define-struct good-value (v))
-(define-struct bad-value (exn))
-
-;; call-with-timeout: (-> any) number -> any
-;; Calls a thunk, with a given timeout.
-(define (call-with-timeout thunk timeout)
-  (let ([ch (make-channel)]
-        [alarm-e
-         (alarm-evt (+ (current-inexact-milliseconds)
-                       timeout))])
-    (let* ([cust (make-custodian)]
-           [th (parameterize ([current-custodian cust])
-                 (thread (lambda ()
-                        (channel-put ch
-                                     (with-handlers ([void
-                                                      (lambda (e)
-                                                        (make-bad-value e))])
-                                       (make-good-value (thunk)))))))])
-      (let ([result (sync ch
-                          (handle-evt alarm-e
-                                      (lambda (false-value)
-                                        (begin0
-                                            (make-bad-value
-                                             (make-exn:fail:timeout
-                                              "timeout"
-                                              (current-continuation-marks)
-                                              timeout))
-                                          (custodian-shutdown-all cust)
-                                          (kill-thread th)))))])
-        (cond
-         [(good-value? result)
-          (good-value-v result)]
-         [(bad-value? result)
-          (raise (bad-value-exn result))])))))
-        

whalesong/compiler/analyzer-structs.rkt

@@ -1,45 +0,0 @@
-#lang typed/racket/base
-
-
-(require "arity-structs.rkt"
-         "expression-structs.rkt"
-         "lexical-structs.rkt"
-         "kernel-primitives.rkt"
-	 "il-structs.rkt")
-
-
-(provide (all-defined-out))
-
-
-;; Static knowledge about an expression.
-;;
-;; We try to keep at compile time a mapping from environment positions to
-;; statically known things, to generate better code.
-
-
-(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
-
-(define-type CompileTimeEnvironmentEntry 
-  (U '?          ;; no knowledge
-     Prefix      ;; placeholder: necessary since the toplevel lives in the environment too
-     StaticallyKnownLam     ;; The value is a known lam
-     ModuleVariable         ;; The value is a variable from a module
-     PrimitiveKernelValue
-     Const
-     ))
-
-
-(define-struct: StaticallyKnownLam ([name : (U Symbol LamPositionalName)]
-                                    [entry-point : Symbol]
-                                    [arity : Arity]) #:transparent)
-
-
-
-
-
-(define-struct: Analysis ([ht : (HashTable Expression CompileTimeEnvironmentEntry)]))
-
-
-(: empty-analysis (-> Analysis))
-(define (empty-analysis)
-  (make-Analysis (make-hash)))

whalesong/compiler/analyzer.rkt

@@ -1,346 +0,0 @@
-#lang typed/racket/base
-
-(require "expression-structs.rkt"
-         "analyzer-structs.rkt"
-         "arity-structs.rkt"
-         "lexical-structs.rkt"
-         "il-structs.rkt"
-         "compiler-structs.rkt"
-         racket/list)
-
-(require/typed "compiler-helper.rkt"
-               [ensure-const-value (Any -> const-value)])
-
-
-(provide collect-all-lambdas-with-bodies
-         collect-lam-applications
-         extract-static-knowledge
-         ensure-prefix)
-
-;; Holds helper functions we use for different analyses.
-
-;; Given a lambda body, collect all the applications that exist within
-;; it.  We'll use this to determine what procedures can safely be
-;; transformed into primitives.
-(: collect-lam-applications (Lam CompileTimeEnvironment -> (Listof CompileTimeEnvironmentEntry)))
-(define (collect-lam-applications lam cenv)
-  
-  (let: loop : (Listof CompileTimeEnvironmentEntry)
-    ([exp : Expression (Lam-body lam)]
-     [cenv : CompileTimeEnvironment cenv]
-     [acc : (Listof CompileTimeEnvironmentEntry) '()])
-    
-    (cond
-      [(Top? exp)
-       (loop (Top-code exp)
-             (cons (Top-prefix exp) cenv)
-             acc)]
-      
-      [(Module? exp)
-       (loop (Module-code exp)
-             (cons (Module-prefix exp) cenv)
-             acc)]
-      
-      [(Constant? exp)
-       acc]
-      
-      [(LocalRef? exp)
-       acc]
-      
-      [(ToplevelRef? exp)
-       acc]
-      
-      [(ToplevelSet? exp)
-       (loop (ToplevelSet-value exp) cenv acc)]
-      
-      [(Branch? exp)
-       (define acc-1 (loop (Branch-predicate exp) cenv acc))
-       (define acc-2 (loop (Branch-consequent exp) cenv acc-1))
-       (define acc-3 (loop (Branch-alternative exp) cenv acc-2))
-       acc-3]
-      
-      [(Lam? exp)
-       acc]
-      
-      [(CaseLam? exp)
-       acc]
-      
-      [(EmptyClosureReference? exp)
-       acc]
-      
-      [(Seq? exp)
-       (foldl (lambda: ([e : Expression]
-                        [acc : (Listof CompileTimeEnvironmentEntry)])
-                (loop e cenv acc))
-              acc
-              (Seq-actions exp))]
-      
-      [(Splice? exp)
-       (foldl (lambda: ([e : Expression]
-                        [acc : (Listof CompileTimeEnvironmentEntry)])
-                (loop e cenv acc))
-              acc
-              (Splice-actions exp))]
-      
-      [(Begin0? exp)
-       (foldl (lambda: ([e : Expression]
-                        [acc : (Listof CompileTimeEnvironmentEntry)])
-                (loop e cenv acc))
-              acc
-              (Begin0-actions exp))]
-      
-      [(App? exp)
-       (define new-cenv
-         (append (build-list (length (App-operands exp)) (lambda: ([i : Natural]) '?))
-                 cenv))
-       (foldl (lambda: ([e : Expression]
-                        [acc : (Listof CompileTimeEnvironmentEntry)])
-                (loop e new-cenv acc))
-              (cons (extract-static-knowledge (App-operator exp) new-cenv)
-                    (loop (App-operator exp) new-cenv acc))
-              (App-operands exp))]
-      
-      [(Let1? exp)
-       (define acc-1 (loop (Let1-rhs exp) (cons '? cenv) acc))
-       (define acc-2 (loop (Let1-body exp) 
-                           (cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv)) 
-                                 cenv)
-                           acc-1))
-       acc-2]
-      
-      [(LetVoid? exp)
-       (loop (LetVoid-body exp) 
-             (append (build-list (LetVoid-count exp) (lambda: ([i : Natural]) '?))
-                     cenv)
-             acc)]
-      
-      [(InstallValue? exp)
-       (loop (InstallValue-body exp) cenv acc)]
-      
-      [(BoxEnv? exp)
-       (loop (BoxEnv-body exp) cenv acc)]
-      
-      [(LetRec? exp)
-       (let ([n (length (LetRec-procs exp))])
-         (let ([new-cenv (append (map (lambda: ([p : Lam]) 
-                                        (extract-static-knowledge 
-                                         p 
-                                         (append (build-list (length (LetRec-procs exp))
-                                                             (lambda: ([i : Natural]) '?))
-                                                 (drop cenv n))))
-                                      (LetRec-procs exp))
-                                 (drop cenv n))])
-           (loop (LetRec-body exp) new-cenv acc)))]
-      
-      [(WithContMark? exp)
-       (define acc-1 (loop (WithContMark-key exp) cenv acc))
-       (define acc-2 (loop (WithContMark-value exp) cenv acc-1))
-       (define acc-3 (loop (WithContMark-body exp) cenv acc-2))
-       acc-3]
-      
-      [(ApplyValues? exp)
-       (define acc-1 (loop (ApplyValues-proc exp) cenv acc))
-       (define acc-2 (loop (ApplyValues-args-expr exp) cenv acc-1))
-       acc-2]
-      
-      [(DefValues? exp)
-       (loop (DefValues-rhs exp) cenv acc)]
-      
-      [(PrimitiveKernelValue? exp)
-       acc]
-      
-      [(VariableReference? exp)
-       (loop (VariableReference-toplevel exp) cenv acc)]
-      
-      [(Require? exp)
-       acc])))
-
-
-
-
-
-(: extract-static-knowledge (Expression CompileTimeEnvironment ->  
-                                        CompileTimeEnvironmentEntry))
-;; Statically determines what we know about the expression, given the compile time environment.
-;; We should do more here eventually, including things like type inference or flow analysis, so that
-;; we can generate better code.
-(define (extract-static-knowledge exp cenv)
-  (cond
-    [(Lam? exp)
-     ;(log-debug "known to be a lambda")
-     (make-StaticallyKnownLam (Lam-name exp)
-                              (Lam-entry-label exp)
-                              (if (Lam-rest? exp)
-                                  (make-ArityAtLeast (Lam-num-parameters exp))
-                                  (Lam-num-parameters exp)))]
-    [(and (LocalRef? exp) 
-          (not (LocalRef-unbox? exp)))
-     (let ([entry (list-ref cenv (LocalRef-depth exp))])
-       ;(log-debug (format "known to be ~s" entry))
-       entry)]
-    
-    [(EmptyClosureReference? exp)
-     (make-StaticallyKnownLam (EmptyClosureReference-name exp)
-                              (EmptyClosureReference-entry-label exp)
-                              (if (EmptyClosureReference-rest? exp)
-                                  (make-ArityAtLeast (EmptyClosureReference-num-parameters exp))
-                                  (EmptyClosureReference-num-parameters exp)))]
-    [(ToplevelRef? exp)
-     ;(log-debug (format "toplevel reference of ~a" exp))
-     ;(when (ToplevelRef-constant? exp)
-     ;  (log-debug (format "toplevel reference ~a should be known constant" exp)))
-     (let: ([name : (U Symbol False GlobalBucket ModuleVariable)
-                  (list-ref (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp))))
-                            (ToplevelRef-pos exp))])
-       (cond
-         [(ModuleVariable? name)
-          ;(log-debug (format "toplevel reference is to ~s" name))
-          name]
-         [(GlobalBucket? name)
-          '?]
-         [else
-          ;(log-debug (format "nothing statically known about ~s" exp))
-          '?]))]
-    
-    [(Constant? exp)
-     (make-Const (ensure-const-value (Constant-v exp)))]
-    
-    [(PrimitiveKernelValue? exp)
-     exp]
-    
-    [else
-     ;(log-debug (format "nothing statically known about ~s" exp))
-     '?]))
-
-
-
-
-
-
-
-
-
-(: collect-all-lambdas-with-bodies (Expression -> (Listof lam+cenv)))
-;; Finds all the lambdas in the expression.
-(define (collect-all-lambdas-with-bodies exp)
-  (let: loop : (Listof lam+cenv)
-    ([exp : Expression exp]
-     [cenv : CompileTimeEnvironment '()])
-    
-    (cond
-      [(Top? exp)
-       (loop (Top-code exp) (cons (Top-prefix exp) cenv))]
-      [(Module? exp)
-       (loop (Module-code exp) (cons (Module-prefix exp) cenv))]
-      [(Constant? exp)
-       '()]
-      [(LocalRef? exp)
-       '()]
-      [(ToplevelRef? exp)
-       '()]
-      [(ToplevelSet? exp)
-       (loop (ToplevelSet-value exp) cenv)]
-      [(Branch? exp)
-       (append (loop (Branch-predicate exp) cenv)
-               (loop (Branch-consequent exp) cenv)
-               (loop (Branch-alternative exp) cenv))]
-      [(Lam? exp)
-       (cons (make-lam+cenv exp (extract-lambda-cenv exp cenv))
-             (loop (Lam-body exp) 
-                   (extract-lambda-cenv exp cenv)))]
-      [(CaseLam? exp)
-       (cons (make-lam+cenv exp cenv)
-             (apply append (map (lambda: ([lam : (U Lam EmptyClosureReference)])
-                                  (loop lam cenv))
-                                (CaseLam-clauses exp))))]
-      
-      [(EmptyClosureReference? exp)
-       '()]
-      
-      [(Seq? exp)
-       (apply append (map (lambda: ([e : Expression]) (loop e cenv))
-                          (Seq-actions exp)))]
-      [(Splice? exp)
-       (apply append (map (lambda: ([e : Expression]) (loop e cenv))
-                          (Splice-actions exp)))]
-      [(Begin0? exp)
-       (apply append (map (lambda: ([e : Expression]) (loop e cenv))
-                          (Begin0-actions exp)))]
-      [(App? exp)
-       (let ([new-cenv (append (build-list (length (App-operands exp)) (lambda: ([i : Natural]) '?))
-                               cenv)])
-         (append (loop (App-operator exp) new-cenv)
-                 (apply append (map (lambda: ([e : Expression]) (loop e new-cenv)) (App-operands exp)))))]
-      [(Let1? exp)
-       (append (loop (Let1-rhs exp)
-                     (cons '? cenv))
-               (loop (Let1-body exp) 
-                     (cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv)) 
-                           cenv)))]
-      [(LetVoid? exp)
-       (loop (LetVoid-body exp) 
-             (append (build-list (LetVoid-count exp) (lambda: ([i : Natural]) '?))
-                     cenv))]
-      [(InstallValue? exp)
-       (loop (InstallValue-body exp) cenv)]
-      [(BoxEnv? exp)
-       (loop (BoxEnv-body exp) cenv)]
-      [(LetRec? exp)
-       (let ([n (length (LetRec-procs exp))])
-         (let ([new-cenv (append (map (lambda: ([p : Lam]) 
-                                        (extract-static-knowledge 
-                                         p 
-                                         (append (build-list (length (LetRec-procs exp))
-                                                             (lambda: ([i : Natural]) '?))
-                                                 (drop cenv n))))
-                                      (LetRec-procs exp))
-                                 (drop cenv n))])
-           (append (apply append 
-                          (map (lambda: ([lam : Lam])
-                                 (loop lam new-cenv))
-                               (LetRec-procs exp)))
-                   (loop (LetRec-body exp) new-cenv))))]
-      [(WithContMark? exp)
-       (append (loop (WithContMark-key exp) cenv)
-               (loop (WithContMark-value exp) cenv)
-               (loop (WithContMark-body exp) cenv))]
-      [(ApplyValues? exp)
-       (append (loop (ApplyValues-proc exp) cenv)
-               (loop (ApplyValues-args-expr exp) cenv))]
-      [(DefValues? exp)
-       (append (loop (DefValues-rhs exp) cenv))]
-      [(PrimitiveKernelValue? exp)
-       '()]
-      [(VariableReference? exp)
-       (loop (VariableReference-toplevel exp) cenv)]
-      [(Require? exp)
-       '()])))
-
-
-
-(: extract-lambda-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment))
-;; Given a Lam and the ambient environment, produces the compile time environment for the
-;; body of the lambda.
-(define (extract-lambda-cenv lam cenv)
-  (append (map (lambda: ([d : Natural])
-                 (list-ref cenv d))
-               (Lam-closure-map lam))
-          (build-list (if (Lam-rest? lam)
-                          (add1 (Lam-num-parameters lam))
-                          (Lam-num-parameters lam))
-                      (lambda: ([i : Natural]) '?))))
-
-
-
-
-
-
-
-
-
-
-(: ensure-prefix (CompileTimeEnvironmentEntry -> Prefix))
-(define (ensure-prefix x)
-  (if (Prefix? x)
-      x
-      (error 'ensure-prefix "Not a prefix: ~s" x)))

whalesong/compiler/arity-structs.rkt

@@ -1,11 +0,0 @@
-#lang typed/racket/base
-
-(provide (all-defined-out))
-
-;; Arity
-(define-type Arity (U AtomicArity (Listof (U AtomicArity))))
-(define-type AtomicArity (U Natural ArityAtLeast))
-(define-struct: ArityAtLeast ([value : Natural])
-  #:transparent)
-(define-predicate AtomicArity? AtomicArity)
-(define-predicate listof-atomic-arity? (Listof AtomicArity))

whalesong/compiler/bootstrapped-primitives.rkt

@@ -1,346 +0,0 @@
-#lang typed/racket/base
-(require "arity-structs.rkt"
-         "expression-structs.rkt"
-         "lexical-structs.rkt"
-         "il-structs.rkt"
-         (except-in "compiler.rkt" compile)
-         "compiler-structs.rkt")
-
-(require (rename-in "compiler.rkt"
-                     [compile whalesong-compile]))
-
-
-
-(require/typed "../parameters.rkt"
-               (current-defined-name (Parameterof (U Symbol LamPositionalName))))
-(require/typed "../parser/parse-bytecode.rkt"
-               (parse-bytecode (Compiled-Expression -> Expression)))
-
-
-
-(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
-    call/cc-label
-    ;; Precondition: the environment holds the f function that we want to jump into.
-    
-    ;; First, move f to the proc register
-    (make-AssignImmediate 'proc (make-EnvLexicalReference 0 #f))
-    
-    ;; Next, capture the envrionment and the current continuation closure,.
-    (make-PushEnvironment 2 #f)
-    (make-AssignPrimOp (make-EnvLexicalReference 0 #f) 
-                                (make-CaptureControl 0 default-continuation-prompt-tag))
-    (make-AssignPrimOp (make-EnvLexicalReference 1 #f)
-                                ;; When capturing, skip over f and the two slots we just added.
-                                (make-CaptureEnvironment 3 default-continuation-prompt-tag))
-    (make-AssignPrimOp (make-EnvLexicalReference 2 #f)
-                                 (make-MakeCompiledProcedure call/cc-closure-entry
-                                                             1 ;; the continuation consumes a single value
-                                                             (list 0 1)
-                                                             'call/cc))
-    (make-PopEnvironment (make-Const 2) 
-                          (make-Const 0))
-       
-    ;; Finally, do a tail call into f.
-    (make-AssignImmediate 'argcount (make-Const 1))
-    (compile-general-procedure-call '()
-                                    (make-Const 1) ;; the stack at this point holds a single argument
-                                    'val
-                                    return-linkage)
-    
-    ;; The code for the continuation code follows.  It's supposed to
-    ;; abandon the current continuation, initialize the control and environment, and then jump.
-    call/cc-closure-entry
-    (make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
-    (make-Perform (make-InstallClosureValues! 2))
-    (make-Perform (make-RestoreControl! default-continuation-prompt-tag))
-    (make-Perform (make-RestoreEnvironment!))
-    (make-AssignImmediate 'proc (make-ControlStackLabel))
-    (make-PopControlFrame)
-    (make-Goto (make-Reg 'proc)))))
-
-
-
-(: make-bootstrapped-primitive-code (Symbol Any -> (Listof Statement)))
-;; Generates the bootstrapped code for some of the primitives.  Note: the source must compile
-;; under #%kernel, or else!
-(define make-bootstrapped-primitive-code
-  (let ([ns (make-base-empty-namespace)])
-    (parameterize ([current-namespace ns]) (namespace-require ''#%kernel))
-    (lambda (name src)
-      (parameterize ([current-defined-name name])
-        (append
-         (whalesong-compile (parameterize ([current-namespace ns])
-                              (parse-bytecode (compile src)))
-                            (make-PrimitivesReference name) next-linkage/drop-multiple))))))
-
-
-
-
-(: make-map-src (Symbol Symbol -> Any))
-;; Generates the code for map.
-(define (make-map-src name combiner)
-  `(letrec-values ([(first-tuple) (lambda (lists)
-                                   (if (null? lists)
-                                       '()
-                                       (cons (car (car lists))
-                                             (first-tuple (cdr lists)))))]
-                  [(rest-lists) (lambda (lists)
-                                  (if (null? lists)
-                                      '()
-                                      (cons (cdr (car lists))
-                                            (rest-lists (cdr lists)))))]
-                  [(all-empty?) (lambda (lists)
-                                  (if (null? lists)
-                                      #t
-                                      (if (null? (car lists))
-                                          (all-empty? (cdr lists))
-                                          #f)))]
-                  [(some-empty?) (lambda (lists)
-                                   (if (null? lists)
-                                       #f
-                                       (if (null? (car lists))
-                                           #t
-                                           
-                                           (some-empty? (cdr lists)))))]
-                  [(do-it) (lambda (f lists)
-                             (letrec-values ([(loop) (lambda (lists)
-                                                       (if (all-empty? lists)
-                                                           null
-                                                           (if (some-empty? lists)
-                                                               (error 
-                                                                ',name 
-                                                                "all lists must have the same size")
-                                                               (,combiner (apply f (first-tuple lists))
-                                                                          (loop (rest-lists lists))))))])
-                                            (loop lists)))])
-                 (lambda (f . args)
-                   (do-it f args))))
-
-
-
-
-
-
-(: get-bootstrapping-code (-> (Listof Statement)))
-(define (get-bootstrapping-code)
-  
-  (append
-
-   
-   ;; Other primitives
-   (make-bootstrapped-primitive-code 
-    'map 
-    (make-map-src 'map 'cons))
-
-   (make-bootstrapped-primitive-code
-    'for-each
-    (make-map-src 'for-each 'begin))
-
-   (make-bootstrapped-primitive-code
-    'andmap
-    (make-map-src 'andmap 'and))
-
-   (make-bootstrapped-primitive-code
-    'ormap
-    (make-map-src 'ormap 'or))
-
-   
-   
-   (make-bootstrapped-primitive-code
-    'caar
-    '(lambda (x)
-       (car (car x))))
-
-
-   (make-bootstrapped-primitive-code
-    'memq
-    '(letrec-values ([(memq) (lambda (x l)
-                               (if (null? l)
-                                   #f
-                                   (if (eq? x (car l))
-                                       l
-                                       (memq x (cdr l)))))])
-                    memq))
-   (make-bootstrapped-primitive-code
-    'memv
-    '(letrec-values ([(memv) (lambda (x l)
-                               (if (null? l)
-                                   #f
-                                   (if (eqv? x (car l))
-                                       l
-                                       (memv x (cdr l)))))])
-                    memv))
-   
-   (make-bootstrapped-primitive-code
-    'memf
-    '(letrec-values ([(memf) (lambda (x f l)
-                               (if (null? l)
-                                   #f
-                                   (if (f x)
-                                       l
-                                       (memf x f (cdr l)))))])
-                    memf))
-   
-   (make-bootstrapped-primitive-code
-    'assq
-    '(letrec-values ([(assq) (lambda (x l)
-                               (if (null? l)
-                                   #f
-                                   (if (eq? x (caar l))
-                                       (car l)
-                                       (assq x (cdr l)))))])
-                    assq))
-   (make-bootstrapped-primitive-code
-    'assv
-    '(letrec-values ([(assv) (lambda (x l)
-                               (if (null? l)
-                                   #f
-                                   (if (eqv? x (caar l))
-                                       (car l)
-                                       (assv x (cdr l)))))])
-                    assv))
-   (make-bootstrapped-primitive-code
-    'assoc
-    '(letrec-values ([(assoc) (lambda (x l)
-                               (if (null? l)
-                                   #f
-                                   (if (equal? x (caar l))
-                                       (car l)
-                                       (assoc x (cdr l)))))])
-                    assoc))   
-   (make-bootstrapped-primitive-code
-    'length
-    '(letrec-values ([(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-values ([(append-many) (lambda (lsts)
-                                      (if (null? lsts)
-                                          null
-                                          (if (null? (cdr lsts))
-                                              (car lsts)
-                                              (append-2 (car lsts)
-                                                        (append-many (cdr lsts))))))]
-                     [(append-2) (lambda (l1 l2)
-                                   (if (null? l1) 
-                                       l2
-                                       (cons (car l1) (append-2 (cdr l1) l2))))])
-                    (lambda args (append-many args))))
-
-
-   (make-bootstrapped-primitive-code
-    'call-with-values
-    '(lambda (producer consumer)
-       (call-with-values (lambda () (producer)) consumer)))
-      
-   
-   
-   ;; The call/cc code is special:
-   (let ([after-call/cc-code (make-label 'afterCallCCImplementation)])
-     (append 
-
-      `(,(make-AssignPrimOp (make-PrimitivesReference 'call/cc) 
-                                     (make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
-        ,(make-AssignPrimOp (make-PrimitivesReference 'call-with-current-continuation) 
-                                     (make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
-        ,(make-Goto (make-Label after-call/cc-code)))
-      (make-call/cc-code)
-      `(,after-call/cc-code)))
-   
-  
-   
-   ;; values
-   ;; values simply keeps all (but the first) value on the stack, preserves the argcount, and does a return
-   ;; to the multiple-value-return address.
-   (let ([after-values-body-defn (make-label 'afterValues)]
-         [values-entry (make-label 'valuesEntry)]
-         [on-zero-values (make-label 'onZeroValues)]
-         [on-single-value (make-label 'onSingleValue)])
-     `(,(make-Goto (make-Label after-values-body-defn))
-       ,values-entry
-       ,(make-TestAndJump (make-TestOne (make-Reg 'argcount)) on-single-value)
-       ,(make-TestAndJump (make-TestZero (make-Reg 'argcount)) on-zero-values)
-
-       ;; Common case: we're running multiple values.  Put the first in the val register
-       ;; and go to the multiple value return.
-       ,(make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
-       ,(make-PopEnvironment (make-Const 1) (make-Const 0))
-       ,(make-AssignImmediate 'proc (make-ControlStackLabel/MultipleValueReturn))
-       ,(make-PopControlFrame)
-       ,(make-Goto (make-Reg 'proc))
-
-       ;; Special case: on a single value, just use the regular return address
-       ,on-single-value
-       ,(make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
-       ,(make-PopEnvironment (make-Const 1) (make-Const 0))
-       ,(make-AssignImmediate 'proc (make-ControlStackLabel))
-       ,(make-PopControlFrame)
-       ,(make-Goto (make-Reg 'proc))
-
-       ;; On zero values, leave things be and just return.
-       ,on-zero-values
-       ,(make-AssignImmediate 'proc (make-ControlStackLabel/MultipleValueReturn))
-       ,(make-PopControlFrame)
-       ,(make-Goto (make-Reg 'proc))
-       
-       ,after-values-body-defn
-       ,(make-AssignPrimOp (make-PrimitivesReference 'values)
-                                    (make-MakeCompiledProcedure values-entry
-                                                                (make-ArityAtLeast 0) 
-                                                                '() 
-                                                                'values))))
-   
-   
-   
-   
-   ;; As is apply:
-   (let ([after-apply-code (make-label 'afterApplyCode)]
-         [apply-entry (make-label 'applyEntry)])
-     `(,(make-Goto (make-Label after-apply-code))
-       ,apply-entry
-       
-       ;; Push the procedure into proc.
-       ,(make-AssignImmediate 'proc (make-EnvLexicalReference 0 #f))
-       ,(make-PopEnvironment (make-Const 1) (make-Const 0))
-       ;; Correct the number of arguments to be passed.
-       ,(make-AssignImmediate 'argcount (make-SubtractArg (make-Reg 'argcount)
-                                                                   (make-Const 1)))
-       ;; Splice in the list argument.
-       ,(make-Perform (make-SpliceListIntoStack! (make-SubtractArg (make-Reg 'argcount)
-                                                                            (make-Const 1))))
-       
-       ;; Finally, jump into the procedure body
-       ,@(statements (compile-general-procedure-call '()
-                                                     (make-Reg 'argcount) ;; the stack contains only the argcount elements.
-                                                     'val
-                                                     return-linkage))
-       
-       
-       ,after-apply-code
-       ,(make-AssignPrimOp (make-PrimitivesReference 'apply)
-                                    (make-MakeCompiledProcedure apply-entry (make-ArityAtLeast 2) '() 'apply))))))

whalesong/compiler/compiler-helper.rkt

@@ -1,38 +0,0 @@
-#lang racket/base
-
-(provide ensure-const-value)
-
-(define (ensure-const-value x)
-  (cond
-   [(symbol? x)
-    x]
-   [(boolean? x)
-    x]
-   [(string? x)
-    x]
-   [(number? x)
-    x]
-   [(void? x)
-    x]
-   [(null? x)
-    x]
-   [(char? x)
-    x]
-   [(bytes? x)
-    x]
-   [(path? x)
-    x]
-   [(pair? x)
-    (begin (ensure-const-value (car x))
-           (ensure-const-value (cdr x))
-           x)]
-   [(vector? x)
-    (begin (for-each ensure-const-value (vector->list x)))
-    x]
-   [(box? x)
-    (ensure-const-value (unbox x))
-    x]
-   [else
-    (error 'ensure-const-value "Not a const value: ~s\n" x)]))
-         
-    

whalesong/compiler/compiler-structs.rkt

@@ -1,47 +0,0 @@
-#lang typed/racket/base
-(require "expression-structs.rkt"
-         "analyzer-structs.rkt")
-
-
-(provide (all-defined-out))
-
-
-;; A ValuesContext describes if a context either
-;;    * accepts any number multiple values by dropping them from the stack.
-;;    * accepts any number of multiple values by maintaining them on the stack.
-;;    * accepts exactly n values, erroring out
-(define-type ValuesContext (U 'tail
-                              'drop-multiple 
-                              'keep-multiple
-			      Natural))
-
-
-;; Linkage
-(define-struct: NextLinkage ([context : ValuesContext]))
-(define next-linkage/drop-multiple (make-NextLinkage 'drop-multiple))
-(define next-linkage/expects-single (make-NextLinkage 1))
-(define next-linkage/keep-multiple-on-stack (make-NextLinkage 'keep-multiple))
-
-
-
-;; LabelLinkage is a labeled GOTO.
-(define-struct: LabelLinkage ([label : Symbol]
-			      [context : ValuesContext]))
-
-
-
-;; Both ReturnLinkage and ReturnLinkage/NonTail deal with multiple
-;; values indirectly, through the alternative multiple-value-return
-;; address in the LinkedLabel of their call frame.
-(define-struct: ReturnLinkage ([tail? : Boolean]))
-(define return-linkage (make-ReturnLinkage #t))
-(define return-linkage/nontail (make-ReturnLinkage #f))
-
-(define-type Linkage (U NextLinkage
-                        LabelLinkage
-                        ReturnLinkage))
-
-
-;; Lambda and compile-time environment
-(define-struct: lam+cenv ([lam : (U Lam CaseLam)]
-                          [cenv : CompileTimeEnvironment]))

whalesong/compiler/expression-structs.rkt

@@ -1,186 +0,0 @@
-#lang typed/racket/base
-(require "lexical-structs.rkt")
-
-
-(provide (all-defined-out))
-
-
-;; Expressions
-(define-type Expression (U
-                         Top
-                         Constant 
-                         ToplevelRef
-                         LocalRef
-                         ToplevelSet
-                         Branch 
-                         Lam 
-                         CaseLam
-                         EmptyClosureReference
-                         Seq 
-                         Splice 
-                         Begin0
-                         App
-                         Let1 
-                         LetVoid 
-                         LetRec
-                         InstallValue
-                         BoxEnv
-                         WithContMark
-                         ApplyValues
-                         DefValues
-                         PrimitiveKernelValue
-                         Module
-                         VariableReference
-                         Require))
-
-
-(define-struct: Module ([name : Symbol]
-                        [path : ModuleLocator]
-                        [prefix : Prefix]
-                        [requires : (Listof ModuleLocator)]
-                        [provides : (Listof ModuleProvide)]
-                        [code : Expression])
-  #:transparent)
-
-
-(define-struct: ModuleProvide ([internal-name : Symbol]
-                               [external-name : Symbol]
-                               [source : ModuleLocator])
-  #:transparent)
-
-
-
-(define-struct: Top ([prefix : Prefix]
-                     [code : Expression]) #:transparent)
-
-(define-struct: Constant ([v : Any]) #:transparent)
-
-(define-struct: ToplevelRef ([depth : Natural]
-                             [pos : Natural]
-                             [constant? : Boolean]
-                             [check-defined? : Boolean]) #:transparent)
-
-(define-struct: LocalRef ([depth : Natural]
-                          [unbox? : Boolean]) #:transparent)
-
-(define-struct: ToplevelSet ([depth : Natural]
-                             [pos : Natural]
-                             [value : Expression]) #:transparent)
-
-(define-struct: Branch ([predicate : Expression]
-                        [consequent : Expression]
-                        [alternative : Expression]) #:transparent)
-
-(define-struct: CaseLam ([name : (U Symbol LamPositionalName)]
-                         [clauses : (Listof (U Lam EmptyClosureReference))]
-                         [entry-label : Symbol]) #:transparent)
-
-(define-struct: Lam ([name : (U Symbol LamPositionalName)]
-                     [num-parameters : Natural]
-                     [rest? : Boolean]
-                     [body : Expression]
-                     [closure-map : (Listof Natural)]
-                     [entry-label : Symbol]) #:transparent)
-
-;; An EmptyClosureReference has enough information to create the lambda value,
-;; assuming that the lambda's body has already been compiled.  The entry-label needs
-;; to have been shared with an existing Lam, and the closure must be empty.
-(define-struct: EmptyClosureReference ([name : (U Symbol LamPositionalName)]
-                                       [num-parameters : Natural]
-                                       [rest? : Boolean]
-                                       [entry-label : Symbol]) #:transparent)
-
-
-
-;; We may have more information about the lambda's name.  This will show it.
-(define-struct: LamPositionalName ([name : Symbol] 
-                                   [path : String]    ;; the source of the name
-                                   [line : Natural] 
-                                   [column : Natural] 
-                                   [offset : Natural] 
-                                   [span : Natural]) #:transparent)
-
-
-
-(define-struct: Seq ([actions : (Listof Expression)]) #:transparent)
-(define-struct: Splice ([actions : (Listof Expression)]) #:transparent)
-(define-struct: Begin0 ([actions : (Listof Expression)]) #:transparent)
-(define-struct: App ([operator : Expression]
-                     [operands : (Listof Expression)]) #:transparent)
-
-(define-struct: Let1 ([rhs : Expression]
-                      [body : Expression])  #:transparent)
-
-(define-struct: LetVoid ([count : Natural]
-                         [body : Expression]
-                         [boxes? : Boolean]) #:transparent)
-
-
-;; During evaluation, the closures corresponding to procs are expected
-;; to be laid out so that stack position 0 corresponds to procs[0],
-;; stack position 1 to procs[1], and so on.
-(define-struct: LetRec ([procs : (Listof Lam)]
-                        [body : Expression]) #:transparent)
-
-(define-struct: InstallValue ([count : Natural] ;; how many values to install
-                              [depth : Natural] ;; how many slots to skip
-                              [body : Expression]
-                              [box? : Boolean])  #:transparent)
-
-
-(define-struct: BoxEnv ([depth : Natural]
-                        [body : Expression]) #:transparent)
-
-
-
-(define-struct: WithContMark ([key : Expression]
-                              [value : Expression]
-                              [body : Expression]) #:transparent)
-
-
-(define-struct: ApplyValues ([proc : Expression]
-                             [args-expr : Expression]) #:transparent)
-
-
-;; Multiple value definition
-(define-struct: DefValues ([ids : (Listof ToplevelRef)]
-                           [rhs : Expression]) #:transparent)
-
-
-
-(define-struct: PrimitiveKernelValue ([id : Symbol]) #:transparent)
-
-
-(define-struct: VariableReference ([toplevel : ToplevelRef]) #:transparent)
-
-
-(define-struct: Require ([path : ModuleLocator]) #:transparent)
-
-
-
-
-(: current-short-labels? (Parameterof Boolean))
-(define current-short-labels? (make-parameter #t))
-
-
-(define make-label-counter 0)
-
-(: reset-make-label-counter (-> Void))
-(define (reset-make-label-counter)
-  (set! make-label-counter 0))
-
-(: make-label (Symbol -> Symbol))
-#;(define make-label
-  (let ([n 0])
-    (lambda (l)
-      (set! n (add1 n))
-      (if (current-short-labels?)
-          (string->symbol (format "_~a" n))
-          (string->symbol (format "~a~a" l n))))))
-
-(define (make-label l)
-  (set! make-label-counter (+ make-label-counter 1))
-  (define n make-label-counter)
-  (if (current-short-labels?)
-      (string->symbol (format "_~a" n))
-      (string->symbol (format "~a~a" l n))))

whalesong/compiler/il-structs.rkt

@@ -1,623 +0,0 @@
-#lang typed/racket/base
-(provide (all-defined-out))
-
-(require "expression-structs.rkt"
-         "lexical-structs.rkt"
-         "kernel-primitives.rkt"
-         "arity-structs.rkt")
-
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Registers of the machine:
-
-(define-type StackRegisterSymbol (U 'control 'env))
-(define-type AtomicRegisterSymbol (U 'val 'proc 'argcount))
-(define-type RegisterSymbol (U StackRegisterSymbol AtomicRegisterSymbol))
-
-(define-predicate AtomicRegisterSymbol? AtomicRegisterSymbol)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;; An operation can refer to the following arguments:
-(define-type OpArg (U Const ;; an constant
-                      Label ;; an label
-                      Reg   ;; an register 
-                      EnvLexicalReference ;; a reference into the stack
-                      EnvPrefixReference  ;; a reference into an element in the toplevel.
-                      EnvWholePrefixReference ;; a reference into a toplevel prefix in the stack.
-                      SubtractArg
-		      ControlStackLabel
-		      ControlStackLabel/MultipleValueReturn
-                      ControlFrameTemporary
-                      CompiledProcedureEntry
-                      CompiledProcedureClosureReference
-                      ModuleEntry
-                      ModulePredicate
-                      PrimitiveKernelValue
-                      VariableReference
-                      ))
-
-
-;; Targets: these are the allowable lhs's for a targetted assignment.
-(define-type Target (U AtomicRegisterSymbol 
-                       EnvLexicalReference
-                       EnvPrefixReference
-                       PrimitivesReference
-                       GlobalsReference
-                       ControlFrameTemporary
-                       ModulePrefixTarget
-                       ))
-
-(define-struct: ModuleVariableThing () #:transparent)
-
-
-;; When we need to store a value temporarily in the top control frame, we can use this as a target.
-(define-struct: ControlFrameTemporary ([name : (U 'pendingContinuationMarkKey ;; for continuation marks
-                                                  'pendingApplyValuesProc ;; for apply-values
-                                                  'pendingBegin0Count
-                                                  'pendingBegin0Values
-                                                  )])
-  #:transparent)
-
-
-;; Targetting the prefix attribute of a module.
-(define-struct: ModulePrefixTarget ([path : ModuleLocator])
-  #:transparent)
-
-(define-struct: ModuleVariableReference ([name : Symbol]
-                                         [module-name : ModuleLocator])
-  #:transparent)
-
-
-
-(define-type const-value
-  (Rec C
-       (U Symbol
-          String
-          Number
-          Boolean
-          Void
-          Null
-          Char
-          Bytes
-          Path
-          (Pairof C C)
-          (Vectorof C)
-          (Boxof C))))
-
-
-(define-struct: Label ([name : Symbol])
-  #:transparent)
-(define-struct: Reg ([name : AtomicRegisterSymbol])
-  #:transparent)
-(define-struct: Const ([const : const-value])
-  #:transparent)
-
-;; Limited arithmetic on OpArgs
-(define-struct: SubtractArg ([lhs : OpArg]
-                             [rhs : OpArg])
-  #:transparent)
-
-
-(: new-SubtractArg (OpArg OpArg -> OpArg))
-(define (new-SubtractArg lhs rhs)
-  ;; FIXME: do some limited constant folding here
-  (cond
-   [(and (Const? lhs)(Const? rhs))
-    (let ([lhs-val (Const-const lhs)]
-          [rhs-val (Const-const rhs)])
-      (cond [(and (number? lhs-val)
-                  (number? rhs-val))
-             (make-Const (- lhs-val rhs-val))]
-            [else
-             (make-SubtractArg lhs rhs)]))]
-   [(Const? rhs)
-    (let ([rhs-val (Const-const rhs)])
-      (cond
-       [(and (number? rhs-val)
-             (= rhs-val 0))
-        lhs]
-       [else
-        (make-SubtractArg lhs rhs)]))]
-   [else
-    (make-SubtractArg lhs rhs)]))
-
-
-
-
-
-
-;; Gets the return address embedded at the top of the control stack.
-(define-struct: ControlStackLabel ()
-  #:transparent)
-
-;; Gets the secondary (mulitple-value-return) return address embedded
-;; at the top of the control stack.
-(define-struct: ControlStackLabel/MultipleValueReturn ()
-  #:transparent)
-
-;; Get the entry point of a compiled procedure.
-(define-struct: CompiledProcedureEntry ([proc : OpArg])
-  #:transparent)
-
-
-;; Get at the nth value in a closure's list of closed values.
-(define-struct: CompiledProcedureClosureReference ([proc : OpArg]
-                                                   [n : Natural])
-  #:transparent)
-
-
-(define-struct: PrimitivesReference ([name : Symbol])
-  #:transparent)
-
-(define-struct: GlobalsReference ([name : Symbol])
-  #:transparent)
-
-
-;; Produces the entry point of the module.
-(define-struct: ModuleEntry ([name : ModuleLocator])
-  #:transparent)
-
-
-(define-struct: ModulePredicate ([module-name : ModuleLocator]
-                                 [pred : (U 'invoked? 'linked?)])
-  #:transparent)
-
-
-
-;; A straight-line statement includes non-branching stuff.
-(define-type StraightLineStatement (U
-                                    DebugPrint
-                                    Comment
-                                    MarkEntryPoint
-                                    
-                                    AssignImmediate
-                                    AssignPrimOp
-                                    Perform
-                                    
-                                    PopEnvironment
-                                    PushEnvironment
-                                    PushImmediateOntoEnvironment
-                                    
-                                    PushControlFrame/Generic
-                                    PushControlFrame/Call
-                                    PushControlFrame/Prompt
-                                    PopControlFrame))
-
-(define-type BranchingStatement (U Goto TestAndJump))
-                                 
-
-;; instruction sequences
-(define-type UnlabeledStatement (U StraightLineStatement BranchingStatement))
-
-(define-predicate UnlabeledStatement? UnlabeledStatement)
-
-
-;; Debug print statement.
-(define-struct: DebugPrint ([value : OpArg])
-  #:transparent)
-
-
-(define-type Statement (U UnlabeledStatement
-                          Symbol      ;; label
-                          LinkedLabel ;; Label with a reference to a multiple-return-value label
-                          ))
-
-
-(define-struct: LinkedLabel ([label : Symbol]
-                             [linked-to : Symbol])
-  #:transparent)
-
-
-;; Returns a pair of labels, the first being the mutiple-value-return
-;; label and the second its complementary single-value-return label.
-(: new-linked-labels (Symbol -> (Values Symbol LinkedLabel)))
-(define (new-linked-labels sym)
-  (define a-label-multiple (make-label (string->symbol (format "~aMultiple" sym))))
-  (define a-label (make-LinkedLabel (make-label sym) a-label-multiple))
-  (values a-label-multiple a-label))
-
-
-
-
-
-;; FIXME: it would be nice if I can reduce AssignImmediate and
-;; AssignPrimOp into a single Assign statement, but I run into major
-;; issues with Typed Racket taking minutes to compile.  So we're
-;; running into some kind of degenerate behavior.
-(define-struct: AssignImmediate ([target : Target]
-                                 [value : OpArg])
-  #:transparent)
-(define-struct: AssignPrimOp ([target : Target]
-                              [op : PrimitiveOperator])
-  #:transparent)
-
-
-;; Pop n slots from the environment, skipping past a few first.
-(define-struct: PopEnvironment ([n : OpArg]
-                                [skip : OpArg])
-  #:transparent)
-(define-struct: PushEnvironment ([n : Natural]
-                                 [unbox? : Boolean])
-  #:transparent)
-
-
-;; Evaluate the value, and then push it onto the top of the environment.
-(define-struct: PushImmediateOntoEnvironment ([value : OpArg]
-                                              [box? : Boolean])
-  #:transparent)
-
-
-(define-struct: PopControlFrame () 
-  #:transparent)
-
-
-;; A generic control frame only holds marks and other temporary variables.
-(define-struct: PushControlFrame/Generic ()
-  #:transparent)
-
-;; Adding a frame for getting back after procedure application.
-;; The 'proc register must hold either #f or a closure at the time of
-;; this call, as the control frame will hold onto the called procedure record.
-(define-struct: PushControlFrame/Call ([label : LinkedLabel]) 
-  #:transparent)
-
-(define-struct: PushControlFrame/Prompt
-  ([tag : (U OpArg DefaultContinuationPromptTag)]
-   [label : LinkedLabel])
-  #:transparent)
-
-
-(define-struct: DefaultContinuationPromptTag ()
-  #:transparent)
-(define default-continuation-prompt-tag 
-  (make-DefaultContinuationPromptTag))
-
-
-
-
-(define-struct: Goto ([target : (U Label 
-                                            Reg
-                                            ModuleEntry
-                                            CompiledProcedureEntry)]) 
-  #:transparent)
-
-(define-struct: Perform ([op : PrimitiveCommand])
-  #:transparent)
-
-
-
-(define-struct: TestAndJump ([op : PrimitiveTest]
-                                      [label : Symbol])
-  #:transparent)
-
-
-(define-struct: Comment ([val : Any])
-  #:transparent)
-
-
-;; Marks the head of every lambda.
-(define-struct: MarkEntryPoint ([label : Symbol])
-  #:transparent)
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Primitive Operators
-
-;; The operators that return values, that are used in AssignPrimopStatement.
-;; The reason this is here is really to get around what looks like a Typed Racket issue.
-;; I would prefer to move these all to OpArgs, but if I do, Typed Racket takes much longer
-;; to type my program than I'd like.
-(define-type PrimitiveOperator (U GetCompiledProcedureEntry
-                                  MakeCompiledProcedure
-                                  MakeCompiledProcedureShell
-
-                                  ModuleVariable
-                                  PrimitivesReference
-                                  GlobalsReference
-                                  
-                                  MakeBoxedEnvironmentValue
-
-                                  CaptureEnvironment
-                                  CaptureControl
-                                  
-                                  CallKernelPrimitiveProcedure
-                                  ApplyPrimitiveProcedure
-                                  ))
-
-;; Gets the label from the closure stored in the 'proc register and returns it.
-(define-struct: GetCompiledProcedureEntry ()
-  #:transparent)
-
-;; Constructs a closure, given the label, # of expected arguments,
-;; and the set of lexical references into the environment that the
-;; closure needs to close over.
-(define-struct: MakeCompiledProcedure ([label : Symbol]
-                                       [arity : Arity]
-                                       [closed-vals : (Listof Natural)]
-                                       [display-name : (U Symbol LamPositionalName)])
-  #:transparent)
-
-
-;; Constructs a closure shell.  Like MakeCompiledProcedure, but doesn't
-;; bother with trying to capture the free variables.
-(define-struct: MakeCompiledProcedureShell ([label : Symbol]
-                                            [arity : Arity]
-                                            [display-name : (U Symbol LamPositionalName)])
-  #:transparent)
-
-
-
-
-
-(define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName/Inline]
-
-                                              [operands : (Listof (U OpArg ModuleVariable))]
-                                              [expected-operand-types : (Listof OperandDomain)]
-                                              ;; For each operand, #t will add code to typecheck the operand
-                                              [typechecks? : (Listof Boolean)])
-  #:transparent)
-
-
-(define-struct: ApplyPrimitiveProcedure ([name : Symbol]) #:transparent)
-
-
-(define-struct: MakeBoxedEnvironmentValue ([depth : Natural])
-  #:transparent)
-
-
-;; Capture the current environment, skipping skip frames.
-(define-struct: CaptureEnvironment ([skip : Natural]
-                                    [tag : (U DefaultContinuationPromptTag OpArg)]))
-
-;; Capture the control stack, skipping skip frames.
-(define-struct: CaptureControl ([skip : Natural]
-                                [tag : (U DefaultContinuationPromptTag OpArg)]))
-
-
-
-
-;; Primitive tests (used with TestAndBranch)
-(define-type PrimitiveTest (U 
-                            TestFalse
-                            TestTrue
-                            TestOne
-                            TestZero
-                            TestClosureArityMismatch
-                            ))
-(define-struct: TestFalse ([operand : OpArg]) #:transparent)
-(define-struct: TestTrue ([operand : OpArg]) #:transparent)
-(define-struct: TestOne ([operand : OpArg]) #:transparent)
-(define-struct: TestZero ([operand : OpArg]) #:transparent)
-(define-struct: TestClosureArityMismatch ([closure : OpArg]
-                                          [n : OpArg]) #:transparent)
-
-
-
-;; Check that the value in the prefix has been defined.
-;; If not, raise an error and stop evaluation.
-(define-struct: CheckToplevelBound! ([depth : Natural]
-                                     [pos : Natural])
-  #:transparent)
-
-;; Check that the global can be defined.
-;; If not, raise an error and stop evaluation.
-(define-struct: CheckGlobalBound! ([name : Symbol])
-  #:transparent)
-
-
-;; Check the closure procedure value in 'proc and make sure it's a closure
-;; that can accept the right arguments (stored as a number in the argcount register.).
-(define-struct: CheckClosureAndArity! ()
-  #:transparent)
-
-;; Check the primitive can accept the right arguments 
-;; (stored as a number in the argcount register.).
-(define-struct: CheckPrimitiveArity! () #:transparent)
-
-
-;; Extends the environment with a prefix that holds
-;; lookups to the namespace.
-(define-struct: ExtendEnvironment/Prefix! ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))])
-  #:transparent)
-
-;; Adjusts the environment by pushing the values in the
-;; closure (held in the proc register) into itself.
-(define-struct: InstallClosureValues! ([n : Natural])
-  #:transparent)
-
-
-(define-struct: SetFrameCallee! ([proc : OpArg])
-  #:transparent)
-
-
-;; Splices the list structure that lives in env[depth] into position.
-;; Depth must evaluate to a natural.
-(define-struct: SpliceListIntoStack! ([depth : OpArg])
-  #:transparent)
-
-;; Unsplices the length arguments on the stack, replacing with a list of that length.
-;; Side effects: touches both the environment and argcount appropriately. 
-(define-struct: UnspliceRestFromStack! ([depth : OpArg]
-                                        [length : OpArg])
-  #:transparent)
-
-
-(define-struct: FixClosureShellMap! (;; depth: where the closure shell is located in the environment
-                                     [depth : Natural] 
-                                     
-                                     [closed-vals : (Listof Natural)])
-  #:transparent)
-
-;; Raises an exception that says that we expected a number of values.
-;; Assume that argcount is not equal to expected.
-(define-struct: RaiseContextExpectedValuesError! ([expected : Natural])
-  #:transparent)
-
-
-;; Raises an exception that says that we're doing a
-;; procedure application, but got sent an incorrect number.
-(define-struct: RaiseArityMismatchError! ([proc : OpArg]
-                                          [expected : Arity]
-					  [received : OpArg])
-  #:transparent)
-
-
-;; Raises an exception that says that we're doing a
-;; procedure application, but got sent an incorrect number.
-(define-struct: RaiseOperatorApplicationError! ([operator : OpArg])
-  #:transparent)
-
-
-;; Raise a runtime error if we hit a use of an unimplemented kernel primitive.
-(define-struct: RaiseUnimplementedPrimitiveError! ([name : Symbol])
-  #:transparent)
-
-
-
-
-;; Changes over the control located at the given argument from the structure in env[1]
-(define-struct: RestoreControl! ([tag : (U DefaultContinuationPromptTag OpArg)]) #:transparent)
-
-;; Changes over the environment located at the given argument from the structure in env[0]
-(define-struct: RestoreEnvironment! () #:transparent)
-
-
-;; Adds a continuation mark into the current top control frame.
-(define-struct: InstallContinuationMarkEntry! () #:transparent)
-
-
-;; Use the dynamic module loader to link the module into the runtime.
-;; After successful linkage, jump into label.
-(define-struct: LinkModule! ([path : ModuleLocator]
-                             [label : Symbol]))
-
-
-;; Installs a module record into the machine
-(define-struct: InstallModuleEntry! ([name : Symbol]
-                                     [path : ModuleLocator]
-                                     [entry-point : Symbol])
-  #:transparent)
-
-
-;; Mark that the module has been invoked.
-(define-struct: MarkModuleInvoked! ([path : ModuleLocator])
-  #:transparent)
-
-
-;; Give an alternative locator to the module as a main module.
-;; Assumes the module has already been installed.
-(define-struct: AliasModuleAsMain! ([from : ModuleLocator])
-  #:transparent)
-
-;; Given the module locator, do any finalizing operations, like
-;; setting up the module namespace.
-(define-struct: FinalizeModuleInvokation! ([path : ModuleLocator]
-                                           [provides : (Listof ModuleProvide)])
-  #:transparent)
-
-
-
-(define-type PrimitiveCommand (U                                
-                               CheckToplevelBound!
-                               CheckGlobalBound!
-                               CheckClosureAndArity!
-                               CheckPrimitiveArity!
-
-                               ExtendEnvironment/Prefix!
-                               InstallClosureValues!
-                               FixClosureShellMap!
-           
-                               InstallContinuationMarkEntry!
-                               
-                               SetFrameCallee!
-                               SpliceListIntoStack!
-                               UnspliceRestFromStack!
-                            
-                               RaiseContextExpectedValuesError!
-                               RaiseArityMismatchError!
-			       RaiseOperatorApplicationError!
-                               RaiseUnimplementedPrimitiveError!
-                               
-                               RestoreEnvironment!
-                               RestoreControl!
-                               
-                               LinkModule!
-                               InstallModuleEntry!
-                               MarkModuleInvoked!
-                               AliasModuleAsMain!
-                               FinalizeModuleInvokation!
-                               ))
-
-
-
-
-(define-type InstructionSequence (U Symbol
-                                    LinkedLabel
-                                    UnlabeledStatement
-                                    instruction-sequence-list
-                                    instruction-sequence-chunks))
-(define-struct: instruction-sequence-list ([statements : (Listof Statement)])
-  #:transparent)
-(define-struct: instruction-sequence-chunks ([chunks : (Listof InstructionSequence)])
-  #:transparent)
-(define empty-instruction-sequence (make-instruction-sequence-list '()))
-
-
-(define-predicate Statement? Statement)
-
-
-(: statements (InstructionSequence -> (Listof Statement)))
-(define (statements s)
-  (reverse (statements-fold (inst cons Statement (Listof Statement))
-                            '() s)))
-
-
-(: statements-fold (All (A) ((Statement A -> A) A InstructionSequence -> A)))
-(define (statements-fold f acc seq)
-  (cond
-   [(symbol? seq)
-    (f seq acc)]
-   [(LinkedLabel? seq)
-    (f seq acc)]
-   [(UnlabeledStatement? seq)
-    (f seq acc)]
-   [(instruction-sequence-list? seq)
-    (foldl f acc (instruction-sequence-list-statements seq))]
-   [(instruction-sequence-chunks? seq)
-    (foldl (lambda: ([subseq : InstructionSequence] [acc : A])
-             (statements-fold f acc subseq))
-           acc
-           (instruction-sequence-chunks-chunks seq))]))
-
-            
-
-
-
-
-(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
-(define (append-instruction-sequences . seqs)
-  (append-seq-list seqs))
-
-(: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
-(define (append-2-sequences seq1 seq2)
-  (make-instruction-sequence-chunks (list seq1 seq2)))
-
-(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
-(define (append-seq-list seqs)
-  (if (null? seqs)
-      empty-instruction-sequence
-      (make-instruction-sequence-chunks seqs)))
-
-
-
-
-
-
-
-
-(define-predicate OpArg? OpArg)

whalesong/compiler/kernel-primitives.rkt

@@ -1,375 +0,0 @@
-#lang typed/racket/base
-
-(provide (all-defined-out))
-
-(require "arity-structs.rkt"
-         "lexical-structs.rkt"
-         "../type-helpers.rkt")
-
-
-
-
-(: kernel-module-name? (ModuleLocator -> Boolean))
-;; Produces true if the module is hardcoded.
-(define (kernel-module-name? name)
-
-  
-  (: kernel-locator? (ModuleLocator -> Boolean))
-  (define (kernel-locator? locator)
-    (or (and (eq? (ModuleLocator-name locator) '#%kernel)
-             (eq? (ModuleLocator-real-path locator) '#%kernel))
-        (eq? (ModuleLocator-name locator)
-             'whalesong/lang/kernel.rkt)
-        
-        ;; HACK HACK HACK
-        ;; This is for srcloc:
-        (eq? (ModuleLocator-name locator)
-             'collects/racket/private/kernstruct.rkt)))
-
-
-  (: paramz-locator? (ModuleLocator -> Boolean))
-  (define (paramz-locator? locator)
-    (or (and (eq? (ModuleLocator-name locator) '#%paramz)
-             (eq? (ModuleLocator-real-path locator) '#%paramz))))
-
-
-  (: kernel-module-locator? (ModuleLocator -> Boolean))
-  ;; Produces true if the given module locator should be treated as a primitive root one
-  ;; that is implemented by us.
-  (define (kernel-module-locator? locator)
-    (or (kernel-locator? locator)
-        (paramz-locator? locator)))
-
-  
-  (kernel-module-locator? name))
-
-
-
-;; Given a kernel-labeled ModuleVariable, returns the kernel name for it.
-(: kernel-module-variable->primitive-name (ModuleVariable -> Symbol))
-(define (kernel-module-variable->primitive-name a-modvar)
-  ;; FIXME: remap if the module is something else like whalesong/unsafe/ops
-
-  (ModuleVariable-name a-modvar))
-
-
-
-
-
-
-
-
-
-
-(define-type OperandDomain (U 'number
-                              'string
-                              'vector
-                              'box
-                              'list
-                              'pair
-                              'caarpair
-                              'any))
-
-
-;; The following are primitives that the compiler knows about:
-(define-type KernelPrimitiveName (U '+
-                                    '-
-                                    '*
-                                    '/
-                                    'zero?
-                                    'add1
-                                    'sub1
-				    'abs
-                                    '<
-                                    '<=
-                                    '=
-                                    '>
-                                    '>=
-                                    'cons
-                                    'car
-                                    'cdr
-
-                                    
-                                    'caar
-                                    'cdar
-                                    'cadr
-                                    'cddr
-                                    'caaar
-                                    'cdaar
-                                    'cadar
-                                    'cddar
-                                    'caadr
-                                    'cdadr
-                                    'caddr
-                                    'cdddr
-                                    'caaaar
-                                    'cdaaar
-                                    'cadaar
-                                    'cddaar
-                                    'caadar
-                                    'cdadar
-                                    'caddar
-                                    'cdddar
-                                    'caaadr
-                                    'cdaadr
-                                    'cadadr
-                                    'cddadr
-                                    'caaddr
-                                    'cdaddr
-                                    'cadddr
-                                    'cddddr
-
-                                    
-				    'list
-                                    'list?
-                                    'list*
-                                    'list->vector
-                                    'vector->list
-                                    'vector
-                                    'vector-length
-                                    'vector-ref
-                                    'vector-set!
-                                    'make-vector
-                                    'equal?
-                                    'member
-                                    'memq
-                                    'memv
-                                    'memf
-                                    'append
-                                    'reverse
-                                    'length
-				    'pair?
-                                    'null?
-                                    'not
-                                    'eq?
-                                    'eqv?
-				    'remainder
-				    'display
-				    'newline
-				    'call/cc
-				    'box
-				    'unbox
-				    'set-box!
-				    'string-append
-				    'current-continuation-marks
-				    'continuation-mark-set->list
-				    'values
-				    'call-with-values
-                                    'apply
-                                    
-
-                                    'for-each
-                                    'current-print
-
-                                    'make-struct-type
-                                    'current-inspector
-                                    'make-struct-field-accessor
-                                    'make-struct-field-mutator
-                                    
-                                    'gensym
-                                    'srcloc
-                                    'make-srcloc
-                                    'srcloc-source
-                                    'srcloc-line
-                                    'srcloc-column
-                                    'srcloc-position
-                                    'srcloc-span
-
-				    'error
-                                    'raise-type-error
-                                    'raise-mismatch-error
-                                    'struct:exn:fail
-                                    'prop:exn:srclocs
-                                    'make-exn
-                                    'make-exn:fail
-                                    'make-exn:fail:contract
-                                    'make-exn:fail:contract:arity
-                                    'make-exn:fail:contract:variable
-                                    'make-exn:fail:contract:divide-by-zero
-
-                                    'exn:fail?
-                                    'exn:fail:contract?
-                                    'exn:fail:contract:arity?
-                                    
-                                    'exn-message
-                                    'exn-continuation-marks
-
-                                    'hash?
-                                    'hash-equal?
-                                    'hash-eq?
-                                    'hash-eqv?
-                                    'hash
-                                    'hasheqv
-                                    'hasheq
-                                    'make-hash
-                                    'make-hasheqv
-                                    'make-hasheq
-                                    'make-immutable-hash
-                                    'make-immutable-hasheqv
-                                    'make-immutable-hasheq
-                                    'hash-copy
-                                    'hash-ref
-                                    'hash-has-key?
-                                    'hash-set!
-                                    'hash-set
-                                    'hash-remove!
-                                    'hash-remove
-                                    'equal-hash-code
-                                    'hash-count
-                                    'hash-keys
-                                    'hash-values
-                                    
-                                    'string-copy
-
-                                    'unsafe-car
-                                    'unsafe-cdr
-
-                                    'continuation-prompt-available?
-                                    'abort-current-continuation
-                                    'call-with-continuation-prompt
-                                    ))
-(define-predicate KernelPrimitiveName? KernelPrimitiveName)
-
-
-;; These are the primitives that we know how to inline.
-(define-type KernelPrimitiveName/Inline (U '+
-                                           '-
-                                           '*
-                                           '/
-                                           'zero?
-                                           'add1
-                                           'sub1
-                                           '<
-                                           '<=
-                                           '=
-                                           '>
-                                           '>=
-                                           'cons
-                                           'car
-                                           'caar
-                                           'cdr
-                                           'list
-                                           'list?
-                                           'pair?
-                                           'null?
-                                           'not
-                                           'eq?
-                                           'vector-ref
-                                           'vector-set!
-                                           ))
-
-(ensure-type-subsetof KernelPrimitiveName/Inline KernelPrimitiveName)
-
-
-(define-predicate KernelPrimitiveName/Inline? KernelPrimitiveName/Inline)
-
-(define-struct: IncorrectArity ([expected : Arity]))
-
-
-(: kernel-primitive-expected-operand-types (KernelPrimitiveName/Inline Natural -> (U (Listof OperandDomain)
-                                                                                     IncorrectArity)))
-;; Given a primitive and the number of arguments, produces the list of expected domains.
-;; TODO: do something more polymorphic.
-(define (kernel-primitive-expected-operand-types prim arity)
-  (cond
-    [(eq? prim '+)
-     (build-list arity (lambda (i) 'number))]
-
-    [(eq? prim '-)
-     (cond [(> arity 0)
-            (build-list arity (lambda (i) 'number))]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 1))])]
-
-    [(eq? prim '*)
-     (build-list arity (lambda (i) 'number))]
-
-    [(eq? prim '/)
-     (cond [(> arity 0)
-            (build-list arity (lambda (i) 'number))]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 1))])]
-
-    [(eq? prim 'zero?)
-     (cond [(= arity 1)
-            (list 'number)]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 1))])]
-
-    [(eq? prim 'add1)
-     (cond [(= arity 1)
-            (list 'number)]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 1))])]
-    
-    [(eq? prim 'sub1)
-     (cond [(= arity 1)
-            (list 'number)]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 1))])]
-                           
-    [(eq? prim '<)
-     (cond [(>= arity 2)
-            (build-list arity (lambda (i) 'number))]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 2))])]
-    
-    [(eq? prim '<=)
-     (cond [(>= arity 2)
-            (build-list arity (lambda (i) 'number))]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 2))])]
-    
-    [(eq? prim '=)
-     (cond [(>= arity 2)
-            (build-list arity (lambda (i) 'number))]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 2))])]
-    
-    [(eq? prim '>)
-     (cond [(>= arity 2)
-            (build-list arity (lambda (i) 'number))]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 2))])]
-    
-    [(eq? prim '>=)
-     (cond [(>= arity 2)
-            (build-list arity (lambda (i) 'number))]
-           [else
-            (make-IncorrectArity (make-ArityAtLeast 2))])]
-
-    [(eq? prim 'cons)
-     (list 'any 'any)]
-
-    [(eq? prim 'car)
-     (list 'pair)]
-
-    [(eq? prim 'caar)
-     (list 'caarpair)]
-    
-    [(eq? prim 'cdr)
-     (list 'pair)]
-    
-    [(eq? prim 'list)
-     (build-list arity (lambda (i) 'any))]
-
-    [(eq? prim 'list?)
-     (list 'any)]
-
-    [(eq? prim 'pair?)
-     (list 'any)]
-
-    [(eq? prim 'null?)
-     (list 'any)]
-
-    [(eq? prim 'not)
-     (list 'any)]
-
-    [(eq? prim 'eq?)
-     (list 'any 'any)]
-
-    [(eq? prim 'vector-ref)
-     (list 'vector 'number)]
-
-    [(eq? prim 'vector-set!)
-     (list 'vector 'number 'any)]))

whalesong/compiler/optimize-il.rkt

@@ -1,453 +0,0 @@
-#lang typed/racket/base
-(require "expression-structs.rkt"
-         "il-structs.rkt"
-         "lexical-structs.rkt"
-         (prefix-in ufind: "../union-find.rkt")
-         racket/list)
-(require/typed "../logger.rkt"
-               [log-debug (String -> Void)])
-(provide optimize-il)
-
-;; perform optimizations on the intermediate language.
-;;
-
-
-
-(: optimize-il ((Listof Statement) -> (Listof Statement)))
-(define (optimize-il statements)
-  ;; For now, replace pairs of PushEnvironment / AssignImmediate(0, ...)
-  ;; We should do some more optimizations here, like peephole...
-  (let* ([statements (filter not-no-op? statements)]
-         [statements (pairwise-reductions statements)]
-         [statements (flatten-adjacent-labels statements)])
-    statements))
-
-
-
-
-(: flatten-adjacent-labels ((Listof Statement) -> (Listof Statement)))
-;; Squash adjacent labels together.
-(define (flatten-adjacent-labels statements)
-  (cond
-   [(empty? statements)
-    empty]
-   [else
-
-    ;; The first pass through will collect adjacent labels and equate them.
-    (define a-forest (ufind:new-forest))
-    (let: loop : 'ok ([stmts : (Listof Statement) (rest statements)]
-                      [last-stmt : Statement (first statements)])
-      (cond
-       [(empty? stmts)
-        'ok]
-       [else
-        (define next-stmt (first stmts))
-        (cond
-         [(and (symbol? last-stmt) (symbol? next-stmt))
-          (log-debug (format "merging label ~a and ~a" last-stmt next-stmt))
-          (ufind:union-set a-forest last-stmt next-stmt)
-          (loop (rest stmts) next-stmt)]
-         
-         ;; If there's a label, immediately followed by a direct Goto jump,
-         ;; just equate the label and the jump.
-         [(and (symbol? last-stmt) (Goto? next-stmt))
-          (define goto-target (Goto-target next-stmt))
-          (cond
-            [(Label? goto-target)
-             (log-debug (format "merging label ~a and ~a" last-stmt (Label-name goto-target)))
-             (ufind:union-set a-forest last-stmt (Label-name goto-target))
-             (loop (rest stmts) next-stmt)]
-            [else
-             (loop (rest stmts) next-stmt)])]
-               
-         [else
-          (loop (rest stmts) next-stmt)])]))
-
-    
-    (: ref (Symbol -> Symbol))
-    (define (ref a-label)
-      (ufind:find-set a-forest a-label))
-
-    
-    (: rewrite-target (Target -> Target))
-    (define (rewrite-target target)
-      target)
-
-    (: rewrite-oparg (OpArg -> OpArg))
-    (define (rewrite-oparg oparg)
-      (cond
-       [(Const? oparg)
-        oparg]
-       [(Label? oparg)
-        (make-Label (ref (Label-name oparg)))]
-       [(Reg? oparg)
-        oparg]
-       [(EnvLexicalReference? oparg)
-        oparg]
-       [(EnvPrefixReference? oparg)
-        oparg]
-       [(EnvWholePrefixReference? oparg)
-        oparg]
-       [(SubtractArg? oparg)
-        oparg]
-       [(ControlStackLabel? oparg)
-        oparg]
-       [(ControlStackLabel/MultipleValueReturn? oparg)
-        oparg]
-       [(ControlFrameTemporary? oparg)
-        oparg]
-       [(CompiledProcedureEntry? oparg)
-        oparg]
-       [(CompiledProcedureClosureReference? oparg)
-        oparg]
-       [(ModuleEntry? oparg)
-        oparg]
-       [(ModulePredicate? oparg)
-        oparg]
-       [(PrimitiveKernelValue? oparg)
-        oparg]
-       [(VariableReference? oparg)
-        oparg]))
-
-
-    (: rewrite-primop (PrimitiveOperator -> PrimitiveOperator))
-    (define (rewrite-primop op)
-      (cond
-       [(GetCompiledProcedureEntry? op)
-        op]
-       [(MakeCompiledProcedure? op)
-        (make-MakeCompiledProcedure (ref (MakeCompiledProcedure-label op))
-                                    (MakeCompiledProcedure-arity op)
-                                    (MakeCompiledProcedure-closed-vals op)
-                                    (MakeCompiledProcedure-display-name op))]
-       
-       [(MakeCompiledProcedureShell? op)
-        (make-MakeCompiledProcedureShell (ref (MakeCompiledProcedureShell-label op))
-                                         (MakeCompiledProcedureShell-arity op)
-                                         (MakeCompiledProcedureShell-display-name op))]
-       
-       
-       [(MakeBoxedEnvironmentValue? op)
-        op]
-       
-       [(CaptureEnvironment? op)
-        op]
-       
-       [(CaptureControl? op)
-        op]
-       
-       [(CallKernelPrimitiveProcedure? op)
-        op]
-       
-       [(ApplyPrimitiveProcedure? op)
-        op]
-
-       [(ModuleVariable? op)
-        op]
-       
-       [(PrimitivesReference? op)
-        op]
-       
-       [(GlobalsReference? op)
-        op]))
-
-
-    (: rewrite-primcmd (PrimitiveCommand -> PrimitiveCommand))
-    (define (rewrite-primcmd cmd)
-      (cond
-       [(InstallModuleEntry!? cmd)
-        (make-InstallModuleEntry! (InstallModuleEntry!-name cmd)
-                                  (InstallModuleEntry!-path cmd)
-                                  (ref (InstallModuleEntry!-entry-point cmd)))]
-       [else
-        cmd]))
-    
-
-    (: rewrite-primtest (PrimitiveTest -> PrimitiveTest))
-    (define (rewrite-primtest test)
-      test)
-
-
-    
-    ;; The second pass will then rewrite references of labels.
-    (let: loop : (Listof Statement) ([stmts : (Listof Statement) statements])
-      (cond
-       [(empty? stmts)
-        empty]
-       [else
-        (define a-stmt (first stmts))
-        (cond
-         [(symbol? a-stmt)
-          (cond
-           [(eq? (ref a-stmt) a-stmt)
-            (cons (ref a-stmt) (loop (rest stmts)))]
-           [else
-            (loop (rest stmts))])]
-
-         [(LinkedLabel? a-stmt)
-          (cons (make-LinkedLabel (LinkedLabel-label a-stmt)
-                                  (ref (LinkedLabel-linked-to a-stmt)))
-                (loop (rest stmts)))]
-         
-         [(DebugPrint? a-stmt)
-          (cons a-stmt (loop (rest stmts)))
-          #;(loop (rest stmts))
-          ]
-
-         [(Comment? a-stmt)
-          ;(loop (rest stmts))
-          (cons a-stmt (loop (rest stmts)))
-          ]
-
-         [(MarkEntryPoint? a-stmt)
-          (cons a-stmt (loop (rest stmts)))]
-         
-         [(AssignImmediate? a-stmt)
-          (cons (make-AssignImmediate (rewrite-target (AssignImmediate-target a-stmt))
-                                               (rewrite-oparg (AssignImmediate-value a-stmt)))
-                (loop (rest stmts)))]
-
-         [(AssignPrimOp? a-stmt)
-          (cons (make-AssignPrimOp (rewrite-target (AssignPrimOp-target a-stmt))
-                                            (rewrite-primop (AssignPrimOp-op a-stmt)))
-                (loop (rest stmts)))]
-
-         [(Perform? a-stmt)
-          (cons (make-Perform (rewrite-primcmd (Perform-op a-stmt)))
-                (loop (rest stmts)))]
-         
-         [(PopEnvironment? a-stmt)
-          (cons (make-PopEnvironment (rewrite-oparg (PopEnvironment-n a-stmt))
-                                     (rewrite-oparg (PopEnvironment-skip a-stmt)))
-                (loop (rest stmts)))]
-
-         [(PushEnvironment? a-stmt)
-          (cons a-stmt (loop (rest stmts)))]
-         
-         [(PushImmediateOntoEnvironment? a-stmt)
-          (cons (make-PushImmediateOntoEnvironment (rewrite-oparg (PushImmediateOntoEnvironment-value a-stmt))
-                                                   (PushImmediateOntoEnvironment-box? a-stmt))
-                (loop (rest stmts)))]
-         
-         [(PushControlFrame/Generic? a-stmt)
-          (cons a-stmt (loop (rest stmts)))]
-
-         [(PushControlFrame/Call? a-stmt)
-          (define a-label (PushControlFrame/Call-label a-stmt))
-          (cons (make-PushControlFrame/Call
-                 (make-LinkedLabel (LinkedLabel-label a-label)
-                                   (ref (LinkedLabel-linked-to a-label))))
-                (loop (rest stmts)))]
-         
-         [(PushControlFrame/Prompt? a-stmt)
-          (define a-label (PushControlFrame/Prompt-label a-stmt))
-          (cons (make-PushControlFrame/Prompt (let ([tag (PushControlFrame/Prompt-tag a-stmt)])
-                                                (if (DefaultContinuationPromptTag? tag)
-                                                    tag
-                                                    (rewrite-oparg tag)))
-                                              (make-LinkedLabel (LinkedLabel-label a-label)
-                                                                (ref (LinkedLabel-linked-to a-label))))
-                (loop (rest stmts)))]
-         
-         [(PopControlFrame? a-stmt)
-          (cons a-stmt (loop (rest stmts)))]
-
-         [(Goto? a-stmt)
-          (define target (Goto-target a-stmt))
-          (cond
-           [(Label? target)
-            (cons (make-Goto (make-Label (ref (Label-name target))))
-                  (loop (rest stmts)))]
-           [else
-            (cons a-stmt (loop (rest stmts)))])]
-
-
-         [(TestAndJump? a-stmt)
-          (cons (make-TestAndJump (rewrite-primtest (TestAndJump-op a-stmt))
-                                           (ref (TestAndJump-label a-stmt)))
-                (loop (rest stmts)))])]))]))
-    
-
-    
-
-
-(: pairwise-reductions ((Listof Statement) -> (Listof Statement)))
-(define (pairwise-reductions statements)
-  (let loop ([statements statements])
-      (cond
-       [(empty? statements)
-        empty]
-       [else
-        (let ([first-stmt (first statements)])
-          (: default (-> (Listof Statement)))
-          (define (default)
-            (cons first-stmt (loop (rest statements))))
-          (cond
-           [(empty? (rest statements))
-            (default)]
-           [else
-            (let ([second-stmt (second statements)])
-              (cond
-               
-               ;; A PushEnvironment followed by a direct AssignImmediate can be reduced to a single
-               ;; instruction.
-               [(and (PushEnvironment? first-stmt)
-                     (equal? first-stmt (make-PushEnvironment 1 #f))
-                     (AssignImmediate? second-stmt))
-                (let ([target (AssignImmediate-target second-stmt)])
-                  (cond
-                   [(equal? target (make-EnvLexicalReference 0 #f))
-                    (loop (cons (make-PushImmediateOntoEnvironment 
-                                 (adjust-oparg-depth 
-                                  (AssignImmediate-value second-stmt) -1)
-                                 #f)
-                                (rest (rest statements))))]
-                   [else
-                    (default)]))]
-
-               ;; Adjacent PopEnvironments with constants can be reduced to single ones
-               [(and (PopEnvironment? first-stmt)
-                     (PopEnvironment? second-stmt))
-                (let ([first-n (PopEnvironment-n first-stmt)]
-                      [second-n (PopEnvironment-n second-stmt)]
-                      [first-skip (PopEnvironment-skip first-stmt)]
-                      [second-skip (PopEnvironment-skip second-stmt)])
-                  (cond [(and (Const? first-n) (Const? second-n) (Const? first-skip) (Const? second-skip))
-                         (let ([first-n-val (Const-const first-n)]
-                               [second-n-val (Const-const second-n)]
-                               [first-skip-val (Const-const first-skip)]
-                               [second-skip-val (Const-const second-skip)])
-                           (cond
-                            [(and (number? first-n-val)
-                                  (number? second-n-val)
-                                  (number? first-skip-val) (= first-skip-val 0)
-                                  (number? second-skip-val) (= second-skip-val 0))
-                             (loop (cons (make-PopEnvironment (make-Const (+ first-n-val second-n-val))
-                                                              (make-Const 0))
-                                         (rest (rest statements))))]
-                            [else
-                             (default)]))]
-                         [else
-                          (default)]))]
-
-               [else
-                (default)]))]))])))
-
-
-(: not-no-op? (Statement -> Boolean))
-(define (not-no-op? stmt) (not (no-op? stmt)))
-
-
-(: no-op? (Statement -> Boolean))
-;; Produces true if the statement should have no effect.
-(define (no-op? stmt)
-  (cond
-    [(symbol? stmt)
-     #f]
-    
-    [(LinkedLabel? stmt)
-     #f]
-    
-    [(DebugPrint? stmt)
-     #f
-     #;#t]
-    
-    [(MarkEntryPoint? stmt)
-     #f]
-    
-    [(AssignImmediate? stmt)
-     (equal? (AssignImmediate-target stmt)
-             (AssignImmediate-value stmt))]
-
-    [(AssignPrimOp? stmt)
-     #f]
-    
-    [(Perform? stmt)
-     #f]
-    
-    [(Goto? stmt)
-     #f]
-    
-    [(TestAndJump? stmt)
-     #f]
-    
-    [(PopEnvironment? stmt)
-     (and (Const? (PopEnvironment-n stmt))
-          (equal? (PopEnvironment-n stmt) 
-                  (make-Const 0)))]
-     
-    [(PushEnvironment? stmt)
-     (= (PushEnvironment-n stmt) 0)]
-    
-    [(PushImmediateOntoEnvironment? stmt)
-     #f]
-
-    [(PushControlFrame/Generic? stmt)
-     #f]
-    
-    [(PushControlFrame/Call? stmt)
-     #f]
-    
-    [(PushControlFrame/Prompt? stmt)
-     #f]
-    
-    [(PopControlFrame? stmt)
-     #f]
-    [(Comment? stmt)
-     #f]))
-
-
-
-
-
-
-(: adjust-oparg-depth (OpArg Integer -> OpArg))
-(define (adjust-oparg-depth oparg n)
-  (cond
-    [(Const? oparg) oparg]
-    [(Label? oparg) oparg]
-    [(Reg? oparg) oparg]
-    [(EnvLexicalReference? oparg)
-     (make-EnvLexicalReference (ensure-natural (+ n (EnvLexicalReference-depth oparg)))
-                               (EnvLexicalReference-unbox? oparg))]
-    [(EnvPrefixReference? oparg)
-     (make-EnvPrefixReference (ensure-natural (+ n (EnvPrefixReference-depth oparg)))
-                              (EnvPrefixReference-pos oparg)
-                              (EnvPrefixReference-modvar? oparg))]
-    [(EnvWholePrefixReference? oparg)
-     (make-EnvWholePrefixReference (ensure-natural (+ n (EnvWholePrefixReference-depth oparg))))]
-    [(SubtractArg? oparg)
-     (make-SubtractArg (adjust-oparg-depth (SubtractArg-lhs oparg) n)
-                       (adjust-oparg-depth (SubtractArg-rhs oparg) n))]
-    [(ControlStackLabel? oparg)
-     oparg]
-    [(ControlStackLabel/MultipleValueReturn? oparg)
-     oparg]
-    [(ControlFrameTemporary? oparg)
-     oparg]
-    [(CompiledProcedureEntry? oparg)
-     (make-CompiledProcedureEntry (adjust-oparg-depth (CompiledProcedureEntry-proc oparg) n))]
-    [(CompiledProcedureClosureReference? oparg)
-     (make-CompiledProcedureClosureReference 
-      (adjust-oparg-depth (CompiledProcedureClosureReference-proc oparg) n)
-      (CompiledProcedureClosureReference-n oparg))]
-    [(PrimitiveKernelValue? oparg)
-     oparg]
-    [(ModuleEntry? oparg)
-     oparg]
-    [(ModulePredicate? oparg)
-     oparg]
-    [(VariableReference? oparg)
-     (let ([t (VariableReference-toplevel oparg)])
-       (make-VariableReference 
-        (make-ToplevelRef (ensure-natural (+ n (ToplevelRef-depth t)))
-                          (ToplevelRef-pos t)
-                          (ToplevelRef-constant? t)
-                          (ToplevelRef-check-defined? t))))]))
-
-
-(define-predicate natural? Natural)
-(define (ensure-natural x)
-  (if (natural? x)
-      x
-      (error 'ensure-natural)))

whalesong/cs019/cs019-pre-base.rkt

@@ -1,26 +0,0 @@
-#lang s-exp "../lang/base.rkt"
-
-
-(require (for-syntax "teach.rkt")
-         (for-syntax racket/base))
-
-;; FIXME: there's something wrong with the compiler: it's not picking
-;; up that teach-runtime is a dependency.
-(require "teach-runtime.rkt")
-
-(provide cs019-lambda
-         cs019-define
-         cs019-when
-         cs019-unless
-         cs019-set!
-         cs019-case
-         cs019-local
-         cs019-dots)
-
-(define-syntax cs019-define advanced-define/proc)
-(define-syntax cs019-lambda advanced-lambda/proc)
-(define-syntaxes (cs019-when cs019-unless) (values advanced-when/proc advanced-unless/proc))
-(define-syntax cs019-set! advanced-set!/proc)
-(define-syntax cs019-case advanced-case/proc)
-(define-syntax cs019-local intermediate-local/proc)
-(define-syntax cs019-dots beginner-dots/proc)

whalesong/cs019/cs019.rkt

@@ -1,441 +0,0 @@
-#lang s-exp "../lang/base.rkt"
-
-;; Like the big whalesong language, but with additional ASL restrictions.
-
-(current-print-mode "constructor")
-
-
-(require (for-syntax racket/base syntax/stx racket/match))
-
-
-(require "cs019-pre-base.rkt")
-
-
-(provide (rename-out [cs019-lambda lambda]
-                     [cs019-define define]
-                     [cs019-when when]
-                     [cs019-unless unless]
-                     [cs019-case case]
-                     [cs019-local local]
-
-                     [cs019-dots ..]
-                     [cs019-dots ...]
-                     [cs019-dots ....]
-                     [cs019-dots .....]
-                     [cs019-dots ......]
-                     ))
-
-(define-syntax λ (make-rename-transformer #'cs019-lambda))
-
-
-(require "private/sigs-patched.rkt")
-(provide [all-from-out "private/sigs-patched.rkt"])
-(provide Image$)
-(define Image$ (Sig: image?))
-
-
-(require "../lang/posn.rkt")
-(provide [all-from-out "../lang/posn.rkt"])
-(define Posn$ (Sig: posn?))
-(provide Posn$)
-
-
-
-
-(require (prefix-in whalesong: "../lang/whalesong.rkt"))
-(provide (except-out (filtered-out
-                      (lambda (name)
-                        (match name
-                          [(regexp #rx"^whalesong:(.+)$" (list _ real-name))
-                           real-name]
-                          [else
-                           #f]))
-                      (except-out (all-from-out "../lang/whalesong.rkt")
-                                  
-                                  whalesong:if
-                                  whalesong:cond
-                                  whalesong:case
-                                  whalesong:member
-                                  whalesong:memq
-                                  whalesong:define
-                                  whalesong:lambda
-                                  whalesong:unless
-                                  whalesong:when
-                                  whalesong:local
-
-
-                                  whalesong:first
-                                  whalesong:rest
-                                  whalesong:second
-                                  whalesong:third
-                                  whalesong:fourth
-                                  whalesong:fifth
-                                  whalesong:sixth
-                                  whalesong:seventh
-                                  whalesong:eighth
-                                  whalesong:ninth
-                                  )))
-
-         string-ith
-         replicate
-         int->string
-         string->int
-         explode
-         implode
-         string-numeric?
-         string-alphabetic?
-         string-whitespace?
-         string-upper-case?
-         string-lower-case?)
-
-(require "lists.rkt")
-(provide (all-from-out "lists.rkt"))
-
-(require "../image.rkt")
-(provide (all-from-out "../image.rkt"))
-
-(require "../web-world.rkt")
-(provide (all-from-out "../web-world.rkt"))
-
-(define View$ (Sig: view?))
-(provide View$)
-
-(define Event$ (Sig: event?))
-(provide Event$)
-
-
-
-(require "../resource.rkt")
-(provide (all-from-out "../resource.rkt"))
-
-
-(define Resource$ (Sig: resource?))
-(provide Resource$)
-
-
-
-
-(define-for-syntax (local-expand-for-error stx ctx stops)
-  ;; This function should only be called in an 'expression
-  ;;  context. In case we mess up, avoid bogus error messages.
-  (when (memq (syntax-local-context) '(expression))
-    (local-expand stx ctx stops)))
-
-
-
-    
-
-
-;; Raise a syntax error:
-(define-for-syntax (teach-syntax-error form stx detail msg . args)
-  (let ([form (if (eq? form '|function call|)
-                  form
-                  #f)] ; extract name from stx
-        [msg (apply format msg args)])
-    (if detail
-        (raise-syntax-error form msg stx detail)
-        (raise-syntax-error form msg stx))))
-
-(define-for-syntax (teach-syntax-error* form stx details msg . args)
-  (let ([exn (with-handlers ([exn:fail:syntax?
-                              (lambda (x) x)])
-               (apply teach-syntax-error form stx #f msg args))])
-    (raise
-     (make-exn:fail:syntax
-      (exn-message exn)
-      (exn-continuation-marks exn)
-      details))))
-
-
-
-;; The syntax error when a form's name doesn't follow a "("
-(define-for-syntax (bad-use-error name stx)
-  (teach-syntax-error
-   name
-   stx
-   #f
-   "found a use of `~a' that does not follow an open parenthesis"
-   name))
-
-(define-for-syntax (something-else v)
-  (let ([v (syntax-e v)])
-    (cond
-      [(number? v) "a number"]
-      [(string? v) "a string"]
-      [else "something else"])))
-
-;; verify-boolean is inserted to check for boolean results:
-(define-for-syntax (verify-boolean b where)
-  (with-syntax ([b b]
-                [where where])
-    (quasisyntax/loc #'b
-      (let ([bv b])
-        (if (or (eq? bv #t) (eq? bv #f))
-            bv
-            #,(syntax/loc #'b
-                (whalesong:#%app raise
-                                 (make-exn:fail:contract
-                                  (format "~a: question result is not true or false: ~e" 'where bv)
-                                  (current-continuation-marks)))))))))
-
-
-(define-syntax (-cond stx)
-  (syntax-case stx ()
-    [(_)
-     (teach-syntax-error
-      'cond
-      stx
-      #f
-      "expected a question--answer clause after `cond', but nothing's there")]
-    [(_ clause ...)
-     (let* ([clauses (syntax->list (syntax (clause ...)))]
-            [check-preceding-exprs
-             (lambda (stop-before)
-               (let/ec k
-                 (for-each (lambda (clause)
-                             (if (eq? clause stop-before)
-                                 (k #t)
-                                 (syntax-case clause ()
-                                   [(question answer)
-                                    (begin
-                                      (unless (and (identifier? (syntax question))
-                                                   (free-identifier=? (syntax question)
-                                                                      #'else))
-                                        (local-expand-for-error (syntax question) 'expression null))
-                                      (local-expand-for-error (syntax answer) 'expression null))])))
-                           clauses)))])
-       (let ([checked-clauses
-              (map
-               (lambda (clause)
-                 (syntax-case clause (else)
-                   [(else answer)
-                    (let ([lpos (memq clause clauses)])
-                      (when (not (null? (cdr lpos)))
-                        (teach-syntax-error
-                         'cond
-                         stx
-                         clause
-                         "found an `else' clause that isn't the last clause ~
-                                    in its `cond' expression"))
-                      (with-syntax ([new-test (syntax #t) ])
-                        (syntax/loc clause (new-test answer))))]
-                   [(question answer)
-                    (with-syntax ([verified 
-                                   (verify-boolean #'question 'cond)])
-                      (syntax/loc clause (verified answer)))]
-                   [()
-                    (check-preceding-exprs clause)
-                    (teach-syntax-error
-                     'cond
-                     stx
-                     clause
-                     "expected a question--answer clause, but found an empty clause")]
-                   [(question?)
-                    (check-preceding-exprs clause)
-                    (teach-syntax-error
-                     'cond
-                     stx
-                     clause
-                     "expected a clause with a question and answer, but found a clause with only one part")]
-                   [(question? answer? ...)
-                    (check-preceding-exprs clause)
-                    (let ([parts (syntax->list clause)])
-                      ;; to ensure the illusion of left-to-right checking, make sure 
-                      ;; the question and first answer (if any) are ok:
-                      (unless (and (identifier? (car parts))
-                                   (free-identifier=? (car parts) #'else))
-                        (local-expand-for-error (car parts) 'expression null))
-                      (unless (null? (cdr parts))
-                        (local-expand-for-error (cadr parts) 'expression null))
-                      ;; question and answer (if any) are ok, raise a count-based exception:
-                      (teach-syntax-error*
-                       'cond
-                       stx
-                       parts
-                       "expected a clause with one question and one answer, but found a clause with ~a parts"
-                       (length parts)))]
-                   [_else
-                    (teach-syntax-error
-                     'cond
-                     stx
-                     clause
-                     "expected a question--answer clause, but found ~a"
-                     (something-else clause))]))
-               clauses)])
-         ;; Add `else' clause for error (always):
-         (let ([clauses (append checked-clauses 
-                                (list 
-                                 (with-syntax ([error-call (syntax/loc stx (whalesong:#%app raise (make-exn:fail:contract "cond: all question results were false" (current-continuation-marks))))])
-                                   (syntax [else error-call]))))])
-           (with-syntax ([clauses clauses])
-             (syntax/loc stx (cond . clauses))))))]
-    [_else (bad-use-error 'cond stx)]))
-
-(provide (rename-out [-cond cond]))
-
-
-
-
-
-
-(define-syntax (-if stx)
-  (syntax-case stx ()
-    [(_ test then else)
-     (with-syntax ([new-test (verify-boolean #'test 'if)])
-       (syntax/loc stx
-         (if new-test
-             then
-             else)))]
-    [(_ . rest)
-     (let ([n (length (syntax->list (syntax rest)))])
-       (teach-syntax-error
-        'if
-        stx
-        #f
-        "expected one question expression and two answer expressions, but found ~a expression~a"
-        (if (zero? n) "no" n)
-        (if (= n 1) "" "s")))]
-    [_else (bad-use-error 'if stx)]))
-
-(provide (rename-out [-if if]))
-
-
-
-
-
-
-
-(define 1-LET "1-letter string")
-(define 1-LETTER (format "~a" 1-LET))
-(define 1-LETTER* (format "list of ~as" 1-LET))
-(define NAT "natural number")
-
-;; Symbol Any -> Boolean 
-;; is this a 1-letter string?
-(define (1-letter? tag s)
-  (unless (string? s) (err tag "expected a ~a, but received a string: ~e" 1-LETTER s))
-  (= (string-length s) 1))
-
-;; Symbol Any -> Boolean 
-;; is s a list of 1-letter strings
-;; effect: not a list, not a list of strings 
-(define (1-letter*? tag s)
-  (unless (list? s) (err tag "expected a ~a, but received: ~e" 1-LETTER* s))
-  (for-each 
-   (lambda (c) 
-     (unless (string? c) (err tag "expected a ~a, but received: ~e" 1-LETTER* c)))
-   s)
-  (andmap (compose (lambda (x) (= x 1)) string-length) s))
-
-
-(define (err tag msg-format . args)
-  (raise 
-   (make-exn:fail:contract
-    (apply format (string-append (symbol->string tag) ": " msg-format) args)
-    (current-continuation-marks))))
-
-(define (a-or-an after)
-  (if (member (string-ref (format "~a" after) 0) '(#\a #\e #\i #\o #\u))
-      "an" "a"))
-
-(define cerr 
-  (case-lambda
-    [(tag check-result format-msg actual)
-     (unless check-result
-       (err tag (string-append "expected " (a-or-an format-msg) " " format-msg ", but received ~e") actual))]
-    [(tag check-result format-msg actual snd)
-     (unless check-result
-       (err tag (string-append "expected " (a-or-an format-msg) " " format-msg " for the ~a argument, but received ~e")
-            snd actual))]))
-
-(define string-ith
-  (lambda (s n)
-    (define f "exact integer in [0, length of the given string]")
-    (cerr 'string-ith (string? s) "string" s "first")
-    (cerr 'string-ith (and (number? n) (integer? n) (>= n 0)) NAT n "second")
-    (let ([l (string-length s)]) 
-      (cerr 'string-ith (< n l) f n "second"))
-    (string (string-ref s n))))
-
-
-
-(define replicate 
-  (lambda (n s1)
-    (cerr 'replicate (and (number? n) (exact-integer? n) (>= n 0)) NAT n)
-    (cerr 'replicate (string? s1) "string" s1)
-    (apply string-append (build-list n (lambda (i) s1)))))
-
-(define int->string 
-  (lambda (i) 
-    (cerr 'int->string 
-          (and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111)))
-          "exact integer in [0,55295] or [57344 1114111]"
-          i)
-    (string (integer->char i))))
-
-(define string->int 
-  (lambda (s) 
-    (cerr 'string->int (1-letter? 'string->int s) 1-LETTER s)
-    (char->integer (string-ref s 0))))
-
-
-(define explode 
-  (lambda (s)
-    (cerr 'explode (string? s) "string" s)
-    (map string (string->list s))))
-
-(define implode
-  (lambda (los)
-    (cerr 'implode (1-letter*? 'implode los) 1-LETTER* los)
-    (apply string-append los)))
-
-
-
-(define string-numeric? 
-  ;; is this: (number? (string->number s)) enough?
-  (lambda (s1)
-    (cerr 'string-numeric? (string? s1) "string" s1)
-    (andmap char-numeric? (string->list s1))))
-
-(define string-alphabetic? 
-  (lambda (s1)
-    (cerr 'string-alphabetic? (string? s1) "string" s1)
-    (andmap char-alphabetic? (string->list s1))))
-
-
-(define string-whitespace? 
-  (lambda (s)
-    (cerr 'string-upper-case? (string? s)  "string" s)
-    (andmap char-whitespace? (string->list s))))
-
-(define string-upper-case? 
-  (lambda (s)
-    (cerr 'string-upper-case? (string? s) "string" s)
-    (andmap char-upper-case? (string->list s))))
-
-
-(define string-lower-case? 
-  (lambda (s)
-    (cerr 'string-lower-case? (string? s) "string" s)
-    (andmap char-lower-case? (string->list s))))
-
-
-;; ASL's member returns booleans.
-(define (-member x L)
-  (cond
-    [(eq? (member x L) #f) #f]
-    [else #t]))
-
-
-;; as does memq
-(define (-memq x L)
-  (cond
-    [(eq? (memq x L) #f) #f]
-    [else #t]))
-
-
-
-(provide (rename-out [-member member]
-                     [-member member?]
-                     [-memq memq]))
-

whalesong/cs019/deviations.txt

@@ -1,143 +0,0 @@
-Misc
-===
-exit
-sleep
-delay
-promise
-force
-time
-identity
-state
-match
-Char
-name
-module-begin
-define-datatype
-recur
-
-
-Testing
-===
-check-range
-check-error
-check-within
-check-member-of
-check-property
-check-with
-equal~?
-cons-of
-=~
-
-Lists
-===
-caaar
-caadr
-cdar
-cddr
-cadar
-cdaar
-cdadr
-cddar
-cadddr
-caddr
-cdddr
-sort
-quicksort
-
-IO
-===
-with-output-to-file
-with-input-from-file
-with-output-from-string
-with-output-to-string
-read
-print
-pretty-print
-
-
-Hashes
-===
-hash-iterate-first
-hash-iterate-key
-hash-iterate-next
-hash-iterate-value
-hash-update
-hash-ref!
-hash-update!
-
-
-Images & Universe
-===
-register
-universe
-animate
-run-simulation
-run-movie
-LOCALHOST
-on-receive
-on-mouse
-on-new
-on-msg
-on-disconnect
-on-key
-on-release
-stop-with
-on-draw
-make-bundle
-iworld-name
-iworld?
-make-package
-package?
-bundle?
-mail?
-iworld=?
-make-mail
-iworld1
-iworld2
-iworld3
-sexp?
-launch-many-worlds
-mouse-event?
-record?
-bitmap
-key-event?
-key=?
-image=?
-pen
-pen-color
-pen-style
-pen-cap
-pen-join
-make-pen
-pen-width
-Key$
-color-list->bitmap
-pinhole-x
-pinhole-y
-center-pinhole
-put-pinthole
-clear-pinhole
-freeze
-save-image
-overlay/pinhole
-underlay/pinhole
-overlay/offset
-overlay/align/offset
-underlay/align/offset
-underlay/offset
-pen-cap?
-real-valued-posn?
-pen-join?
-pen-style?
-scene+curve
-triangle/asa
-triangle/sas
-triangle/aas
-triangle/ssa
-triangle/ass
-triangle/sss
-triangle/saa
-polygon
-empty-image
-add-curve
-to-string

whalesong/cs019/firstorder.rkt

@@ -1,23 +0,0 @@
-(module firstorder mzscheme
-
-  (provide make-first-order
-	   first-order->higher-order)
-
-  (define-values (struct:fo make-first-order fo? fo-get fo-set!)
-    (make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0))  
-
-  (define fo-proc-id (make-struct-field-accessor fo-get 1))
-
-  (define (first-order->higher-order id)
-    (let ([v (syntax-local-value id (lambda () #f))])
-      (if (or (fo? v)
-              (and (set!-transformer? v)
-                   (fo? (set!-transformer-procedure v))))
-          (syntax-property
-           (syntax-local-introduce 
-            (fo-proc-id (if (fo? v) v (set!-transformer-procedure v))))
-           'disappeared-use
-           (syntax-local-introduce id))
-	  id))))
-
-

whalesong/cs019/get-cs019-names.rkt

@@ -1,33 +0,0 @@
-#lang racket/base
-
-;; Grabs all the names exported by the real cs019 language, so we can
-;; compare and see what names are missing from our implementation.
-(require racket/set)
-
-(provide cs019-names
-         whalesong-cs019-names
-         missing-cs019-names)
-
-
-(define-namespace-anchor anchor)
-(define ns (namespace-anchor->namespace anchor))
-
-
-(require (prefix-in cs019: (planet cs019/cs019/cs019)))
-(define cs019-names 
-  (for/set ([name (namespace-mapped-symbols ns)]
-             #:when (regexp-match #rx"^cs019:" (symbol->string name)))
-    (string->symbol
-     (substring (symbol->string name) (string-length "cs019:")))))
-
-
-(require (prefix-in whalesong-cs019: "cs019.rkt"))
-(define whalesong-cs019-names 
-  (for/set ([name (namespace-mapped-symbols ns)]
-             #:when (regexp-match #rx"^whalesong-cs019:" (symbol->string name)))
-    (string->symbol
-     (substring (symbol->string name) (string-length "whalesong-cs019:")))))
-
-
-(define missing-cs019-names
-  (set-subtract cs019-names whalesong-cs019-names))

whalesong/cs019/info.rkt

@@ -1,4 +0,0 @@
-#lang setup/infotab
-(define compile-omit-paths '("get-cs019-names.rkt"))
-
-

whalesong/cs019/lang/reader.rkt

@@ -1,9 +0,0 @@
-#lang s-exp syntax/module-reader
-
-;; http://docs.racket-lang.org/planet/hash-lang-planet.html
-
-#:language (lambda (ip)
-	    `(file ,(path->string cs019.rkt)))
-
-(require racket/runtime-path)
-(define-runtime-path cs019.rkt "../cs019.rkt")

whalesong/cs019/lists.rkt

@@ -1,64 +0,0 @@
-#lang whalesong/base
-#|
-Why on earth are these here?
-Because first, etc. don't work on cyclic lists:
-(define web-colors
- (shared ([W (cons "white" G)]
-          [G (cons "grey" W)])
-   W))
-(first web-colors)
-fails with expected argument of type <list>.
-But car/cdr still do the trick per email from mflatt, 10/20/2011.
-
-So we suppress the built-in functions from lang/htdp-advanced
-and provide these instead.
-|#
-
-(require (for-syntax racket/base))
-
-(provide first second third fourth fifth sixth seventh eighth ninth
-         rest)
-
-
-(define (rest x)
-  (cond
-   [(pair? x)
-    (cdr x)]
-   [else
-    (raise-type-error 'rest
-                      "list with at least one element"
-                      x)]))
-
-(define-syntax (define-list-selectors stx)
-  (syntax-case stx ()
-    [(_ [(name ordinal) ...])
-     (with-syntax ([(offset ...)
-                    (build-list (length (syntax->list #'(name ...)))
-                                (lambda (i) i))])
-       #'(begin
-           (define (name p)
-             (pair-ref p offset 'name 'ordinal p))
-           ...))]))
-
-(define (pair-ref x offset name ordinal original)
-  (cond
-   [(pair? x)
-    (cond
-     [(= offset 0)
-      (car x)]
-     [else
-      (pair-ref (cdr x) (sub1 offset) name ordinal original)])]
-   [else
-    (raise-type-error name
-                      (format "list with ~a elements" ordinal)
-                      original)]))
-                                           
-(define-list-selectors [[first one]
-                        [second two]
-                        [third three]
-                        [fourth four]
-                        [fifth five]
-                        [sixth six]
-                        [seventh seven]
-                        [eighth eight]
-                        [ninth nine]])

whalesong/cs019/private/info.rkt

@@ -1,6 +0,0 @@
-#lang setup/infotab
-
-;; sigs is the original version of Shriram's signature library.  We'll
-;; be patching it anyway, so don't compile this source file.
-(define compile-omit-paths '("sigs.rkt"))
-

whalesong/cs019/private/sigs-patched.rkt

@@ -1,395 +0,0 @@
-#lang s-exp "../../lang/base.rkt"
-
-(require (only-in "../cs019-pre-base.rkt"
-                  [cs019-define asl:define] 
-                  [cs019-lambda asl:lambda]))
-(require [for-syntax syntax/struct]
-         [for-syntax racket])
-
-(provide define: lambda: define-struct: and: or: not:
-         (struct-out signature-violation))
-
-(define the-undefined-value (letrec ([x x]) x))
-
-(define-struct (signature-violation exn:fail) 
-  (srclocs)  ;; listof srcloc-vector
-  #:property prop:exn:srclocs
-  (lambda (violation)
-    (map (lambda (vec)
-           (apply srcloc (vector->list vec)))
-         (signature-violation-srclocs violation))))
-
-
-;; syntax-srcloc: syntax -> srcloc-vector
-(define-for-syntax (syntax-srcloc stx)
-  (vector (syntax-source stx)
-          (syntax-line stx)
-          (syntax-column stx)
-          (syntax-position stx)
-          (syntax-span stx)))
-
-
-(define-for-syntax (parse-sig stx)
-  (syntax-case stx (->)
-    [(A ... -> R)
-     (with-syntax ([(A ...) (map parse-sig (syntax->list #'(A ...)))]
-                   [R (parse-sig #'R)])
-       (syntax/loc stx
-         (proc: (A ... -> R))))]
-    [_ stx]))
-
-(define-for-syntax (parse-sigs stxs)
-  (map parse-sig (syntax->list stxs)))
-
-(define-syntax (define-struct: stx)
-  (syntax-case stx (:)
-    [(_ sn ([f : S] ...))
-     (with-syntax ([(names ...) 
-                    (map (lambda (i)
-                           (datum->syntax stx i))
-                         (map syntax->datum
-                              (build-struct-names #'sn
-                                                  (syntax->list #'(f ...)) 
-                                                  #f #f)))]
-                   [term-srcloc (syntax-srcloc stx)]
-                   [(S ...) (parse-sigs #'(S ...))])
-       (with-syntax ([(S-srcloc ...) (map syntax-srcloc (syntax->list #'(S ...)))]
-                     [sig-name (datum->syntax #'sn
-                                              (string->symbol
-                                               (string-append
-                                                (symbol->string
-                                                 (syntax->datum #'sn))
-                                                "$")))]
-                     [(cnstr pred get/set! ...)
-                      (syntax-case #'(names ...) ()
-                        [(_s:id constructor predicate? getters/setters! ...)
-                         #'(constructor predicate? getters/setters! ...)])])
-         (with-syntax ([(setters ...) (let loop ([g/s! (syntax->list #'(get/set! ...))])
-                                        (if (empty? g/s!) 
-                                            empty
-                                            (cons (second g/s!)
-                                                  (loop (rest (rest g/s!))))))])
-#|
-This expansion used to use 
-         #'(begin
-             (define-values (names ...)
-               (let ()
-                 (begin
-                   (define-struct sn (f ...) #:transparent #:mutable)
-                   (let ([cnstr 
-                          (lambda (f ...)
-                            (let ([wrapped-args ETC])
-                              (apply cnstr wrapped-args)))]
-                         [setters ETC]
-                         ...)
-                     (values names ...)))))
-        ETC.
-It does not because that fails with shared:
-(define-struct: foo ([n : Number$]))
-(shared ([f (make-foo A)]
-         [A 3])
-  f)
-produces (make-foo #<undefined>) rather than (make-foo 3).
-The version below, which mutates the setters, does not suffer from this.
-|#
-           #'(begin
-               (define-struct sn (f ...) #:transparent #:mutable)
-               (define dummy
-                 (set! cnstr
-                       (let ([prim-cnstr cnstr])
-                         (lambda (f ...)
-                           (let ([wrapped-args
-                                  (let loop ([sigs (list S ... )]
-                                             [args (list f ...)]
-                                             [sig-srclocs (list S-srcloc ...)]
-                                             [n 1])
-                                    (if (null? sigs)
-                                        '()
-                                        (cons (wrap (car sigs) 
-                                                    (car args)
-                                                    (car sig-srclocs))
-                                              (loop (cdr sigs) 
-                                                    (cdr args)
-                                                    (cdr sig-srclocs)
-                                                    (add1 n)))))])
-                             (apply prim-cnstr wrapped-args))))))
-               (define more-dummies
-                 (list
-                  (set! setters
-                        (let ([prim-setter setters])
-                          (lambda (struct-inst new-val)
-                            (prim-setter struct-inst (wrap S new-val S-srcloc)))))
-                  ...))
-               ;; This could be a define below, but it's a define-values
-               ;; due to a bug in ISL's local.  See users@racket-lang.org
-               ;; thread, 2011-09-03, "splicing into local".  Should not
-               ;; be necessary with next release.
-               (define-values (sig-name) 
-                 (first-order-sig pred term-srcloc))))))]))
-
-(define (raise-signature-violation msg srclocs)
-  (raise (signature-violation msg (current-continuation-marks) srclocs)))
-
-(define (not-sig-error srcloc)
-  (raise-signature-violation "not a valid signature" (list srcloc)))
-
-(define (wrap sig val srcloc)
-  (if (signature? sig)
-      (if (eq? val the-undefined-value)
-          val
-          ((signature-wrapper sig) val))
-      (not-sig-error srcloc)))
-
-(provide Number$ String$ Char$ Boolean$ Any$ Void$ Sig: Listof: Vectorof:)
-
-(define-struct signature (pred wrapper ho? srcloc))
-
-(define-syntax (Listof: stx)
-  (syntax-case stx ()
-    [(_ S)
-     (with-syntax ([S (parse-sig #'S)]
-                   [sig-srcloc (syntax-srcloc #'S)]
-                   [term-srcloc (syntax-srcloc stx)])
-       #'(let ([s S])
-           (if (signature? s)
-               (if (signature-ho? s)
-                   (make-signature list?
-                                   (lambda (v)
-                                     (map (lambda (e) (wrap s e sig-srcloc)) v))
-                                   #t
-                                   term-srcloc)
-                   (let ([pred (lambda (v)
-                                 (and (list? v)
-                                      (andmap (signature-pred s) v)))])
-                     (make-signature pred
-                                     (lambda (v)
-                                       (if (pred v)
-                                           v
-                                           (if (list? v)
-                                               (raise-signature-violation
-                                                (format "not an appropriate list: ~e" v)
-                                                (list sig-srcloc))
-                                               (raise-signature-violation
-                                                (format "not a list: ~e" v)
-                                                (list term-srcloc)))))
-                                     #f
-                                     term-srcloc)))
-               (not-sig-error sig-srcloc))))]))
-
-(define-syntax (Vectorof: stx)
-  (syntax-case stx ()
-    [(_ S)
-     (with-syntax ([S (parse-sig #'S)]
-                   [sig-srcloc (syntax-srcloc #'S)]
-                   [term-srcloc (syntax-srcloc stx)])
-       #'(let ([s S])
-           (if (signature? s)
-               (if (signature-ho? s)
-                   (make-signature vector?
-                                   (lambda (v)
-                                     (list->vector
-                                      (map (lambda (e) (wrap s e sig-srcloc))
-                                           (vector->list v))))
-                                   #t
-                                   term-srcloc)
-                   (let ([pred (lambda (v)
-                                 (and (vector? v)
-                                      (andmap (signature-pred s)
-                                              (vector->list v))))])
-                     (make-signature pred
-                                     (lambda (v)
-                                       (if (pred v)
-                                           v
-                                           (if (vector? v)
-                                               (raise-signature-violation
-                                                (format "not an appropriate vector: ~e" v)
-                                                (list sig-srcloc))
-                                               (raise-signature-violation
-                                                (format "not a vector: ~e" v)
-                                                (list term-srcloc)))))
-                                     #f
-                                     term-srcloc)))
-               (not-sig-error sig-srcloc))))]))
-
-(define (first-order-sig pred? term-srcloc)
-  (make-signature pred?
-                  (lambda (v)
-                    (if (pred? v)
-                        v
-                        (raise-signature-violation
-                         (format "value ~s failed the signature" v)
-                         (list term-srcloc))))
-                  #f
-                  term-srcloc))
-
-(define-syntax (Sig: stx)
-  (syntax-case stx ()
-    [(_ S)
-     (with-syntax ([Sp (parse-sig #'S)]
-                   [term-srcloc (syntax-srcloc stx)])
-       (if (eq? #'Sp #'S) ;; currently means S is NOT (... -> ...)
-           #'(first-order-sig S term-srcloc)
-           #'Sp))]))
-
-(define-syntax (Number$ stx)
-  (syntax-case stx (Number$)
-    [Number$
-     (with-syntax ([term-srcloc (syntax-srcloc stx)])
-       #'(first-order-sig number? term-srcloc))]))
-
-(define-syntax (String$ stx)
-  (syntax-case stx (String$)
-    [String$
-     (with-syntax ([term-srcloc (syntax-srcloc stx)])
-       #'(first-order-sig string? term-srcloc))]))
-
-(define-syntax (Char$ stx)
-  (syntax-case stx (char$)
-    [Char$
-     (with-syntax ([term-srcloc (syntax-srcloc stx)])
-       #'(first-order-sig char? term-srcloc))]))
-
-(define-syntax (Boolean$ stx)
-  (syntax-case stx (Boolean$)
-    [Boolean$
-     (with-syntax ([term-srcloc (syntax-srcloc stx)])
-       #'(first-order-sig boolean? term-srcloc))]))
-
-(define-syntax (Any$ stx)
-  (syntax-case stx (Any$)
-    [Any$
-     (with-syntax ([term-srcloc (syntax-srcloc stx)])
-       #'(first-order-sig (lambda (_) #t) term-srcloc))]))
-
-(define-syntax (Void$ stx)
-  (syntax-case stx (Void$)
-    [Void$
-     (with-syntax ([term-srcloc (syntax-srcloc stx)])
-       #'(first-order-sig void? term-srcloc))]))
-
-;; proc: is for internal use only.
-;; Stand-alone procedural signatures are defined using Sig:; e.g.,
-;; (define n->n (Sig: (Number$ -> Number$)))
-;; In all other cases, the macros invoke parse-sig, which takes care of
-;; automatically wrapping (proc: ...) around procedure signatures.
-(define-syntax (proc: stx)
-  (syntax-case stx (->)
-    [(_ (A ... -> R))
-     (with-syntax ([(args ...) (generate-temporaries #'(A ...))]
-                   [(A ...) (parse-sigs #'(A ...))]
-                   [R (parse-sig #'R)]
-                   [term-srcloc (syntax-srcloc stx)])
-       (with-syntax ([(A-srcloc ...) 
-                      (map syntax-srcloc (syntax->list #'(A ...)))]
-                     [R-srcloc (syntax-srcloc #'R)])
-         #'(make-signature
-            procedure?
-            (lambda (v)
-              (if (procedure? v)
-                  (lambda (args ...)
-                    (wrap R (v (wrap A args A-srcloc) ...) R-srcloc))
-                  (raise-signature-violation
-                   (format "not a procedure: ~e" v)
-                   (list term-srcloc))))
-            #t
-            term-srcloc)))]))
-
-(define-syntax (define: stx)
-  (syntax-case stx (: ->)
-    [(_ id : S exp)
-     (identifier? #'id)
-     (with-syntax ([S (parse-sig #'S)])
-       (with-syntax ([S-srcloc (syntax-srcloc #'S)])
-         #'(asl:define id (wrap S exp S-srcloc))))]
-    [(_ (f [a : Sa] ...) -> Sr exp)
-     (with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))]
-                   [Sr (parse-sig #'Sr)])
-       #'(asl:define f (lambda: ([a : Sa] ...) -> Sr exp)))]))
-
-(define-syntax (lambda: stx)
-  (syntax-case stx (: ->)
-    [(_ ([a : Sa] ...) -> Sr exp)
-     (with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))]
-                   [Sr (parse-sig #'Sr)])
-       (with-syntax ([(Sa-srcloc ...) (map syntax-srcloc (syntax->list #'(Sa ...)))]
-                     [Sr-srcloc (syntax-srcloc #'Sr)])
-         #'(asl:lambda (a ...)
-                       (let ([a (wrap Sa a Sa-srcloc)] ...)
-                         (wrap Sr exp Sr-srcloc)))))]))     
-
-(define-syntax (or: stx)
-  (syntax-case stx ()
-    [(_ S ...)
-     (with-syntax ([(S ...) (parse-sigs #'(S ...))]
-                   [term-srcloc (syntax-srcloc stx)])
-       (with-syntax ([(S-srcloc ...) 
-                      (map syntax-srcloc (syntax->list #'(S ...)))])
-         #'(first-order-sig
-            (lambda (x)
-              (let loop ([sigs (list S ...)]
-                         [sig-srclocs (list S-srcloc ...)])
-                (if (null? sigs)
-                    #f
-                    (let ([s (car sigs)])
-                      (if (signature? s)
-                          (if (signature-ho? s)
-                              (raise-signature-violation
-                               "or: cannot combine higher-order signature" 
-                               (list term-srcloc (signature-srcloc s)))
-                              (or ((signature-pred s) x)
-                                  (loop (cdr sigs) (cdr sig-srclocs))))
-                          (not-sig-error (car sig-srclocs)))))))
-            term-srcloc)))]))
-
-(define-syntax (and: stx)
-  (syntax-case stx ()
-    [(_ S ...)
-     (with-syntax ([(S ...) (parse-sigs #'(S ...))]
-                   [term-srcloc (syntax-srcloc stx)])
-       (with-syntax ([(S-srcloc ...) (map syntax-srcloc (syntax->list #'(S ...)))])
-         #'(first-order-sig
-            (lambda (x)
-              (let loop ([sigs (list S ...)]
-                         [sig-srclocs (list S-srcloc ...)])
-                (if (null? sigs)
-                    #t
-                    (let ([s (car sigs)])
-                      (if (signature? s)
-                          (if (signature-ho? s)
-                              (raise-signature-violation
-                               "and: cannot combine higher-order signature" 
-                               (list term-srcloc (signature-srcloc s)))
-                              (and ((signature-pred s) x)
-                                   (loop (cdr sigs) (cdr sig-srclocs))))
-                          (not-sig-error (car sig-srclocs)))))))
-            term-srcloc)))]))
-
-(define-syntax (not: stx)
-  (syntax-case stx ()
-    [(_ S)
-     (with-syntax ([S (parse-sig #'S)]
-                   [term-srcloc (syntax-srcloc stx)])
-       (with-syntax ([sig-srcloc(syntax-srcloc #'S)])
-         #'(let ([s S])
-             (if (signature? s)
-                 (if (signature-ho? s)
-                     (raise-signature-violation
-                      "not: cannot negate higher-order signature" 
-                      (list term-srcloc))
-                     (first-order-sig (lambda (x) (not ((signature-pred s) x))) term-srcloc))
-                 (not-sig-error sig-srcloc)))))]))
-
-#|
-(provide : defvar:)
-
-(define-syntax (: stx) (raise-syntax-error stx ': "Cannot be used outside ..."))
-
-(define-syntax (defvar: stx)
-  (syntax-parse stx #:literals(:)
-    [(_ i:id : S:expr b:expr)
-     #'(asl:define i
-         (let ([e b])
-           (if (S e)
-               e
-               (error 'signature "violation of ~a" S))))]))
-|#

whalesong/cs019/rewrite-error-message.rkt

@@ -1,99 +0,0 @@
-#lang scheme/base
-
-(require mzlib/etc
-         mzlib/list
-         (for-syntax "firstorder.rkt"
-                     scheme/base))
-
-(provide rewrite-contract-error-message
-         reraise-rewriten-lookup-error-message
-         get-rewriten-error-message
-         plural
-         raise-not-bound-error
-         argcount-error-message)
-
-(define (reraise-rewriten-lookup-error-message e id was-in-app-position)
-  (let ([var-or-function (if was-in-app-position "function" "variable")])
-    (raise-syntax-error
-     #f
-     (format "this ~a is not defined" var-or-function)
-     id)))
-
-(define (exn-needs-rewriting? exn)
-  (exn:fail:contract? exn))
-
-(define (ensure-number n-or-str)
-  (if (string? n-or-str) (string->number n-or-str) n-or-str))
-
-(define (plural n)
-  (if (> (ensure-number n) 1) "s" ""))
-
-(define (raise-not-bound-error id)
-  (if (syntax-property id 'was-in-app-position)
-      (raise-syntax-error
-       #f
-       "this function is not defined"
-       id)
-      (raise-syntax-error
-       #f
-       "this variable is not defined"
-       id)))
-
-(define (argcount-error-message arity found [at-least #f])
-  (define arity:n (ensure-number arity))
-  (define found:n (ensure-number found))
-  (define fn-is-large (> arity:n found:n))
-  (format "expects ~a~a~a argument~a, but found ~a~a"
-          (if at-least "at least " "")
-          (if (or (= arity:n 0) fn-is-large) "" "only ")
-          (if (= arity:n 0) "no" arity:n) (plural arity:n)
-          (if (and (not (= found:n 0)) fn-is-large) "only " "")
-          (if (= found:n 0) "none" found:n)))
-
-(define (rewrite-contract-error-message msg)
-  (define replacements
-    (list (list #rx"procedure application: expected procedure, given: (.*) \\(no arguments\\)"
-                (lambda (all one) 
-                  (format "function call: expected a function after the open parenthesis, but received ~a" one)))
-          (list #rx"procedure application: expected procedure, given: (.*); arguments were:.*"
-                (lambda (all one)  
-                  (format "function call: expected a function after the open parenthesis, but received ~a" one)))
-          (list #rx"expects argument of type (<([^>]+)>)"
-                (lambda (all one two) (format "expects a ~a" two)))
-          (list #rx"expected argument of type (<([^>]+)>)"
-                (lambda (all one two) (format "expects a ~a" two)))
-          (list #rx"expects type (<([^>]+)>)"
-                (lambda (all one two) (format "expects a ~a" two)))
-          (list #px"expects at least (\\d+) argument.?, given (\\d+)(: .*)?"
-                (lambda (all one two three) (argcount-error-message one two #t)))
-          (list #px"expects (\\d+) argument.?, given (\\d+)(: .*)?"
-                (lambda (all one two three) (argcount-error-message one two)))
-          (list #rx"^procedure "
-                (lambda (all) ""))
-          (list #rx", given: "
-                (lambda (all) ", given "))
-          (list #rx"; other arguments were:.*"
-                (lambda (all) ""))
-          (list #rx"expects a (struct:)"
-                (lambda (all one) "expects a "))
-          (list #rx"list or cyclic list"
-                (lambda (all) "list"))
-          (list (regexp-quote "given #(struct:object:image% ...)")
-                (lambda (all) "given an image"))
-          (list (regexp-quote "given #(struct:object:image-snip% ...)")
-                (lambda (all) "given an image"))
-          (list (regexp-quote "given #(struct:object:cache-image-snip% ...)")
-                (lambda (all) "given an image"))
-          (list (regexp-quote "#(struct:object:image% ...)")
-                (lambda (all) "(image)"))
-          (list (regexp-quote "#(struct:object:image-snip% ...)")
-                (lambda (all) "(image)"))
-          (list (regexp-quote "#(struct:object:cache-image-snip% ...)")
-                (lambda (all) "(image)"))))
-  (for/fold ([msg msg]) ([repl. replacements])
-    (regexp-replace* (first repl.) msg (second repl.))))
-
-(define (get-rewriten-error-message exn)
-  (if (exn-needs-rewriting? exn)
-      (rewrite-contract-error-message (exn-message exn))
-      (exn-message exn)))

whalesong/cs019/teach-runtime.rkt

@@ -1,14 +0,0 @@
-#lang s-exp "../lang/base.rkt"
-
-(provide check-not-undefined)
-
-;; Wrapped around uses of local-bound variables:
-(define (check-not-undefined name val)
-  (if (eq? val undefined)
-      (raise
-       (make-exn:fail:contract:variable
-        (format "local variable used before its definition: ~a" name)
-        (current-continuation-marks)
-        name))
-      val))
-(define undefined (letrec ([x x]) x))

whalesong/cs019/teachhelp.rkt

@@ -1,95 +0,0 @@
-(module teachhelp mzscheme
-  (require "firstorder.rkt"
-           "rewrite-error-message.rkt"
-           "../version-case/version-case.rkt")
-
-  ;; We're treading in private implementation; we deserve this pain.
-  (version-case
-    [(and (version<= "5.2.0.900" (version))
-          (version< (version) "5.2.900"))
-     (begin
-       (require stepper/private/shared)
-       (require-for-syntax stepper/private/shared))]
-    [(version<= "5.2.900" (version))
-     (begin
-       (require stepper/private/syntax-property)
-       (require-for-syntax stepper/private/syntax-property))]
-    [else
-     (error 'teachhelp.rkt "Unable to cooperate with Racket ~a" (version))])
-
-  
-  (provide make-undefined-check
-           make-first-order-function)
-
-  (define (make-undefined-check check-proc tmp-id)
-    (let ([set!-stx (datum->syntax-object check-proc 'set!)])
-      (make-set!-transformer
-       (lambda (stx)
-	 (syntax-case stx ()
-	   [(set! id expr)
-	    (module-identifier=? (syntax set!) set!-stx)
-	    (with-syntax ([tmp-id tmp-id])
-	      (syntax/loc stx (set! tmp-id expr)))]
-	   [(id . args)
-	    (datum->syntax-object
-	     check-proc
-	     (cons (stepper-syntax-property
-		    (datum->syntax-object
-		     check-proc
-		     (list check-proc 
-			   (list 'quote (syntax id))
-			   tmp-id))
-		    'stepper-skipto
-                    (append skipto/cdr
-                            skipto/third))
-		   (syntax args))
-	     stx)]
-	   [id
-            (stepper-syntax-property
-             (datum->syntax-object
-              check-proc
-              (list check-proc 
-                    (list 'quote (syntax id))
-                    tmp-id)
-              stx)
-             'stepper-skipto
-             (append skipto/cdr
-                     skipto/third))])))))
-#;    
-  (define (appropriate-use what)
-    (case what
-     [(constructor)
-      "called with values for the structure fields"]
-     [(selector) 
-      "applied to a structure to get the field value"]
-     [(predicate procedure)
-      "applied to arguments"]))
-
-  (define (make-first-order-function what arity orig-id app)
-    (make-set!-transformer
-     (make-first-order
-      (lambda (stx)
-	(syntax-case stx (set!)
-	  [(set! . _) (raise-syntax-error 
-		       #f stx #f 
-		       "internal error: assignment to first-order function")]
-	  [id
-	   (identifier? #'id)
-	   (raise-syntax-error
-	    #f
-	    (format "expected a function call, but there is no open parenthesis before this function")
-	    stx
-	    #f)]
-	  [(id . rest)
-	   (let ([found (length (syntax->list #'rest))])
-	     (unless (= found arity)
-	       (raise-syntax-error
-		#f
-                (argcount-error-message arity found)
-		stx
-		#f))
-	     (datum->syntax-object
-	      app
-	      (list* app (datum->syntax-object orig-id (syntax-e orig-id) #'id #'id) #'rest)
-	      stx stx))]))
-      (syntax-local-introduce orig-id)))))

whalesong/examples/alert.rkt

@@ -1,3 +0,0 @@
-#lang whalesong
-(require whalesong/js)
-(alert "hello world")

whalesong/examples/cs019/hello.rkt

@@ -1,2 +0,0 @@
-#lang whalesong/cs019
-"hello world"

whalesong/examples/cs019/tick-tock/index.html

@@ -1,7 +0,0 @@
-<!DOCTYPE html>
-<html>
-  <head><title>My simple program</title></head>
-  <body>
-    <p>The current counter is: <span id="counter">fill-me-in</span></p>
-  </body>
-</html>

whalesong/examples/cs019/tick-tock/tick-tock.rkt

@@ -1,21 +0,0 @@
-#lang whalesong/cs019
-
-(define-resource index.html)
-
-
-(define: (draw [world : Number$] [dom : View$]) -> View$
-  (update-view-text (view-focus dom "counter") world))
-
-
-(define: (tick [world : Number$] [dom : View$]) -> Number$
-  (add1 world))
-
-
-(define: (stop? [world : Number$] [dom : View$]) -> Boolean$
-  (> world 10))
-
-(big-bang 0
-          (initial-view index.html)
-          (to-draw draw)
-          (on-tick tick 1)
-          (stop-when stop?))

whalesong/examples/cs019/where-am-i/index.html

@@ -1,9 +0,0 @@
-<html>
-<head><title>Where in the world am I?</title></head>
-<body>
-<p>
-  I am at: <span id="real-location">dunno</span>.
-  The mock location says: <span id="mock-location">dunno</span>.
-</p>
-</body>
-</html>

whalesong/examples/cs019/where-am-i/where-am-i.rkt

@@ -1,56 +0,0 @@
-#lang whalesong/cs019
-
-(define-resource index.html)
-
-(define-struct: coord ([lat : Number$]
-                       [lng : Number$]))
-
-;; coord/unknown?: any -> boolean
-;; Returns true if x is a coord or the symbol 'unknown.
-(define (coord/unknown? x)
-  (or (coord? x)
-      (and (symbol? x)
-           (symbol=? x 'unknown))))
-
-(define Coord/Unknown$ (Sig: coord/unknown?))
-  
-
-;; The world stores both the real location, as well as a mocked-up
-;; one.
-(define-struct: world ([real : Coord/Unknown$]
-                       [mock : Coord/Unknown$]))
-
-
-(define: (location-change [world : world$] [dom : View$] [evt : Event$]) -> world$
-  (make-world (make-coord (event-ref evt "latitude")
-                          (event-ref evt "longitude"))
-              (world-mock world)))
-
-
-(define: (mock-location-change [world : world$] [dom : View$] [evt : Event$]) -> world$
-  (make-world (world-real world)
-              (make-coord (event-ref evt "latitude")
-                          (event-ref evt "longitude"))))
-
-
-(define: (draw [world : world$] [dom : View$]) -> View$
-  (local [(define v1 (if (coord? (world-real world))
-                         (update-view-text (view-focus dom "real-location")
-                                           (format "lat=~a, lng=~a"
-                                                   (coord-lat (world-real world))
-                                                   (coord-lng (world-real world))))
-                         dom))
-          (define v2 (if (coord? (world-mock world))
-                         (update-view-text (view-focus v1 "mock-location")
-                                           (format "lat=~a, lng=~a"
-                                                   (coord-lat (world-mock world))
-                                                   (coord-lng (world-mock world))))
-                         v1))]
-         v2))
-
-
-(big-bang (make-world 'unknown 'unknown)
-          (initial-view index.html)
-          (to-draw draw)
-          (on-location-change location-change)
-          (on-mock-location-change mock-location-change))

whalesong/examples/dom-play.rkt

@@ -1,37 +0,0 @@
-#lang whalesong
-
-(require whalesong/js)
-
-
-;; insert-break: -> void
-(define (insert-break)
-  (call-method ($ "<br/>") "appendTo" body)
-  (void))
-
-
-(define (write-message msg)
-  (void (call-method (call-method (call-method ($ "<span/>") "text" msg)
-                    "css" "white-space" "pre")
-              "appendTo"
-              body)))
-
-
-
-;; Set the background green.
-(void (call-method body "css" "background-color" "lightgreen"))
-(void (call-method ($ "<h1>Hello World</h1>") "appendTo" body))
-(write-message "Hello, this is a test!")
-(insert-break)
-(let loop ([i 0])
-  (cond
-   [(= i 10)
-    (void)]
-   [else
-    (write-message "iteration ") (write-message i)
-    (insert-break)
-    (loop (add1 i))]))
-
-(write-message "viewport-width: ") (write-message (viewport-width))
-(insert-break)
-(write-message "viewport-height: ") (write-message (viewport-height))
-(insert-break)

whalesong/examples/drag-and-drop/drag-and-drop-1.rkt

@@ -1,59 +0,0 @@
-#lang whalesong
-
-(require whalesong/web-world
-         whalesong/resource)
-
-(define-resource view.html)
-(define-resource style.css)
-
-;; A small drag-and-drop example using the web-world library.
-;;
-;; The world consists of a set of shapes.
-;;
-;; A shape has an id and a position.
-(define-struct shape (id x y))
-
-
-
-;; add-fresh-shape: world view -> world
-;; Given a world, creates a new world within the boundaries of the playground.
-(define (add-fresh-shape w v)
-  (define-values (max-width max-height) (width-and-height v "playground"))
-  (define new-world (cons (make-shape (fresh-id)
-                                      (random max-width)
-                                      (random max-height))
-                          w))
-  new-world)
-
-
-
-(define (width-and-height v element-id)
-  (define focused (view-focus v element-id))
-  (values (view-width focused)
-          (view-height focused)))
-
-
-(define (draw w v)
-  (foldl (lambda (a-shape v)
-           (cond
-            [(view-focus? v (shape-id a-shape))
-             v]
-            [else
-             (view-append-child v
-                                (xexp->dom `(span (@ (class "shape")
-                                                     (id ,(shape-id a-shape))
-                                                     (style ,(format "position: absolute; left: ~apx; top: ~apx"
-                                                                     (shape-x a-shape)
-                                                                     (shape-y a-shape))))
-                                                  "shape")))]))
-         (view-focus v "playground")
-         w))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define the-view (view-bind-many view.html
-                                 ["add" "click" add-fresh-shape]))
-
-(big-bang (list)
-          (initial-view the-view)
-          (to-draw draw))

whalesong/examples/drag-and-drop/drag-and-drop-2.rkt

@@ -1,128 +0,0 @@
-#lang whalesong
-
-(require whalesong/web-world
-         whalesong/resource)
-
-(define-resource view.html)
-(define-resource style.css)
-
-;; A small drag-and-drop example using the web-world library.
-;;
-;; The world consists of a set of shapes.  It also has a reference
-;; to the currently dragged shape, if one is being dragged.
-(define-struct world (shapes  ;; (listof shape)
-                      dragged ;; (U shape #f)
-                      ))
-
-;; A shape has an id and a position.
-(define-struct shape (id x y))
-
-
-
-;; add-fresh-shape: world view -> world
-;; Given a world, creates a new world within the boundaries of the playground.
-(define (add-fresh-shape w v)
-  (define-values (max-width max-height) (width-and-height v "playground"))
-  (define new-world (make-world (cons (make-shape (fresh-id)
-                                                  (random max-width)
-                                                  (random max-height))
-                                      (world-shapes w))
-                                (world-dragged w)))
-  new-world)
-
-
-;; Helper: produces the width and height of the element with the given id.
-(define (width-and-height v element-id)
-  (define focused (view-focus v element-id))
-  (values (view-width focused)
-          (view-height focused)))
-
-
-(define (draw w v)
-  (foldl (lambda (a-shape v)
-           (cond
-            [(view-focus? v (shape-id a-shape))
-             (define focused (view-focus v (shape-id a-shape)))
-             (update-view-css (update-view-css focused "left" (format "~apx" (shape-x a-shape)))
-                              "top"
-                              (format "~apx" (shape-y a-shape)))]
-            [else
-             (view-bind-many
-              (view-append-child v
-                                 (xexp->dom `(span (@ (class "shape")
-                                                      (id ,(shape-id a-shape))
-                                                      (style ,(format "position: absolute; left: ~apx; top: ~apx"
-                                                                      (shape-x a-shape)
-                                                                      (shape-y a-shape))))
-                                                   "shape")))
-              [(shape-id a-shape) "mousedown" mousedown])]))
-         (view-focus v "playground")
-         (if (shape? (world-dragged w))
-             (cons (world-dragged w) (world-shapes w))
-             (world-shapes w))))
-
-
-;; find-shape: (listof shape) string -> (U #f shape)
-(define (find-shape los id)
-  (cond
-   [(empty? los)
-    #f]
-   [(string=? (shape-id (first los)) id)
-    (first los)]
-   [else
-    (find-shape (rest los) id)]))
-
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Mouse handling.
-
-;; When the mouse is down, select the shape being clicked.
-;; The shape being mousedowned is the one with focus.
-(define (mousedown w v evt)
-  (define selected-shape (find-shape (world-shapes w) (view-id v)))
-  (make-world (remove selected-shape (world-shapes w))
-              selected-shape))
-
-
-
-(define (mouseup w v evt)
-  (cond [(shape? (world-dragged w))
-         (make-world (cons (world-dragged w)
-                           (world-shapes w))
-                     #f)]
-        [else
-         w]))
-
-(define (mousemove w v evt)
-  (cond
-   [(shape? (world-dragged w))
-    (define-values (left top) (normalize-mouse-event-coordinates v evt))
-    (make-world (world-shapes w)
-                (make-shape (shape-id (world-dragged w))
-                            left
-                            top))]
-   [else
-    w]))
-
-(define (normalize-mouse-event-coordinates v evt)
-  (values (- (event-ref evt "pageX")
-             (string->number (trim-px (view-css v "left"))))
-          (- (event-ref evt "pageY")
-             (string->number (trim-px (view-css v "top"))))))
-
-(define (trim-px s)
-  (substring s 0 (- (string-length s) 2)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define the-view (view-bind-many view.html
-                                 ["add" "click" add-fresh-shape]
-                                 ["playground" "mousemove" mousemove]
-                                 ["playground" "mouseup" mouseup]))
-
-(big-bang (make-world (list) #f)
-          (initial-view the-view)
-          (to-draw draw))

whalesong/examples/drag-and-drop/style.css

@@ -1,16 +0,0 @@
-
-#playground {
-    background-color: lightgray;
-    border: 1px solid black;
-    width: 500px;
-    height: 500px;
-    display: block;
-    position: relative;
-}
-
-
-.shape {
-    position: relative;
-    background-color: orange;
-    border: 1px solid black;
-}

whalesong/examples/drag-and-drop/view.html

@@ -1,16 +0,0 @@
-<!DOCTYPE html>
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css"/>
-</head>
-<body>
-<h1>Drag and drop example</h1>
-
-<div id="playground">
-This is the playground.
-</div>
-
-<input type="button" id="add" value="Add"/>
-
-</body>
-</html>

whalesong/examples/eli-number-puzzle.rkt

@@ -1,45 +0,0 @@
-#lang whalesong
-
-;; Eli's puzzle
-;;
-;;    http://lists.racket-lang.org/users/archive/2011-July/046849.html
-
-(require whalesong/world)
-          
-(define-struct world (seq output))
-
-;; streak: (listof number) -> number
-(define (streak lst)
-  (let ([elt (car lst)])
-    (let loop ([lst lst])
-      (cond
-        [(null? lst) 0]
-        [(= (car lst)
-            elt)
-         (add1 (loop (cdr lst)))]
-        [else
-         0]))))
-            
-(define (my-drop lst n)
-  (cond
-    [(= n 0)
-     lst]
-    [else
-     (my-drop (cdr lst) (sub1 n))]))
-
-(define (tick w)
-  (let* ([streak-length (streak (world-seq w))]
-         [next-self-describing-chunk
-          (list streak-length (car (world-seq w)))])
-    (make-world (append (my-drop (world-seq w) streak-length) 
-                        next-self-describing-chunk)
-                (append (world-output w)
-                        (list streak-length
-                              (car (world-seq w)))))))
-
-(define (draw w)
-  (world-output w))
-
-(big-bang (make-world '(1) '())
-          (on-tick tick 1)
-          (to-draw draw))

whalesong/examples/expanding-circle.rkt

@@ -1,24 +0,0 @@
-#lang whalesong
-
-(require whalesong/world
-         whalesong/image)
-
-
-(define handler (on-tick add1 1))
-handler
-
-"big bang should follow:"
-
-
-(define (draw w)
-  (circle w 'solid 'blue))
-
-
-(big-bang 1
-          (on-tick add1 1/28)
-          (stop-when (lambda (w) (> w 500)))
-          (to-draw draw)
-          )
-
-
-"all done"

whalesong/examples/fact.rkt

@@ -1,8 +0,0 @@
-#lang whalesong
-(provide fact)
-(define (fact x)
-  (cond
-   [(= x 0)
-    1]
-   [else
-    (* x (fact (sub1 x)))]))

whalesong/examples/google-maps/maps.rkt

@@ -1,127 +0,0 @@
-#lang whalesong
-
-;; A simple binding to Google Maps.
-;;
-;; Some of this comes from:
-;;
-;;     https://developers.google.com/maps/documentation/javascript/tutorial
-;; 
-
-(require whalesong/js
-         whalesong/js/world)
-
-(provide initialize-google-maps-api!
-         make-dom-and-map
-         make-on-map-click)
-
-
-
-;; initialize-google-maps-api!: string boolean -> void
-;; Dynamically loads the Google Maps API.
-(define raw-initialize-google-maps-api!
-  (js-async-function->procedure
-   #<<EOF
-function(success, fail, key, sensor) {
-    var callbackName = 'afterGoogleMapsInitialized' + plt.runtime.makeRandomNonce();
-    window[callbackName] = function() {
-        delete(window[callbackName]);
-        // At this point, we know the API has been instantiated ok.
-        success(plt.runtime.VOID);
-    };
-
-    var script = document.createElement("script");
-    script.type = "text/javascript";
-    script.src = "http://maps.googleapis.com/maps/api/js?key="
-         + encodeURIComponent(key) + "&sensor=" + (sensor ? 'true' : 'false')
-         + "&callback=" + encodeURIComponent(callbackName);
-    document.body.appendChild(script);
-}
-EOF
-))
-
-
-;; raw-make-map-dom-and-map: js-number js-number -> (values dom-node gmap-object)
-;; Dynamically creates both a dom-node and a gmap object.
-(define raw-make-map-dom-and-map
-  (js-async-function->procedure
-   #<<EOF
-function(success, fail, lat, lng) {
-    var myOptions = {
-         center: new google.maps.LatLng(lat, lng),
-         zoom: 8,
-         mapTypeId: google.maps.MapTypeId.ROADMAP
-    };
-    var domElement = document.createElement('div');
-    domElement.style.width = "100%";
-    domElement.style.height = "200px";
-    var map = new google.maps.Map(domElement, myOptions);
-    success(domElement, map);
-}
-EOF
-))
-
-;; We can listen to certain events, like click.
-;; https://developers.google.com/maps/documentation/javascript/events
-(define (raw-make-on-map-click a-gmap)
-  ;; setup will add a listener associated to the given map.
-  (define raw-setup
-    (js-function->procedure #<<EOF
-function(map, callback) {
-    var mapsListener =
-        google.maps.event.addListener(map, 'click', function(event) {
-            callback(plt.runtime.makeFloat(event.latLng.lat()),
-                     plt.runtime.makeFloat(event.latLng.lng()));
-        });
-   return mapsListener;
-}
-EOF
-))
-  ;; shutdown will remove the listener off the map.
-  (define raw-shutdown
-    (js-function->procedure #<<EOF
-function(gmap, mapsListener) {
-    google.maps.event.removeListener(gmap, mapsListener);
-}
-EOF
-
-))
-  (define (setup callback)
-    (raw-setup a-gmap callback))
-
-  (define (shutdown setup-data)
-    (raw-shutdown a-gmap setup-data))
-  
-  (make-world-event-handler setup shutdown))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (initialize-google-maps-api! key sensor)
-  (unless (string? key)
-    (raise-type-error 'initialize-google-maps-api! "string" 0 key))
-  (unless (boolean? sensor)
-    (raise-type-error 'initialize-google-maps-api! "boolean" 1 sensor))
-  (raw-initialize-google-maps-api! key sensor))
-
-
-;; make-dom-and-map: number number -> (values dom-node gmap-object)
-;; Given a latitude and longitude, creates a dom node that presents a
-;; Google Map, along with the gmap-object that carries its map state.
-;; TODO: We may want to provide a higher-level abstraction that
-;; encapsulates the two into a structured value.
-(define (make-dom-and-map lat lng)
-  (unless (real? lat)
-    (raise-type-error 'make-dom-and-map "real" 0 lat))
-  (unless (real? lng)
-    (raise-type-error 'make-dom-and-map "real" 1 lng))
-  (raw-make-map-dom-and-map (number->js-number lat)
-                            (number->js-number lng)))
-
-
-;; make-on-map-click: gmap-object -> world-handler
-;; TODO: We may want to provide a higher-level abstraction that
-;; encapsulates the two into a structured value.
-(define make-on-map-click raw-make-on-map-click)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

whalesong/examples/google-maps/test-maps.rkt

@@ -1,40 +0,0 @@
-#lang whalesong
-(require whalesong/web-world
-         "maps.rkt")
-
-;; Note: this is dyoo's API key.  Please don't abuse this.  :)
-(initialize-google-maps-api! "AIzaSyCRKQNI_nbyyN1286cssEy3taKj5IZcHN8" #f)
-
-
-;; We dynamically create a dom node for the presentation of the map,
-;; and an auxiliary gmap value that we use to manage the internal
-;; state of the map.
-(define-values (dom gmap)
-  (make-dom-and-map 41.82706261971936 -71.39962630844116))
-
-
-;; on-map-click: world handler
-;; Creates an on-map-click associated to the gmap, ready to be used in
-;; a big bang.
-;; It'll be used as an input device for our world program.
-(define on-map-click (make-on-map-click gmap))
-
-
-
-(xexp->dom '(h1 "Google Maps demonstration"))
-
-(big-bang "???"
-          (initial-view
-           (xexp->dom
-            `(div (p (@ (id "where"))
-                     "<<fill me in>>")
-                  (hr)
-                  ,dom
-                  (hr)
-                  (p "Instructions: click the map.  The "
-                     "world program will follow the map clicks."))))
-          (to-draw (lambda (w v)
-                     (update-view-text (view-focus v "where")
-                                       (format "~a" w))))
-          (on-map-click (lambda (w v lat lng)
-                          (list lat lng))))

whalesong/examples/hello-bf.rkt

@@ -1,23 +0,0 @@
-#lang whalesong/bf
-
-+++++ +++++             initialize counter (cell #0) to 10
-[                       use loop to set the next four cells to 70/100/30/10
-    > +++++ ++              add  7 to cell #1
-    > +++++ +++++           add 10 to cell #2 
-    > +++                   add  3 to cell #3
-    > +                     add  1 to cell #4
-    <<<< -                  decrement counter (cell #0)
-]                   
-> ++ .                  print 'H'
-> + .                   print 'e'
-+++++ ++ .              print 'l'
-.                       print 'l'
-+++ .                   print 'o'
-> ++ .                  print ' '
-<< +++++ +++++ +++++ .  print 'W'
-> .                     print 'o'
-+++ .                   print 'r'
------ - .               print 'l'
------ --- .             print 'd'
-> + .                   print '!'
-> .                     print '\n'

whalesong/examples/hello-css.css

@@ -1,3 +0,0 @@
-body {
-    background-color: blue
-}

whalesong/examples/hello-css.rkt

@@ -1,12 +0,0 @@
-#lang whalesong/base
-(require whalesong/web-world
-         whalesong/resource)
-
-(define-resource hello-css.css)
-(define-resource hello-css-main.html)
-
-(big-bang 0
-          (initial-view hello-css-main.html)
-          (to-draw (lambda (w v) v)))
-
-"done"