Makefile

@@ -0,0 +1,43 @@
+# test-analyzer:
+# 	raco make -v --disable-inline test-analyzer.rkt
+# 	racket test-analyzer.rkt
+
+launcher: 
+	raco make -v --disable-inline whalesong.rkt
+	racket make-launcher.rkt
+
+whalesong:
+	raco make -v --disable-inline whalesong.rkt
+
+test-all:
+	raco make -v --disable-inline tests/test-all.rkt
+	racket tests/test-all.rkt
+
+test-browser-evaluate:
+	raco make -v --disable-inline tests/test-browser-evaluate.rkt
+	racket tests/test-browser-evaluate.rkt
+
+test-compiler:
+	raco make -v --disable-inline tests/test-compiler.rkt
+	racket tests/test-compiler.rkt
+
+
+test-parse-bytecode-on-collects:
+	raco make -v --disable-inline tests/test-parse-bytecode-on-collects.rkt
+	racket tests/test-parse-bytecode-on-collects.rkt
+
+
+test-earley:
+	raco make -v --disable-inline tests/test-earley.rkt
+	racket tests/test-earley.rkt
+
+
+test-conform:
+	raco make -v --disable-inline tests/test-conform.rkt
+	racket tests/test-conform.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

README

@@ -1,7 +1,7 @@
 ======================================================================
 Whalesong: a compiler from Racket to JavaScript.
 
-Danny Yoo (dyoo@hashcollision.org)
+Danny Yoo (dyoo@cs.wpi.edu)
 
 
 ======================================================================
@@ -29,30 +29,21 @@ 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.)
+
+Create a simple, standalong 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
+    #lang planet dyoo/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.
+    $ ls -l hello.xhtml
+    -rw-rw-r-- 1 dyoo nogroup 692213 Jun  7 18:00 hello.xhtml
 
 
 [FIXME: add more examples]
@@ -177,7 +168,7 @@ 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
+browser-evaluate.rkt brings up a temporary web server that allows us
 to pass values between Racket and the JavaScript evaluator on the
 browser.
 
@@ -196,4 +187,4 @@ This uses code from the following projects:
    jquery (http://jquery.com/)
 
 
-   [FIXME: add more]
+   [FIXME: add more]

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

compiler/analyzer-structs.rkt

@@ -1,8 +1,7 @@
 #lang typed/racket/base
 
 
-(require "arity-structs.rkt"
-         "expression-structs.rkt"
+(require "expression-structs.rkt"
          "lexical-structs.rkt"
          "kernel-primitives.rkt"
 	 "il-structs.rkt")

compiler/bootstrapped-primitives.rkt

@@ -0,0 +1,257 @@
+#lang typed/racket/base
+(require "expression-structs.rkt"
+         "lexical-structs.rkt"
+         "il-structs.rkt"
+         "compiler.rkt"
+         "compiler-structs.rkt")
+
+
+(require/typed "../parameters.rkt"
+               (current-defined-name (Parameterof (U Symbol LamPositionalName))))
+(require/typed "../parser/parse-bytecode.rkt"
+               (parse-bytecode (Path -> Expression)))
+
+(require/typed "../parser/baby-parser.rkt"
+               [parse (Any -> 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
+    (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 default-continuation-prompt-tag))
+       ,(make-AssignPrimOpStatement (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-instruction-sequence `(,(make-AssignImmediateStatement '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.
+    (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-AssignImmediateStatement 'proc (make-ControlStackLabel))
+                                 ,(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/drop-multiple))))
+
+
+
+
+
+(: get-bootstrapping-code (-> (Listof Statement)))
+(define (get-bootstrapping-code)
+  
+  (append
+
+   
+   ;; Other primitives
+   (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-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-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)))
+   
+  
+   
+   ;; 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-GotoStatement (make-Label after-values-body-defn))
+       ,values-entry
+       ,(make-TestAndBranchStatement (make-TestOne (make-Reg 'argcount)) on-single-value)
+       ,(make-TestAndBranchStatement (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-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
+       ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
+       ,(make-PopEnvironment (make-Const 1) (make-Const 0))
+       ,(make-PopControlFrame)
+       ,(make-GotoStatement (make-Reg 'proc))
+
+       ;; Special case: on a single value, just use the regular return address
+       ,on-single-value
+       ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
+       ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
+       ,(make-PopEnvironment (make-Const 1) (make-Const 0))
+       ,(make-PopControlFrame)
+       ,(make-GotoStatement (make-Reg 'proc))
+
+       ;; On zero values, leave things be and just return.
+       ,on-zero-values
+       ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
+       ,(make-PopControlFrame)
+       ,(make-GotoStatement (make-Reg 'proc))
+       
+       ,after-values-body-defn
+       ,(make-AssignPrimOpStatement (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-GotoStatement (make-Label after-apply-code))
+       ,apply-entry
+       
+       ;; Push the procedure into proc.
+       ,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
+       ,(make-PopEnvironment (make-Const 1) (make-Const 0))
+       ;; Correct the number of arguments to be passed.
+       ,(make-AssignImmediateStatement 'argcount (make-SubtractArg (make-Reg 'argcount)
+                                                                   (make-Const 1)))
+       ;; Splice in the list argument.
+       ,(make-PerformStatement (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-AssignPrimOpStatement (make-PrimitivesReference 'apply)
+                                    (make-MakeCompiledProcedure apply-entry (make-ArityAtLeast 2) '() 'apply))))))

compiler/compiler-structs.rkt

@@ -1,6 +1,4 @@
 #lang typed/racket/base
-(require "expression-structs.rkt"
-         "analyzer-structs.rkt")
 
 
 (provide (all-defined-out))
@@ -40,8 +38,3 @@
 (define-type Linkage (U NextLinkage
                         LabelLinkage
                         ReturnLinkage))
-
-
-;; Lambda and compile-time environment
-(define-struct: lam+cenv ([lam : (U Lam CaseLam)]
-                          [cenv : CompileTimeEnvironment]))

compiler/expression-structs.rkt

@@ -1,7 +1,6 @@
-#lang whalesong (require "../selfhost-lang.rkt")
+#lang typed/racket/base
 (require "lexical-structs.rkt")
 
-
 (provide (all-defined-out))
 
 
@@ -56,9 +55,7 @@
 (define-struct: Constant ([v : Any]) #:transparent)
 
 (define-struct: ToplevelRef ([depth : Natural]
-                             [pos : Natural]
-                             [constant? : Boolean]
-                             [check-defined? : Boolean]) #:transparent)
+                             [pos : Natural]) #:transparent)
 
 (define-struct: LocalRef ([depth : Natural]
                           [unbox? : Boolean]) #:transparent)
@@ -158,16 +155,9 @@
 
 
 
-
-(: current-short-labels? (Parameterof Boolean))
-(define current-short-labels? (make-parameter #t))
-
-
 (: 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))))))
+      (string->symbol (format "~a~a" l n)))))

compiler/il-structs.rkt

@@ -3,8 +3,7 @@
 
 (require "expression-structs.rkt"
          "lexical-structs.rkt"
-         "kernel-primitives.rkt"
-         "arity-structs.rkt")
+         "kernel-primitives.rkt")
 
 
 
@@ -35,23 +34,19 @@
                       CompiledProcedureEntry
                       CompiledProcedureClosureReference
                       ModuleEntry
-                      ModulePredicate
+                      IsModuleInvoked
+		      IsModuleLinked
                       PrimitiveKernelValue
-                      VariableReference
-                      ))
+                      VariableReference))
 
 
 ;; Targets: these are the allowable lhs's for a targetted assignment.
 (define-type Target (U AtomicRegisterSymbol 
                        EnvLexicalReference
                        EnvPrefixReference
-                       PrimitivesReference
-                       GlobalsReference
+                       PrimitivesReference                   
                        ControlFrameTemporary
-                       ModulePrefixTarget
-                       ))
-
-(define-struct: ModuleVariableThing () #:transparent)
+                       ModulePrefixTarget))
 
 
 ;; When we need to store a value temporarily in the top control frame, we can use this as a target.
@@ -67,33 +62,13 @@
 (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])
+(define-struct: Const ([const : Any])
   #:transparent)
 
 ;; Limited arithmetic on OpArgs
@@ -102,34 +77,6 @@
   #: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)
@@ -153,47 +100,47 @@
 (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)
 
+;; Produces true if the module has already been invoked
+(define-struct: IsModuleInvoked ([name : ModuleLocator])
+  #:transparent)
 
-(define-struct: ModulePredicate ([module-name : ModuleLocator]
-                                 [pred : (U 'invoked? 'linked?)])
+;; Produces true if the module has been loaded into the machine
+(define-struct: IsModuleLinked ([name : ModuleLocator])
   #: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-type UnlabeledStatement (U 
+                                 
+                                 AssignImmediateStatement
+                                 AssignPrimOpStatement
+                                 
+                                 PerformStatement
+                                 
+                                 GotoStatement
+                                 TestAndBranchStatement
+                                 
+                                 PopEnvironment
+                                 PushEnvironment
+                                 
+                                 PushImmediateOntoEnvironment
+                                 
+                                 PushControlFrame/Generic
+                                 PushControlFrame/Call
+                                 PushControlFrame/Prompt
 
-(define-predicate UnlabeledStatement? UnlabeledStatement)
+                                 PopControlFrame
+                                 
+                                 DebugPrint
+                                 Comment
+                                 ))
 
 
 ;; Debug print statement.
@@ -212,27 +159,11 @@
   #: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])
+(define-struct: AssignImmediateStatement ([target : Target]
+                                          [value : OpArg])
   #:transparent)
-(define-struct: AssignPrimOp ([target : Target]
-                              [op : PrimitiveOperator])
+(define-struct: AssignPrimOpStatement ([target : Target]
+                                       [op : PrimitiveOperator])
   #:transparent)
 
 
@@ -265,12 +196,12 @@
 (define-struct: PushControlFrame/Call ([label : LinkedLabel]) 
   #:transparent)
 
-(define-struct: PushControlFrame/Prompt
-  ([tag : (U OpArg DefaultContinuationPromptTag)]
-   [label : LinkedLabel])
+(define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
+                                         [label : LinkedLabel]
+                                         ;; TODO: add handler and arguments
+                                         )
   #:transparent)
 
-
 (define-struct: DefaultContinuationPromptTag ()
   #:transparent)
 (define default-continuation-prompt-tag 
@@ -279,19 +210,19 @@
 
 
 
-(define-struct: Goto ([target : (U Label 
+(define-struct: GotoStatement ([target : (U Label 
                                             Reg
                                             ModuleEntry
                                             CompiledProcedureEntry)]) 
   #:transparent)
 
-(define-struct: Perform ([op : PrimitiveCommand])
+(define-struct: PerformStatement ([op : PrimitiveCommand])
   #:transparent)
 
 
 
-(define-struct: TestAndJump ([op : PrimitiveTest]
-                                      [label : Symbol])
+(define-struct: TestAndBranchStatement ([op : PrimitiveTest]
+                                        [label : Symbol])
   #:transparent)
 
 
@@ -299,35 +230,23 @@
   #: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
+                                  ApplyPrimitiveProcedure
                                   
+
                                   MakeBoxedEnvironmentValue
 
                                   CaptureEnvironment
                                   CaptureControl
                                   
-                                  CallKernelPrimitiveProcedure
-                                  ApplyPrimitiveProcedure
-                                  ))
+                                  CallKernelPrimitiveProcedure))
 
 ;; Gets the label from the closure stored in the 'proc register and returns it.
 (define-struct: GetCompiledProcedureEntry ()
@@ -351,19 +270,27 @@
   #:transparent)
 
 
+;; Applies the primitive procedure that's stored in the proc register, using
+;; the argcount number of values that are bound in the environment as arguments
+;; to that primitive.
+(define-struct: ApplyPrimitiveProcedure ()
+  #:transparent)
+
+
+
+
 
 
 
 (define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName/Inline]
 
-                                              [operands : (Listof (U OpArg ModuleVariable))]
+                                              [operands : (Listof OpArg)]
                                               [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])
@@ -387,12 +314,14 @@
                             TestTrue
                             TestOne
                             TestZero
+                            TestPrimitiveProcedure
                             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: TestPrimitiveProcedure ([operand : OpArg]) #:transparent)
 (define-struct: TestClosureArityMismatch ([closure : OpArg]
                                           [n : OpArg]) #:transparent)
 
@@ -404,21 +333,14 @@
                                      [pos : Natural])
   #:transparent)
 
-;; Check that the global can be defined.
-;; If not, raise an error and stop evaluation.
-(define-struct: CheckGlobalBound! ([name : Symbol])
+;; Check the closure procedure value in 'proc and make sure it can accept the
+;; # of arguments (stored as a number in the argcount register.).
+(define-struct: CheckClosureArity! ([num-args : OpArg])
+  #:transparent)
+(define-struct: CheckPrimitiveArity! ([num-args : OpArg])
   #: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.
@@ -427,7 +349,7 @@
 
 ;; Adjusts the environment by pushing the values in the
 ;; closure (held in the proc register) into itself.
-(define-struct: InstallClosureValues! ([n : Natural])
+(define-struct: InstallClosureValues! ()
   #:transparent)
 
 
@@ -491,12 +413,6 @@
 (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]
@@ -516,16 +432,14 @@
 
 ;; Given the module locator, do any finalizing operations, like
 ;; setting up the module namespace.
-(define-struct: FinalizeModuleInvokation! ([path : ModuleLocator]
-                                           [provides : (Listof ModuleProvide)])
+(define-struct: FinalizeModuleInvokation! ([path : ModuleLocator])
   #:transparent)
 
 
 
 (define-type PrimitiveCommand (U                                
                                CheckToplevelBound!
-                               CheckGlobalBound!
-                               CheckClosureAndArity!
+                               CheckClosureArity!
                                CheckPrimitiveArity!
 
                                ExtendEnvironment/Prefix!
@@ -546,7 +460,6 @@
                                RestoreEnvironment!
                                RestoreControl!
                                
-                               LinkModule!
                                InstallModuleEntry!
                                MarkModuleInvoked!
                                AliasModuleAsMain!
@@ -556,16 +469,10 @@
 
 
 
-(define-type InstructionSequence (U Symbol
-                                    LinkedLabel
-                                    UnlabeledStatement
-                                    instruction-sequence-list
-                                    instruction-sequence-chunks))
-(define-struct: instruction-sequence-list ([statements : (Listof Statement)])
+(define-type InstructionSequence (U Symbol LinkedLabel Statement instruction-sequence))
+(define-struct: instruction-sequence ([statements : (Listof Statement)])
   #:transparent)
-(define-struct: instruction-sequence-chunks ([chunks : (Listof InstructionSequence)])
-  #:transparent)
-(define empty-instruction-sequence (make-instruction-sequence-list '()))
+(define empty-instruction-sequence (make-instruction-sequence '()))
 
 
 (define-predicate Statement? Statement)
@@ -573,45 +480,14 @@
 
 (: 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)))
+  (cond [(symbol? s) 
+         (list s)]
+        [(LinkedLabel? s)
+         (list s)]
+        [(Statement? s)
+         (list s)]
+        [else
+         (instruction-sequence-statements s)]))
 
 
 
@@ -620,4 +496,25 @@
 
 
 
-(define-predicate OpArg? OpArg)
+
+
+
+
+
+
+
+
+
+
+;; 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))
+
+
+
+
+(define-predicate OpArg? OpArg)

compiler/kernel-primitives.rkt

@@ -0,0 +1,177 @@
+#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
+				    'abs
+                                    '<
+                                    '<=
+                                    '=
+                                    '>
+                                    '>=
+                                    'cons
+                                    'car
+                                    'cdr
+				    'cadr
+				    'caddr
+                                    'list
+                                    'list*
+                                    'list->vector
+                                    'vector->list
+                                    'vector
+                                    'vector-length
+                                    'vector-ref
+                                    'vector-set!
+                                    'make-vector
+                                    'equal?
+                                    'member
+                                    'append
+                                    'reverse
+                                    'length
+				    'pair?
+                                    'null?
+                                    'not
+                                    'eq?
+				    '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
+                                    ))
+(define-predicate KernelPrimitiveName? KernelPrimitiveName)
+
+
+;; These are the primitives that we know how to inline.
+(define-type KernelPrimitiveName/Inline (U '+
+                                           '-
+                                           '*
+                                           '/
+                                           'add1
+                                           'sub1
+                                           '<
+                                           '<=
+                                           '=
+                                           '>
+                                           '>=
+                                           'cons
+                                           'car
+                                           'cdr
+                                           'list
+                                           'null?
+                                           'not
+                                           'eq?))
+
+
+(define-predicate KernelPrimitiveName/Inline? KernelPrimitiveName/Inline)
+
+
+
+(: kernel-primitive-expected-operand-types (KernelPrimitiveName/Inline 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)]))

compiler/lexical-env.rkt

@@ -48,11 +48,11 @@
                                  (let: ([n : (U False Symbol GlobalBucket 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)]
+                                          (make-EnvPrefixReference depth pos)]
                                          [(and (GlobalBucket? n) (eq? name (GlobalBucket-name n)))
-                                          (make-EnvPrefixReference depth pos #f)]
+                                          (make-EnvPrefixReference depth pos)]
                                          [else
                                           (prefix-loop (rest names) (add1 pos))]))]))]
                    
@@ -122,8 +122,8 @@
 ;; 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 
@@ -218,8 +218,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)))]))
 

compiler/lexical-structs.rkt

@@ -53,8 +53,7 @@
   #:transparent)
 
 (define-struct: EnvPrefixReference ([depth : Natural]
-                                    [pos : Natural]
-                                    [modvar? : Boolean])
+                                    [pos : Natural])
   #:transparent)
 
 (define-struct: EnvWholePrefixReference ([depth : Natural])

compiler/optimize-il.rkt

@@ -0,0 +1,163 @@
+#lang typed/racket/base
+(require "expression-structs.rkt"
+         "il-structs.rkt"
+         "lexical-structs.rkt"
+         racket/list)
+
+(provide optimize-il)
+
+;; perform optimizations on the intermediate language.
+;;
+
+
+
+(: optimize-il ((Listof Statement) -> (Listof Statement)))
+(define (optimize-il statements)
+
+  #;statements
+  ;; For now, replace pairs of PushEnvironment / AssignImmediate(0, ...)
+  ;; We should do some more optimizations here, like peephole...
+  (let loop ([statements (filter not-no-op? 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
+                [(and (PushEnvironment? first-stmt)
+                      (equal? first-stmt (make-PushEnvironment 1 #f))
+                      (AssignImmediateStatement? second-stmt))
+                 (let ([target (AssignImmediateStatement-target second-stmt)])
+                   (cond
+                     [(equal? target (make-EnvLexicalReference 0 #f))
+                      (cons (make-PushImmediateOntoEnvironment 
+                             (adjust-oparg-depth 
+                              (AssignImmediateStatement-value second-stmt) -1)
+                             #f)
+                            (loop (rest (rest statements))))]
+                     [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]
+    
+    [(AssignImmediateStatement? stmt)
+     (equal? (AssignImmediateStatement-target stmt)
+             (AssignImmediateStatement-value stmt))]
+
+    [(AssignPrimOpStatement? stmt)
+     #f]
+    
+    [(PerformStatement? stmt)
+     #f]
+    
+    [(GotoStatement? stmt)
+     #f]
+    
+    [(TestAndBranchStatement? 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))]
+    [(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]
+    [(IsModuleInvoked? oparg)
+     oparg]
+    [(IsModuleLinked? oparg)
+     oparg]
+    [(VariableReference? oparg)
+     (let ([t (VariableReference-toplevel oparg)])
+       (make-VariableReference 
+        (make-ToplevelRef (ensure-natural (+ n (ToplevelRef-depth t)))
+                          (ToplevelRef-pos t))))]))
+
+
+(define-predicate natural? Natural)
+(define (ensure-natural x)
+  (if (natural? x)
+      x
+      (error 'ensure-natural)))

examples/alert.rkt

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

examples/dom-play.rkt

@@ -1,6 +1,6 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
-(require whalesong/js)
+(require (planet dyoo/whalesong/js))
 
 
 ;; insert-break: -> void
@@ -34,4 +34,4 @@
 (write-message "viewport-width: ") (write-message (viewport-width))
 (insert-break)
 (write-message "viewport-height: ") (write-message (viewport-height))
-(insert-break)
+(insert-break)

examples/hello.rkt

@@ -0,0 +1,4 @@
+#lang planet dyoo/whalesong
+
+(display "hello world")
+(newline)

examples/simple-world-program.rkt

@@ -0,0 +1,9 @@
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/world))
+
+(display "hello again")
+(newline)
+
+(is-color? "red")
+(is-color? "blue")
+(is-color? 42)

examples/window-size.rkt

@@ -1,6 +1,4 @@
-#lang whalesong
-
-(require whalesong/js)
+#lang planet dyoo/whalesong
 
 (when (in-javascript-context?)
   (viewport-width))

get-module-bytecode.rkt

@@ -0,0 +1,61 @@
+#lang racket/base
+(require racket/path
+         racket/runtime-path
+         syntax/modcode
+         "language-namespace.rkt")
+
+(provide get-module-bytecode)
+
+
+(define-runtime-path kernel-language-path
+  "lang/kernel.rkt")
+
+  
+(define (get-module-bytecode x)
+  (let ([compiled-code
+         (cond
+           ;; Assumed to be a path string
+           [(string? x)
+            (get-compiled-code-from-path (normalize-path (build-path x)))]
+
+           [(path? x)
+            (get-compiled-code-from-path x)]
+
+           ;; Input port is assumed to contain the text of a module.
+           [(input-port? x)
+            (get-compiled-code-from-port x)]
+
+           [else
+            (error 'get-module-bytecode)])])
+    (let ([op (open-output-bytes)])
+      (write compiled-code op)
+      (get-output-bytes op))))
+
+
+;; Tries to use get-module-code to grab at module bytecode.  Sometimes
+;; this fails because it appears get-module-code tries to write to
+;; compiled/.
+(define (get-compiled-code-from-path p)
+  (with-handlers ([void (lambda (exn)
+                          ;; Failsafe: try to do it from scratch
+                          (call-with-input-file* p
+                            (lambda (ip)
+                              (get-compiled-code-from-port ip))))])
+    (get-module-code p)))
+
+
+
+
+
+
+(define base-namespace
+  (lookup-language-namespace
+   #;'racket/base
+   `(file ,(path->string kernel-language-path)))
+  #;(make-base-namespace))
+
+   
+(define (get-compiled-code-from-port ip)
+  (parameterize ([read-accept-reader #t]
+                 [current-namespace base-namespace])
+    (compile (read-syntax (object-name ip) ip))))

info.rkt

@@ -1,2 +1,13 @@
 #lang setup/infotab
-(define collection 'multi)
+
+(define name "Whalesong")
+(define blurb '("A Racket to JavaScript compiler"))
+(define release-notes '((p "A not-even-alpha release; please don't use this unless you expect sharp edges...")))
+(define version "0.01")
+(define categories '(devtools))
+(define repositories '("4.x"))
+(define required-core-version "5.1.1")
+(define racket-launcher-libraries '("whalesong.rkt"))
+(define racket-launcher-names '("whalesong"))
+(define homepage "http://hashcollision.org/whalesong")
+(define scribblings '(("scribblings/manual.scrbl")))

js-assembler/assemble-expression.rkt

@@ -0,0 +1,64 @@
+#lang typed/racket/base
+
+(require "assemble-structs.rkt"
+         "assemble-helpers.rkt"
+         "assemble-open-coded.rkt"
+         "../compiler/il-structs.rkt"
+         "../compiler/lexical-structs.rkt"
+         racket/string
+         racket/list)
+
+(provide assemble-op-expression)
+
+
+
+(: 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)"
+             (assemble-label (make-Label (MakeCompiledProcedure-label op)))
+             (assemble-arity (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)"
+             (assemble-label (make-Label (MakeCompiledProcedureShell-label op)))
+             (assemble-arity (MakeCompiledProcedureShell-arity op))
+             (assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
+    
+    [(ApplyPrimitiveProcedure? op)
+     (format "MACHINE.proc(MACHINE)")]
+    
+    [(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 : (U DefaultContinuationPromptTag OpArg)
+			 (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)]))

js-assembler/assemble-helpers.rkt

@@ -0,0 +1,398 @@
+#lang typed/racket/base
+
+(require "../compiler/il-structs.rkt"
+         "../compiler/expression-structs.rkt"
+         "../compiler/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-listof-assembled-values
+	 assemble-default-continuation-prompt-tag
+	 assemble-env-reference/closure-capture
+	 assemble-arity
+	 assemble-jump
+	 assemble-display-name
+	 assemble-location
+         assemble-numeric-constant)
+
+(require/typed typed/racket/base
+               [regexp-split (Regexp String -> (Listof String))])
+
+
+(: 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)]
+    [(SubtractArg? v)
+     (assemble-subtractarg v)]
+    [(ControlStackLabel? v)
+     (assemble-control-stack-label v)]
+    [(ControlStackLabel/MultipleValueReturn? v)
+     (assemble-control-stack-label/multiple-value-return v)]
+    [(ControlFrameTemporary? v)
+     (assemble-control-frame-temporary v)]
+    [(CompiledProcedureEntry? v)
+     (assemble-compiled-procedure-entry v)]
+    [(CompiledProcedureClosureReference? v)
+     (assemble-compiled-procedure-closure-reference v)]
+    [(PrimitiveKernelValue? v)
+     (assemble-primitive-kernel-value v)]
+    [(ModuleEntry? v)
+     (assemble-module-entry v)]
+    [(IsModuleInvoked? v)
+     (assemble-is-module-invoked v)]
+    [(IsModuleLinked? v)
+     (assemble-is-module-linked v)]
+    [(VariableReference? v)
+     (assemble-variable-reference v)]))
+
+
+
+
+(: assemble-target (Target -> String))
+(define (assemble-target target)
+  (cond
+    [(eq? target 'proc)
+     "MACHINE.proc"]
+    [(eq? target 'val)
+     "MACHINE.val"]
+    [(eq? target 'argcount)
+     "MACHINE.argcount"]
+    [(EnvLexicalReference? target)
+     (assemble-lexical-reference target)]
+    [(EnvPrefixReference? target)
+     (assemble-prefix-reference target)]
+    [(PrimitivesReference? target)
+     (format "RUNTIME.Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]
+    [(ControlFrameTemporary? target)
+     (assemble-control-frame-temporary target)]
+    [(ModulePrefixTarget? target)
+     (format "MACHINE.modules[~s].prefix"
+             (symbol->string (ModuleLocator-name (ModulePrefixTarget-path target))))]))
+
+
+(: assemble-control-frame-temporary (ControlFrameTemporary -> String))
+(define (assemble-control-frame-temporary t)
+  (format "MACHINE.control[MACHINE.control.length-1].~a"
+          (ControlFrameTemporary-name t)))
+
+;; 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 "RUNTIME.makePair(~a, ~a)" 
+                       (loop (car val))
+                       (loop (cdr val)))]
+              [(boolean? val)
+               (if val "true" "false")]
+              [(void? val)
+               "RUNTIME.VOID"]
+              [(empty? val)
+               (format "RUNTIME.NULL")]
+              [(number? val)
+               (assemble-numeric-constant val)]
+              [else
+               (format "~s" val)])))
+
+(: assemble-listof-assembled-values ((Listof String) -> String))
+(define (assemble-listof-assembled-values vals)
+  (let loop ([vals vals])
+    (cond
+      [(empty? vals)
+       "RUNTIME.NULL"]
+      [else
+       (format "RUNTIME.makePair(~a, ~a)" (first vals) (loop (rest vals)))])))
+
+
+
+;; Slightly ridiculous definition, but I need it to get around what appear to
+;; be Typed Racket bugs in its numeric tower.
+(define-predicate int? Integer)
+
+
+
+(: assemble-numeric-constant (Number -> String))
+(define (assemble-numeric-constant a-num)
+
+  (: floating-number->js (Real -> String))
+  (define (floating-number->js a-num)
+    (cond
+     [(eqv? a-num -0.0)
+      "jsnums.negative_zero"]
+     [(eqv? a-num +inf.0)
+      "jsnums.inf"]
+     [(eqv? a-num -inf.0)
+      "jsnums.negative_inf"]
+     [(eqv? a-num +nan.0)
+      "jsnums.nan"]
+     [else
+      (string-append "jsnums.makeFloat(" (number->string a-num) ")")]))
+
+  ;; FIXME: fix the type signature when typed-racket isn't breaking on
+  ;; (define-predicate ExactRational? (U Exact-Rational))
+  (: rational-number->js (Real -> String))
+  (define (rational-number->js a-num)
+    (cond [(= (denominator a-num) 1)
+           (string-append (integer->js (ensure-integer (numerator a-num))))]
+          [else
+           (string-append "jsnums.makeRational("
+                          (integer->js (ensure-integer (numerator a-num)))
+                          ", "
+                          (integer->js (ensure-integer (denominator a-num)))
+                          ")")]))
+
+  
+  (: ensure-integer (Any -> Integer))
+  (define (ensure-integer x)
+    (if (int? x)
+        x
+        (error "not an integer: ~e" x)))
+  
+
+
+  (: integer->js (Integer -> String))
+  (define (integer->js an-int)
+    (cond
+     ;; non-overflow case
+     [(< (abs an-int) 9e15)
+      (number->string an-int)]
+     ;; overflow case
+     [else
+      (string-append "jsnums.makeBignum("
+                     (format "~s" (number->string an-int))
+                     ")")]))
+
+  (cond 
+   [(and (exact? a-num) (rational? a-num))
+    (rational-number->js a-num)]
+   
+   [(real? a-num)
+    (floating-number->js a-num)]
+   
+   [(complex? a-num)
+    (string-append "jsnums.makeComplex("
+                   (assemble-numeric-constant (real-part a-num))
+                   ", "
+                   (assemble-numeric-constant (imag-part a-num))
+                   ")")]))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+   
+
+
+
+(: 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)
+  (let ([chunks
+         (regexp-split #rx"[^a-zA-Z0-9]+"
+                       (symbol->string (Label-name a-label)))])
+    (cond
+      [(empty? chunks)
+       (error "impossible: empty label ~s" a-label)]
+      [(empty? (rest chunks))
+       (string-append "_" (first chunks))]
+      [else
+       (string-append "_"
+                      (first chunks)
+                      (apply string-append (map string-titlecase (rest chunks))))])))
+
+
+
+(: assemble-subtractarg (SubtractArg -> String))
+(define (assemble-subtractarg s)
+  (format "(~a - ~a)"
+          (assemble-oparg (SubtractArg-lhs s))
+          (assemble-oparg (SubtractArg-rhs s))))
+
+
+(: assemble-control-stack-label (ControlStackLabel -> String))
+(define (assemble-control-stack-label a-csl)
+  "MACHINE.control[MACHINE.control.length-1].label")
+
+
+(: assemble-control-stack-label/multiple-value-return (ControlStackLabel/MultipleValueReturn -> String))
+(define (assemble-control-stack-label/multiple-value-return a-csl)
+  "MACHINE.control[MACHINE.control.length-1].label.multipleValueReturn")
+
+
+
+(: assemble-compiled-procedure-entry (CompiledProcedureEntry -> String))
+(define (assemble-compiled-procedure-entry a-compiled-procedure-entry)
+  (format "(~a).label"
+          (assemble-oparg (CompiledProcedureEntry-proc a-compiled-procedure-entry))))
+
+
+(: assemble-compiled-procedure-closure-reference (CompiledProcedureClosureReference -> String))
+(define (assemble-compiled-procedure-closure-reference a-ref)
+  (format "(~a).closedVals[(~a).closedVals.length - 1 - ~a]"
+          (assemble-oparg (CompiledProcedureClosureReference-proc a-ref))
+          (assemble-oparg (CompiledProcedureClosureReference-proc a-ref))
+          (CompiledProcedureClosureReference-n a-ref)))
+
+
+
+(: assemble-default-continuation-prompt-tag (-> String))
+(define (assemble-default-continuation-prompt-tag)
+  "RUNTIME.DEFAULT_CONTINUATION_PROMPT_TAG")
+
+
+
+(: 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))
+
+
+
+(define-predicate natural? Natural)
+
+(: assemble-arity (Arity -> String))
+(define (assemble-arity an-arity)
+  (cond
+   [(natural? an-arity)
+    (number->string an-arity)]
+   [(ArityAtLeast? an-arity)
+    (format "(RUNTIME.arityAtLeast(~a))"
+            (ArityAtLeast-value an-arity))]
+   [(listof-atomic-arity? an-arity)
+    (assemble-listof-assembled-values
+     (map
+      (lambda: ([atomic-arity : (U Natural ArityAtLeast)])
+	       (cond
+		[(natural? atomic-arity)
+		 (number->string atomic-arity)]
+		[(ArityAtLeast? atomic-arity)
+		 (format "(RUNTIME.arityAtLeast(~a))"
+                         (ArityAtLeast-value atomic-arity))]))
+      an-arity))]))
+
+
+
+
+
+(: assemble-jump (OpArg -> String))
+(define (assemble-jump target)
+  (format "return (~a)(MACHINE);" (assemble-oparg target)))
+
+
+
+
+
+(: assemble-display-name ((U Symbol LamPositionalName) -> String))
+(define (assemble-display-name name)
+  (cond
+   [(symbol? name)
+    (format "~s" (symbol->string name))]
+   [(LamPositionalName? name)
+    ;; FIXME: record more interesting information here.
+    (format "~s" (symbol->string (LamPositionalName-name name)))]))
+
+
+
+
+(: 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-primitive-kernel-value (PrimitiveKernelValue -> String))
+(define (assemble-primitive-kernel-value a-prim)
+  (format "MACHINE.primitives[~s]" (symbol->string (PrimitiveKernelValue-id a-prim))))
+
+
+
+(: assemble-module-entry (ModuleEntry -> String))
+(define (assemble-module-entry entry)
+  (format "MACHINE.modules[~s].label"
+          (symbol->string (ModuleLocator-name (ModuleEntry-name entry)))))
+
+
+(: assemble-is-module-invoked (IsModuleInvoked -> String))
+(define (assemble-is-module-invoked entry)
+  (format "MACHINE.modules[~s].isInvoked"
+          (symbol->string (ModuleLocator-name (IsModuleInvoked-name entry)))))
+
+
+(: assemble-is-module-linked (IsModuleLinked -> String))
+(define (assemble-is-module-linked entry)
+  (format "(MACHINE.modules[~s] !== undefined)"
+          (symbol->string (ModuleLocator-name (IsModuleLinked-name entry)))))
+
+
+
+(: assemble-variable-reference (VariableReference -> String))
+(define (assemble-variable-reference varref)
+  (let ([t (VariableReference-toplevel varref)])
+    (format "(new RUNTIME.VariableReference(MACHINE.env[MACHINE.env.length - 1 - ~a], ~a))"
+            (ToplevelRef-depth t)
+            (ToplevelRef-pos t))))

js-assembler/assemble-open-coded.rkt

@@ -0,0 +1,177 @@
+#lang typed/racket/base
+
+(require "assemble-helpers.rkt"
+         "../compiler/il-structs.rkt"
+         "../compiler/lexical-structs.rkt"
+         "../compiler/kernel-primitives.rkt"
+         racket/string
+         racket/list
+         typed/rackunit)
+
+(provide open-code-kernel-primitive-procedure)
+
+
+
+(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
+(define (open-code-kernel-primitive-procedure op)
+  (let*: ([operator : KernelPrimitiveName/Inline (CallKernelPrimitiveProcedure-operator op)]
+          [operands : (Listof String) (map assemble-oparg (CallKernelPrimitiveProcedure-operands op))]
+          [checked-operands : (Listof String)
+                            (map (lambda: ([dom : OperandDomain]
+					   [pos : Natural]
+					   [rand : String]
+					   [typecheck? : Boolean])
+				   (maybe-typecheck-operand operator dom pos rand typecheck?))
+                                 (CallKernelPrimitiveProcedure-expected-operand-types op)
+                                 (build-list (length operands) (lambda: ([i : Natural]) i))
+                                 operands
+                                 (CallKernelPrimitiveProcedure-typechecks? op))])
+        (case operator
+          [(+)
+           (cond [(empty? checked-operands)
+                  (assemble-numeric-constant 0)]
+                 [else
+                  (assemble-binop-chain "jsnums.add" checked-operands)])]
+          
+          [(-)
+           (cond [(empty? (rest checked-operands))
+                  (assemble-binop-chain "jsnums.subtract" (cons "0" checked-operands))]
+                 [else
+                  (assemble-binop-chain "jsnums.subtract" checked-operands)])]
+          
+          [(*)
+           (cond [(empty? checked-operands)
+                  (assemble-numeric-constant 1)]
+                 [else
+                  (assemble-binop-chain "jsnums.multiply" checked-operands)])]
+
+          [(/)
+           (assemble-binop-chain "jsnums.divide" checked-operands)]
+
+          [(add1)
+           (assemble-binop-chain "jsnums.add" (cons "1" checked-operands))]
+          
+          [(sub1)
+           (assemble-binop-chain "jsnums.subtract" (append checked-operands (list "1")))]
+
+          [(<)
+           (assemble-boolean-chain "jsnums.lessThan" checked-operands)]
+
+          [(<=)
+           (assemble-boolean-chain "jsnums.lessThanOrEqual" checked-operands)]
+          
+          [(=)
+           (assemble-boolean-chain "jsnums.equals" checked-operands)]
+          
+          [(>)
+           (assemble-boolean-chain "jsnums.greaterThan" checked-operands)]
+          
+          [(>=)
+           (assemble-boolean-chain "jsnums.greaterThanOrEqual" checked-operands)]
+          
+          [(cons)
+           (format "RUNTIME.makePair(~a, ~a)"
+                   (first checked-operands)
+                   (second checked-operands))]
+
+          [(car)
+           (format "(~a).first" (first checked-operands))]
+          
+          [(cdr)
+           (format "(~a).rest" (first checked-operands))]
+          
+          [(list)
+           (let loop ([checked-operands checked-operands])
+             (assemble-listof-assembled-values checked-operands))]
+          
+          [(null?)
+           (format "(~a === RUNTIME.NULL)" (first checked-operands))]
+
+          [(not)
+           (format "(~a === false)" (first checked-operands))]
+          
+          [(eq?)
+           (format "(~a === ~a)" (first checked-operands) (second checked-operands))])))
+
+
+
+(: assemble-binop-chain (String (Listof String) -> String))
+(define (assemble-binop-chain rator rands)
+  (cond
+   [(empty? rands)
+    ""]
+   [(empty? (rest rands))
+    (first rands)]
+   [else
+    (assemble-binop-chain
+     rator
+     (cons (string-append rator "(" (first rands) ", " (second rands) ")")
+           (rest (rest rands))))]))
+
+(check-equal? (assemble-binop-chain "jsnums.add" '("3" "4" "5"))
+              "jsnums.add(jsnums.add(3, 4), 5)")
+(check-equal? (assemble-binop-chain "jsnums.subtract" '("0" "42"))
+              "jsnums.subtract(0, 42)")
+
+
+
+
+
+
+(: assemble-boolean-chain (String (Listof String) -> String))
+(define (assemble-boolean-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))" rator (first rands) (second rands))
+                                         (loop (rest rands)))]))
+                              "&&")
+                 ")"))
+
+
+
+
+
+(: assemble-domain-check (Symbol OperandDomain String Natural -> String))
+(define (assemble-domain-check caller domain operand-string pos)
+  (cond
+    [(eq? domain 'any)
+     operand-string]
+    [else
+     (let: ([test-string : String
+                         (case domain
+                           [(number)
+                            (format "jsnums.isSchemeNumber(~a)"
+                                    operand-string)]             
+                           [(string)
+                            (format "(typeof(~a) === 'string')"
+                                    operand-string)]
+                           [(list)
+                            (format "RUNTIME.isList(~a)" operand-string)]
+                           [(pair)
+                            (format "RUNTIME.isPair(~a)" operand-string)]
+                           [(box)
+                            (format "(typeof(~a) === 'object' && (~a).length === 1)"
+                                    operand-string operand-string)])])
+           (format "((~a) ? (~a) : RUNTIME.raiseArgumentTypeError(MACHINE, ~s, ~s, ~s, ~a))"
+                   test-string
+                   operand-string
+		   (symbol->string caller)
+                   (symbol->string domain)
+                   pos
+                   operand-string))]))
+
+
+(: maybe-typecheck-operand (Symbol OperandDomain Natural String Boolean -> String))
+;; Adds typechecks if we can't prove that the operand is of the required type.
+(define (maybe-typecheck-operand caller domain-type position operand-string typecheck?)
+  (cond
+    [typecheck?
+     (assemble-domain-check caller domain-type operand-string position)]
+    [else
+     operand-string]))

js-assembler/assemble-perform-statement.rkt

@@ -0,0 +1,187 @@
+#lang typed/racket/base
+(require "assemble-helpers.rkt"
+         "../compiler/il-structs.rkt"
+	 "../compiler/lexical-structs.rkt"
+         "../parameters.rkt"
+	 racket/string)
+
+(provide assemble-op-statement)
+
+
+
+(: assemble-op-statement (PrimitiveCommand -> String))
+(define (assemble-op-statement op)  
+  (cond 
+    
+    [(CheckToplevelBound!? op)
+     (format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { RUNTIME.raiseUnboundToplevelError(MACHINE.env[MACHINE.env.length - 1 - ~a].names[~a]); }"
+             (CheckToplevelBound!-depth op)
+             (CheckToplevelBound!-pos op)
+             (CheckToplevelBound!-depth op)
+             (CheckToplevelBound!-pos op))]
+
+
+    [(CheckClosureArity!? op)
+     (format #<<EOF
+              if (! (MACHINE.proc instanceof RUNTIME.Closure)) {
+                  RUNTIME.raiseOperatorIsNotClosure(MACHINE, MACHINE.proc);
+              }
+              if (! RUNTIME.isArityMatching(MACHINE.proc.arity, ~a)) {
+                  RUNTIME.raiseArityMismatchError(MACHINE,
+                                                  MACHINE.proc,
+                                                  MACHINE.proc.arity,
+                                                  ~a);
+              }
+EOF
+             (assemble-oparg (CheckClosureArity!-num-args op))
+             (assemble-oparg (CheckClosureArity!-num-args op)))]
+
+    
+    [(CheckPrimitiveArity!? op)
+     (format #<<EOF
+              if (! (typeof(MACHINE.proc) === 'function')) {
+                  RUNTIME.raiseOperatorIsNotPrimitiveProcedure(MACHINE, MACHINE.proc);
+              }
+              if (! RUNTIME.isArityMatching(MACHINE.proc.arity, ~a)) {
+                  RUNTIME.raiseArityMismatchError(MACHINE,
+                                                  MACHINE.proc,
+                                                  MACHINE.proc.arity,
+                                                  ~a);
+              }
+EOF
+             (assemble-oparg (CheckPrimitiveArity!-num-args op))
+             (assemble-oparg (CheckPrimitiveArity!-num-args op)))]
+     
+    
+    [(ExtendEnvironment/Prefix!? op)
+     (let: ([names : (Listof (U Symbol False GlobalBucket 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 GlobalBucket ModuleVariable)])
+                                          (cond [(symbol? n)
+                                                 (format "MACHINE.params.currentNamespace[~s] || MACHINE.primitives[~s]"
+                                                         (symbol->string n) 
+                                                         (symbol->string n))]
+                                                [(eq? n #f)
+                                                 "false"]
+                                                [(GlobalBucket? n)
+                                                 ;; FIXME: maybe we should keep a set of global variables here?
+                                                 (format "MACHINE.primitives[~s]"
+                                                         (symbol->string (GlobalBucket-name n)))]
+                                                ;; FIXME:  this should be looking at the module path and getting
+                                                ;; the value here!  It shouldn't be looking into Primitives...
+                                                [(ModuleVariable? n)
+                                                 (cond
+                                                  [((current-kernel-module-locator?)
+                                                    (ModuleVariable-module-name n))
+                                                   (format "MACHINE.primitives[~s]"
+                                                           (symbol->string (ModuleVariable-name n)))]
+                                                  [else
+                                                   (format "MACHINE.modules[~s].namespace[~s]"
+                                                           (symbol->string
+                                                            (ModuleLocator-name
+                                                             (ModuleVariable-module-name n)))
+                                                           (symbol->string (ModuleVariable-name n)))])]))
+                                 names)
+                                ",")
+                   (string-join (map
+				 (lambda: ([n : (U Symbol False GlobalBucket ModuleVariable)])
+					  (cond
+					   [(symbol? n)
+					    (format "~s" (symbol->string n))]
+					   [(eq? n #f)
+					    "false"]
+                                           [(GlobalBucket? n)
+                                            (format "~s" (symbol->string (GlobalBucket-name n)))]
+					   [(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 : (U DefaultContinuationPromptTag OpArg)
+			 (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)))
+			   ", "))]
+    
+    [(SetFrameCallee!? op)
+     (format "MACHINE.control[MACHINE.control.length-1].proc = ~a;"
+             (assemble-oparg (SetFrameCallee!-proc op)))]
+    
+    [(SpliceListIntoStack!? op)
+     (format "RUNTIME.spliceListIntoStack(MACHINE, ~a);"
+             (assemble-oparg (SpliceListIntoStack!-depth op)))]
+
+    [(UnspliceRestFromStack!? op)
+     (format "RUNTIME.unspliceRestFromStack(MACHINE, ~a, ~a);"
+             (assemble-oparg (UnspliceRestFromStack!-depth op))
+             (assemble-oparg (UnspliceRestFromStack!-length op)))]
+
+    [(InstallContinuationMarkEntry!? op)
+     (string-append "RUNTIME.installContinuationMarkEntry(MACHINE,"
+                    "MACHINE.control[MACHINE.control.length-1].pendingContinuationMarkKey,"
+                    "MACHINE.val);")]
+
+    [(RaiseContextExpectedValuesError!? op)
+     (format "RUNTIME.raiseContextExpectedValuesError(MACHINE, ~a);"
+             (RaiseContextExpectedValuesError!-expected op))]
+
+
+    [(RaiseArityMismatchError!? op)
+     (format "RUNTIME.raiseArityMismatchError(MACHINE, ~a, ~a, ~a);"
+             (assemble-oparg (RaiseArityMismatchError!-proc op))
+             (assemble-arity (RaiseArityMismatchError!-expected op))
+             (assemble-oparg (RaiseArityMismatchError!-received op)))]
+
+
+    [(RaiseOperatorApplicationError!? op)
+     (format "RUNTIME.raiseOperatorApplicationError(MACHINE, ~a);"
+             (assemble-oparg (RaiseOperatorApplicationError!-operator op)))]
+
+
+    [(RaiseUnimplementedPrimitiveError!? op)
+     (format "RUNTIME.raiseUnimplementedPrimitiveError(MACHINE, ~s);"
+             (symbol->string (RaiseUnimplementedPrimitiveError!-name op)))]
+    
+    
+    [(InstallModuleEntry!? op)
+     (format "MACHINE.modules[~s]=new RUNTIME.ModuleRecord(~s, ~a);"
+             (symbol->string (ModuleLocator-name (InstallModuleEntry!-path op)))
+             (symbol->string (InstallModuleEntry!-name op))
+             (assemble-label (make-Label (InstallModuleEntry!-entry-point op))))]
+
+    [(MarkModuleInvoked!? op)
+     (format "MACHINE.modules[~s].isInvoked = true;"
+             (symbol->string (ModuleLocator-name (MarkModuleInvoked!-path op))))]
+
+
+    [(AliasModuleAsMain!? op)
+     (format "MACHINE.mainModules.push(MACHINE.modules[~s]);"
+             (symbol->string (ModuleLocator-name (AliasModuleAsMain!-from op))))]
+
+    [(FinalizeModuleInvokation!? op)
+     (format "MACHINE.modules[~s].finalizeModuleInvokation();"
+             (symbol->string
+              (ModuleLocator-name (FinalizeModuleInvokation!-path op))))]))

js-assembler/assemble-structs.rkt

@@ -13,8 +13,3 @@
 (define-struct: BasicBlock ([name : Symbol] 
                             [stmts : (Listof UnlabeledStatement)]) 
   #:transparent)
-
-
-
-;; Represents a hashtable from symbols to basic blocks
-(define-type Blockht (HashTable Symbol BasicBlock))

js-assembler/assemble.rkt

@@ -0,0 +1,315 @@
+#lang typed/racket/base
+(require "assemble-structs.rkt"
+         "assemble-helpers.rkt"
+         "assemble-open-coded.rkt"
+         "assemble-expression.rkt"
+         "assemble-perform-statement.rkt"
+         "collect-jump-targets.rkt"
+         "../compiler/il-structs.rkt"
+         "../compiler/lexical-structs.rkt"
+         "../compiler/expression-structs.rkt"
+         "../helpers.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 #f))
+
+
+
+
+(: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
+;; Writes out the JavaScript code that represents the anonymous invocation expression.
+;; What's emitted is a function expression that, when invoked, runs the
+;; statements.
+(define (assemble/write-invoke stmts op)
+  (fprintf op "(function(MACHINE, success, fail, params) {\n")
+  (fprintf op "var param;\n")
+  (fprintf op "var RUNTIME = plt.runtime;\n")
+  (let: ([basic-blocks : (Listof BasicBlock) (fracture stmts)])
+        (for-each
+         (lambda: ([basic-block : BasicBlock])
+                  (displayln (assemble-basic-block basic-block) op)
+                  (newline op))
+         basic-blocks)
+        (write-linked-label-attributes stmts op)
+        
+        (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); })"
+                 (assemble-label (make-Label (BasicBlock-name (first basic-blocks)))))))
+
+
+
+
+;; fracture: (listof stmt) -> (listof basic-block)
+(: fracture ((Listof Statement) -> (Listof BasicBlock)))
+(define (fracture stmts)
+  (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
+                                               (symbol? (first stmts)))
+                                          (first stmts)
+                                          (make-label 'start))]
+          [stmts : (Listof Statement) (if (and (not (empty? stmts))
+                                               (symbol? (first stmts)))
+                                          (rest stmts)
+                                          stmts)]
+          [jump-targets : (Listof Symbol)
+                        (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 : Statement (car stmts)])
+                        (: do-on-label (Symbol -> (Listof BasicBlock)))
+                        (define (do-on-label label-name)
+                          (cond
+                            [(member label-name jump-targets)
+                             (loop label-name
+                                   '()
+                                   (cons (make-BasicBlock 
+                                          name  
+                                          (if last-stmt-goto? 
+                                              (reverse acc)
+                                              (reverse (append `(,(make-GotoStatement (make-Label label-name)))
+                                                               acc))))
+                                         basic-blocks)
+                                   (cdr stmts)
+                                   last-stmt-goto?)]
+                            [else
+                             (loop name
+                                   acc
+                                   basic-blocks
+                                   (cdr stmts)
+                                   last-stmt-goto?)]))
+                        (cond
+                          [(symbol? first-stmt)
+                           (do-on-label first-stmt)]
+                          [(LinkedLabel? first-stmt)
+                           (do-on-label (LinkedLabel-label first-stmt))]
+                          [else
+                           (loop name
+                                 (cons first-stmt acc)
+                                 basic-blocks
+                                 (cdr stmts)
+                                 (GotoStatement? (car stmts)))]))]))))
+
+
+(: write-linked-label-attributes ((Listof Statement) Output-Port -> 'ok))
+(define (write-linked-label-attributes stmts op)
+  (cond
+    [(empty? stmts)
+     'ok]
+    [else
+     (let: ([stmt : Statement (first stmts)])
+           
+           (define (next) (write-linked-label-attributes (rest stmts) op))
+           
+           (cond
+             [(symbol? stmt)
+              (next)]
+             [(LinkedLabel? stmt)
+              (fprintf op "~a.multipleValueReturn = ~a;\n" 
+                       (assemble-label (make-Label (LinkedLabel-label stmt)))
+                       (assemble-label (make-Label (LinkedLabel-linked-to stmt))))
+              (next)]
+             [(DebugPrint? stmt)
+              (next)]
+             [(AssignImmediateStatement? stmt)
+              (next)]
+             [(AssignPrimOpStatement? stmt)
+              (next)]
+             [(PerformStatement? stmt)
+              (next)]
+             [(TestAndBranchStatement? stmt)
+              (next)]
+             [(GotoStatement? stmt)
+              (next)]
+             [(PushEnvironment? stmt)
+              (next)]
+             [(PopEnvironment? stmt)
+              (next)]
+             [(PushImmediateOntoEnvironment? stmt)
+              (next)]
+             [(PushControlFrame/Generic? stmt)
+              (next)]
+             [(PushControlFrame/Call? stmt)
+              (next)]
+             [(PushControlFrame/Prompt? stmt)
+              (next)]
+             [(PopControlFrame? stmt)
+              (next)]
+             [(Comment? stmt)
+              (next)]))]))
+
+
+
+
+;; 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};"
+          (assemble-label (make-Label (BasicBlock-name a-basic-block)))
+          (assemble-label (make-Label (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
+     [(DebugPrint? stmt)
+      (format "MACHINE.params.currentOutputPort.writeDomNode(MACHINE, $('<span/>').text(~a));" (assemble-oparg (DebugPrint-value stmt)))]
+     [(AssignImmediateStatement? stmt)
+      (let: ([t : String (assemble-target (AssignImmediateStatement-target stmt))]
+             [v : OpArg (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)]
+              [jump : String (assemble-jump 
+                       (make-Label (TestAndBranchStatement-label stmt)))])
+             ;; to help localize type checks, we add a type annotation here.
+             (ann (cond
+                    [(TestFalse? test)
+                     (format "if (~a === false) { ~a }"
+                             (assemble-oparg (TestFalse-operand test))
+                             jump)]
+                    [(TestTrue? test)
+                     (format "if (~a !== false) { ~a }"
+                             (assemble-oparg (TestTrue-operand test))
+                             jump)]
+                    [(TestOne? test)
+                     (format "if (~a === 1) { ~a }"
+                             (assemble-oparg (TestOne-operand test))
+                             jump)]
+                    [(TestZero? test)
+                     (format "if (~a === 0) { ~a }"
+                             (assemble-oparg (TestZero-operand test))
+                             jump)]
+                    [(TestPrimitiveProcedure? test)
+                     (format "if (typeof(~a) === 'function') { ~a }"
+                             (assemble-oparg (TestPrimitiveProcedure-operand test))
+                             jump)]
+                    [(TestClosureArityMismatch? test)
+                     (format "if (! RUNTIME.isArityMatching((~a).arity, ~a)) { ~a }"
+                             (assemble-oparg (TestClosureArityMismatch-closure test))
+                             (assemble-oparg (TestClosureArityMismatch-n test))
+                             jump)])
+                  String))]
+     
+     [(GotoStatement? stmt)
+      (assemble-jump (GotoStatement-target stmt))]
+     
+     [(PushControlFrame/Generic? stmt)
+      "MACHINE.control.push(new RUNTIME.Frame());"]
+     
+     [(PushControlFrame/Call? stmt)
+      (format "MACHINE.control.push(new RUNTIME.CallFrame(~a, MACHINE.proc));" 
+              (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
+                    (cond
+                      [(symbol? label) 
+                       (assemble-label (make-Label label))]
+                      [(LinkedLabel? label) 
+                       (assemble-label (make-Label (LinkedLabel-label label)))])))]
+     
+     [(PushControlFrame/Prompt? stmt)
+      ;; fixme: use a different frame structure
+      (format "MACHINE.control.push(new RUNTIME.PromptFrame(~a, ~a));" 
+              (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
+                    (cond
+                      [(symbol? label) 
+                       (assemble-label (make-Label label))]
+                      [(LinkedLabel? label) 
+                       (assemble-label (make-Label (LinkedLabel-label label)))]))
+              
+              (let: ([tag : (U DefaultContinuationPromptTag OpArg)
+                          (PushControlFrame/Prompt-tag stmt)])
+                    (cond
+                      [(DefaultContinuationPromptTag? tag)
+                       (assemble-default-continuation-prompt-tag)]
+                      [(OpArg? tag)
+                       (assemble-oparg tag)])))]
+     
+     [(PopControlFrame? stmt)
+      "MACHINE.control.pop();"]
+     
+     [(PushEnvironment? stmt)
+      (if (= (PushEnvironment-n stmt) 0)
+          ""
+          (format "MACHINE.env.push(~a);" (string-join
+                                           (build-list (PushEnvironment-n stmt) 
+                                                       (lambda: ([i : Natural])
+                                                                (if (PushEnvironment-unbox? stmt)
+                                                                    "[undefined]"
+                                                                    "undefined")))
+                                           ", ")))]
+     [(PopEnvironment? stmt)
+      (let: ([skip : OpArg (PopEnvironment-skip stmt)])
+            (cond
+              [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
+               (format "MACHINE.env.length = MACHINE.env.length - ~a;"
+                       (assemble-oparg (PopEnvironment-n stmt)))]
+              [else
+               (format "MACHINE.env.splice(MACHINE.env.length - (~a + ~a), ~a);"
+                       (assemble-oparg (PopEnvironment-skip stmt))
+                       (assemble-oparg (PopEnvironment-n stmt))
+                       (assemble-oparg (PopEnvironment-n stmt)))]))]
+     
+     [(PushImmediateOntoEnvironment? stmt)
+      (format "MACHINE.env.push(~a);"
+              (let: ([val-string : String
+                                 (cond [(PushImmediateOntoEnvironment-box? stmt)
+                                        (format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)))]
+                                       [else
+                                        (assemble-oparg (PushImmediateOntoEnvironment-value stmt))])])
+                    val-string))]
+     [(Comment? stmt)
+      ;; TODO: maybe comments should be emitted as JavaScript comments.
+      ""])))
+
+
+(define-predicate natural? Natural)
+
+(: ensure-natural (Any -> Natural))
+(define (ensure-natural x)
+  (if (natural? x)
+      x
+      (error 'ensure-natural)))
+
+

js-assembler/collect-jump-targets.rkt

@@ -0,0 +1,189 @@
+#lang typed/racket/base
+(require "../compiler/expression-structs.rkt"
+         "../compiler/il-structs.rkt"
+	 "../compiler/lexical-structs.rkt"
+	 "../helpers.rkt"
+	 racket/list)
+
+(provide collect-general-jump-targets)
+
+
+
+
+(: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol)))
+;; collects all the labels that are potential targets for GOTOs or branches.
+(define (collect-general-jump-targets stmts)
+  (unique/eq?
+   (let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
+         (cond [(empty? stmts)
+                empty]
+               [else
+                (let: ([stmt : Statement (first stmts)])
+		      (append (collect-statement stmt)
+			      (loop (rest stmts))))]))))
+
+
+
+
+
+(: collect-statement (Statement -> (Listof Symbol)))
+(define (collect-statement stmt)
+  (cond
+   [(symbol? stmt)
+    empty]
+   [(LinkedLabel? stmt)
+    (list (LinkedLabel-label stmt)
+	  (LinkedLabel-linked-to stmt))]
+   [(DebugPrint? stmt)
+    empty]
+   [(AssignImmediateStatement? stmt)
+    (let: ([v : OpArg (AssignImmediateStatement-value stmt)])
+	  (collect-input v))]
+   [(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-input (GotoStatement-target stmt))]
+   [(PushEnvironment? stmt)
+    empty]
+   [(PopEnvironment? stmt)
+    empty]
+   [(PushImmediateOntoEnvironment? stmt)
+    (collect-input (PushImmediateOntoEnvironment-value stmt))]
+   [(PushControlFrame/Generic? stmt)
+    empty]
+   [(PushControlFrame/Call? stmt)
+    (label->labels (PushControlFrame/Call-label stmt))]
+   [(PushControlFrame/Prompt? stmt)
+    (label->labels (PushControlFrame/Prompt-label stmt))]
+   [(PopControlFrame? stmt)
+    empty]
+   [(Comment? stmt)
+    empty]))
+
+
+
+(: 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]
+   [(SubtractArg? an-input)
+    (append (collect-input (SubtractArg-lhs an-input))
+	    (collect-input (SubtractArg-rhs an-input)))]
+   [(ControlStackLabel? an-input)
+    empty]
+   [(ControlStackLabel/MultipleValueReturn? an-input)
+    empty]
+   [(ControlFrameTemporary? an-input)
+    empty]
+   [(CompiledProcedureEntry? an-input)
+    (collect-input (CompiledProcedureEntry-proc an-input))]
+   [(CompiledProcedureClosureReference? an-input)
+    (collect-input (CompiledProcedureClosureReference-proc an-input))]
+   [(PrimitiveKernelValue? an-input)
+    empty]
+   [(ModuleEntry? an-input)
+    empty]
+   [(IsModuleInvoked? an-input)
+    empty]
+   [(IsModuleLinked? an-input)
+    empty]
+   [(VariableReference? 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]
+   [(CaptureEnvironment? op)
+    empty]
+   [(CaptureControl? op)
+    empty]
+   [(MakeBoxedEnvironmentValue? op)
+    empty]
+   [(CallKernelPrimitiveProcedure? op)
+    empty]))
+
+(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
+(define (collect-primitive-command op)
+  (cond
+   [(InstallModuleEntry!? op)
+    (list (InstallModuleEntry!-entry-point op))]
+   [else
+    empty]
+   ;; currently written this way because I'm hitting some bad type-checking behavior.
+   #;([(CheckToplevelBound!? op)
+      empty]
+     [(CheckClosureArity!? op)
+      empty]
+     [(CheckPrimitiveArity!? op)
+      empty]
+     [(ExtendEnvironment/Prefix!? op)
+      empty]
+     [(InstallClosureValues!? op)
+      empty]
+     [(RestoreEnvironment!? op)
+      empty]
+     [(RestoreControl!? op)
+      empty]
+     [(SetFrameCallee!? op)
+      empty]
+     [(SpliceListIntoStack!? op)
+      empty]
+     [(UnspliceRestFromStack!? op)
+      empty]
+     [(FixClosureShellMap!? op)
+      empty]
+     [(InstallContinuationMarkEntry!? op)
+      empty]
+     [(RaiseContextExpectedValuesError!? op)
+      empty]
+     [(RaiseArityMismatchError!? op)
+      empty]
+     [(RaiseOperatorApplicationError!? op)
+      empty])))
+
+
+
+
+
+
+(: label->labels ((U Symbol LinkedLabel) -> (Listof Symbol)))
+(define (label->labels label)
+  (cond
+   [(symbol? label)
+    (list label)]
+   [(LinkedLabel? label)
+    (list (LinkedLabel-label label)
+	  (LinkedLabel-linked-to label))]))
+

js-assembler/get-js-vm-implemented-primitives.rkt

@@ -6,9 +6,9 @@
          racket/list)
 ;; Get the list of primitives implemented in js-vm-primitives.js
 
-;; (define-runtime-path js-vm-primitives.js "runtime-src/js-vm-primitives.js")
+(define-runtime-path js-vm-primitives.js "runtime-src/js-vm-primitives.js")
 
-(define-runtime-path whalesong-primitives.js "runtime-src/baselib-primitives.js")
+(define-runtime-path whalesong-primitives.js "runtime-src/runtime.js")
 
 ;; sort&unique: (listof string) -> (listof string)
 (define (sort&unique names)
@@ -19,16 +19,16 @@
             name)
           string<?)))
         
-;; ;; primitive-names: (listof symbol)
-;; (define js-vm-primitive-names
-;;   (map string->symbol
-;;        (sort&unique
-;;         (map (lambda (a-str)
-;;                (substring a-str
-;;                           (string-length "PRIMITIVES['")
-;;                           (- (string-length a-str) (string-length "']"))))
-;;              (let ([contents (file->string js-vm-primitives.js)])
-;;                (regexp-match* #px"PRIMITIVES\\[('|\")[^\\]]*('|\")\\]" contents))))))
+;; primitive-names: (listof symbol)
+(define js-vm-primitive-names
+  (map string->symbol
+       (sort&unique
+        (map (lambda (a-str)
+               (substring a-str
+                          (string-length "PRIMITIVES['")
+                          (- (string-length a-str) (string-length "']"))))
+             (let ([contents (file->string js-vm-primitives.js)])
+               (regexp-match* #px"PRIMITIVES\\[('|\")[^\\]]*('|\")\\]" contents))))))
 
 
 
@@ -43,5 +43,5 @@
                (regexp-match* #px"installPrimitiveProcedure\\(\\s+('|\")[^\\']*('|\")" contents))))))
 
      
-(provide/contract ;[js-vm-primitive-names (listof symbol?)]
+(provide/contract [js-vm-primitive-names (listof symbol?)]
                   [whalesong-primitive-names (listof symbol?)])

js-assembler/get-runtime.rkt

@@ -0,0 +1,102 @@
+#lang racket/base
+
+;; Function to get the runtime library.
+;;
+;; The resulting Javascript will produce a file that loads:
+;;
+;;
+;; jquery at the the toplevel
+;; HashTable at the toplevel
+;; jsnums at the toplevel
+;;
+;; followed by:
+;;
+;;     plt.link
+;;     plt.helpers
+;;     plt.types
+;;     plt.primitives
+;;     plt.runtime
+
+
+
+(require racket/contract
+         racket/runtime-path
+         racket/port)
+
+
+
+(provide/contract [get-runtime (-> string?)])
+
+;; jquery is special: we need to make sure it's resilient against
+;; multiple invokation and inclusion.
+(define-runtime-path jquery-protect-header.js "runtime-src/jquery-protect-header.js")
+(define-runtime-path jquery.js "runtime-src/jquery.js")
+(define-runtime-path jquery-protect-footer.js "runtime-src/jquery-protect-footer.js")
+
+
+(define-runtime-path baselib.js "runtime-src/baselib.js")
+(define-runtime-path baselib_unionfind.js "runtime-src/baselib_unionfind.js")
+(define-runtime-path baselib_hash.js "runtime-src/baselib_hash.js")
+(define-runtime-path baselib_symbol.js "runtime-src/baselib_symbol.js")
+(define-runtime-path baselib_structs.js "runtime-src/baselib_structs.js")
+(define-runtime-path baselib_arity.js "runtime-src/baselib_arity.js")
+(define-runtime-path baselib_inspectors.js "runtime-src/baselib_inspectors.js")
+(define-runtime-path baselib_exceptions.js "runtime-src/baselib_exceptions.js")
+
+
+(define-runtime-path jshashtable.js "runtime-src/jshashtable-2.1_src.js")
+(define-runtime-path jsnums.js "runtime-src/js-numbers.js")
+(define-runtime-path link.js "runtime-src/link.js")
+
+;; from js-vm
+(define-runtime-path helpers.js "runtime-src/helpers.js")
+;; from js-vm
+(define-runtime-path types.js "runtime-src/types.js")
+;; These primitives were coded for the js-vm project, and we'll gradually
+;; absorb them in.
+;(define-runtime-path js-vm-primitives.js "runtime-src/js-vm-primitives.js")
+
+(define-runtime-path runtime.js "runtime-src/runtime.js")
+
+
+;; The order matters here.  link needs to come near the top, because
+;; the other modules below have some circular dependencies that are resolved
+;; by link.
+(define files (list jquery-protect-header.js
+                    jquery.js
+                    jquery-protect-footer.js
+                    
+                    jshashtable.js
+                    jsnums.js
+                   
+                    baselib.js
+                    baselib_unionfind.js
+                    baselib_hash.js
+                    baselib_symbol.js
+                    baselib_structs.js
+                    baselib_arity.js
+                    baselib_inspectors.js
+                    baselib_exceptions.js
+
+                    
+
+                    link.js
+                    helpers.js
+                    types.js
+;                    js-vm-primitives.js
+                    runtime.js))
+
+
+
+(define (path->string p)
+  (call-with-input-file p
+                (lambda (ip)
+                  (port->string ip))))
+
+
+(define text (apply string-append
+                    (map path->string files)))
+
+
+(define (get-runtime)
+  text)

js-assembler/package.rkt

@@ -0,0 +1,352 @@
+#lang racket/base
+
+(require "assemble.rkt"
+         "quote-cdata.rkt"
+         "../make/make.rkt"
+         "../make/make-structs.rkt"
+         "../parameters.rkt"
+         "../compiler/expression-structs.rkt"
+         "../parser/path-rewriter.rkt"
+         "../parser/parse-bytecode.rkt"
+         racket/match
+         (prefix-in query: "../lang/js/query.rkt")
+         (planet dyoo/closure-compile:1:1)
+         (prefix-in runtime: "get-runtime.rkt")
+         (prefix-in racket: racket/base))
+
+
+;; TODO: put proper contracts here
+
+
+(provide package
+         package-anonymous
+         package-standalone-xhtml
+         get-standalone-code
+         write-standalone-code
+         get-runtime
+         write-runtime)
+
+
+
+;; notify: string (listof any)* -> void
+;; Print out log message during the build process.
+(define (notify msg . args)
+  (displayln (apply format msg args)))
+
+
+
+
+
+(define-struct js-impl (name ;; symbol
+                        real-path ;; path
+                        src ;; string
+                        )
+  #:transparent)
+
+
+;; Packager: produce single .js files to be included to execute a
+;; program.
+
+
+
+(define (package-anonymous source-code
+                           #:should-follow-children? should-follow?
+                           #:output-port op)  
+  (fprintf op "(function() {\n")
+  (package source-code
+           #:should-follow-children? should-follow?
+           #:output-port op)
+  (fprintf op " return invoke; })\n"))
+
+
+
+;; source-is-javascript-module?: Source -> boolean
+;; Returns true if the source looks like a Javascript-implemented module.
+(define (source-is-javascript-module? src)
+  (cond
+   [(StatementsSource? src)
+    #f]
+   [(MainModuleSource? src)
+    (source-is-javascript-module? (MainModuleSource-source src))]
+   [(ModuleSource? src)
+    (query:has-javascript-implementation? `(file ,(path->string (ModuleSource-path src))))]
+   [(SexpSource? src)
+    #f]
+   [(UninterpretedSource? src)
+    #f]))
+
+
+;; get-javascript-implementation: source -> UninterpretedSource
+(define (get-javascript-implementation src)
+
+  (define (get-provided-name-code bytecode)
+    (match bytecode
+      [(struct Top [_ (struct Module (name path prefix requires provides code))])
+       (apply string-append
+              (map (lambda (p)
+                     (format "modrec.namespace[~s] = exports[~s];\n"
+                             (symbol->string (ModuleProvide-internal-name p))
+                             (symbol->string (ModuleProvide-external-name p))))
+                   provides))]
+      [else
+       ""]))
+  (cond
+   [(StatementsSource? src)
+    (error 'get-javascript-implementation src)]
+   [(MainModuleSource? src)
+    (get-javascript-implementation (MainModuleSource-source src))]
+   [(ModuleSource? src)
+    (let ([name (rewrite-path (ModuleSource-path src))]
+          [text (query:query `(file ,(path->string (ModuleSource-path src))))]
+          [bytecode (parse-bytecode (ModuleSource-path src))])
+      (make-UninterpretedSource
+       (format "
+MACHINE.modules[~s] =
+    new plt.runtime.ModuleRecord(~s,
+        function(MACHINE) {
+           if(--MACHINE.callsBeforeTrampoline<0) { throw arguments.callee; }
+           var modrec = MACHINE.modules[~s];
+           var exports = {};
+           modrec.isInvoked = true;
+           (function(MACHINE, RUNTIME, EXPORTS){~a})(MACHINE, plt.runtime, exports);
+           // FIXME: we need to inject the namespace with the values defined in exports.
+           ~a
+           return MACHINE.control.pop().label(MACHINE);
+        });
+"
+                  (symbol->string name)
+                  (symbol->string name)
+                  (symbol->string name)
+                  text
+                  (get-provided-name-code bytecode))))]
+   [(SexpSource? src)
+    (error 'get-javascript-implementation)]
+   [(UninterpretedSource? src)
+    (error 'get-javascript-implementation)]))
+
+        
+
+
+
+
+
+
+;; package: Source (path -> boolean) output-port -> void
+
+;; Compile package for the given source program.
+;;
+;; should-follow-children?  indicates whether we should continue
+;; following module paths of a source's dependencies.
+;;
+;; The generated output defines a function called 'invoke' with
+;; four arguments (MACHINE, SUCCESS, FAIL, PARAMS).  When called, it will
+;; execute the code to either run standalone expressions or
+;; load in modules.
+(define (package source-code
+                 #:should-follow-children? should-follow?
+                 #:output-port op)  
+
+  
+  ;; wrap-source: source -> source
+  ;; Translate all JavaScript-implemented sources into uninterpreted sources;
+  ;; we'll leave its interpretation to on-visit-src.
+  (define (wrap-source src)
+    (cond
+     [(source-is-javascript-module? src)
+      (get-javascript-implementation src)]
+     [else
+      src]))
+
+  
+  (define (on-visit-src src ast stmts)
+    (cond
+     [(UninterpretedSource? src)
+      (fprintf op (UninterpretedSource-datum src))]
+     [else
+      (assemble/write-invoke stmts op)
+      (fprintf op "(MACHINE, function() { ")]))
+
+
+  (define (after-visit-src src ast stmts)
+    (cond
+     [(UninterpretedSource? src)
+      (void)]
+     [else
+      (fprintf op " }, FAIL, PARAMS);")]))
+
+
+  (define (on-last-src)
+    (fprintf op "SUCCESS();"))
+  
+
+  (define packaging-configuration
+    (make-Configuration
+     wrap-source
+     
+     should-follow?
+
+     ;; on
+     on-visit-src
+
+     ;; after
+     after-visit-src
+     
+     ;; last
+     on-last-src))
+
+  
+    (fprintf op "var invoke = (function(MACHINE, SUCCESS, FAIL, PARAMS) {")
+    (fprintf op "    plt.runtime.ready(function() {")
+    (make (list (make-MainModuleSource source-code))
+          packaging-configuration)
+    (fprintf op "    });");
+    (fprintf op "});\n"))
+
+
+
+
+;; package-standalone-xhtml: X output-port -> void
+(define (package-standalone-xhtml source-code op)
+  (display *header* op)
+  (display (quote-cdata (get-runtime)) op)
+  (display (quote-cdata (get-code source-code)) op)
+  (display *footer* op))
+
+
+
+;; write-runtime: output-port -> void
+(define (write-runtime op)
+  
+  (define (wrap-source src) src)
+  (let ([packaging-configuration
+         (make-Configuration
+
+          wrap-source
+          
+          ;; should-follow-children?
+          (lambda (src) #t)
+          ;; on
+          (lambda (src ast stmts)
+            (assemble/write-invoke stmts op)
+            (fprintf op "(MACHINE, function() { "))
+          
+          ;; after
+          (lambda (src ast stmts)
+            (fprintf op " }, FAIL, PARAMS);"))
+          
+          ;; last
+          (lambda ()
+            (fprintf op "SUCCESS();")))])
+
+    (display (runtime:get-runtime) op)
+
+    (newline op)
+    (fprintf op "(function(MACHINE, SUCCESS, FAIL, PARAMS) {")
+    (make (list only-bootstrapped-code) packaging-configuration)
+    (fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n")))
+
+
+
+(define (compress x)
+  (if (current-compress-javascript?)
+      (closure-compile x)
+      x))
+
+
+
+(define *the-runtime*
+  (let ([buffer (open-output-string)])
+    (write-runtime buffer)
+    (compress
+     (get-output-string buffer))))
+
+  
+;; get-runtime: -> string
+(define (get-runtime)
+  *the-runtime*)
+
+
+
+
+
+;; *header* : string
+(define *header*
+  #<<EOF
+<!DOCTYPE html>
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
+  <head>
+    <meta charset="utf-8"/>
+    <title>Example</title>
+  </head>
+  <script>
+
+EOF
+)
+
+
+;; get-code: source -> string
+(define (get-code source-code)
+  (let ([buffer (open-output-string)])
+    (package source-code
+             #:should-follow-children? (lambda (src) #t)
+             #:output-port buffer)
+    (compress
+     (get-output-string buffer))))
+
+
+
+;; get-standalone-code: source -> string
+(define (get-standalone-code source-code)
+  (let ([buffer (open-output-string)])
+    (write-standalone-code source-code buffer)
+    (compress
+     (get-output-string buffer))))
+
+
+;; write-standalone-code: source output-port -> void
+(define (write-standalone-code source-code op)
+  (package-anonymous source-code
+                     #:should-follow-children? (lambda (src) #t)
+                     #:output-port op)
+  (fprintf op "()(plt.runtime.currentMachine, function() {}, function() {}, {});\n"))
+
+
+
+
+(define *footer*
+  #<<EOF
+
+<![CDATA[
+var invokeMainModule = function() {
+    var MACHINE = plt.runtime.currentMachine;
+    invoke(MACHINE,
+           function() {
+                plt.runtime.invokeMains(
+                    MACHINE,
+                    function() {
+                        // On main module invokation success
+                    },
+                    function(MACHINE, e) {
+                        // On main module invokation failure
+                        if (console && console.log) {
+                            console.log(e.stack || e);
+                        }
+                        MACHINE.params.currentErrorDisplayer(
+                             MACHINE, $(plt.helpers.toDomNode(e.stack || e)).css('color', 'red'));
+                    })},
+           function() {
+               // On module loading failure
+               if (console && console.log) {
+                   console.log(e.stack || e);
+               }                       
+           },
+           {});
+};
+  
+  $(document).ready(invokeMainModule);
+]]>
+  </script>
+  <body></body>
+</html>
+EOF
+)

js-assembler/runtime-src/baselib.js

@@ -0,0 +1,24 @@
+// Skeleton for basic library functions
+if (! this['plt']) { this['plt'] = {}; }
+(function (plt) {
+    var baselib = {};
+    plt['baselib'] = baselib;
+
+
+
+
+
+    // Inheritance.
+    var heir = function(parentPrototype) {
+	var f = function() {}
+	f.prototype = parentPrototype;
+	return new f();
+    };
+
+
+
+
+    baselib.heir = heir;
+
+
+})(this['plt']);

js-assembler/runtime-src/baselib_arity.js

@@ -1,14 +1,11 @@
-/*jslint browser: false, unparam: true, vars: true, white: true, plusplus: true, maxerr: 50, indent: 4 */
-
 // Arity structure
 (function(baselib) {
-    'use strict';
     var exports = {};
     baselib.arity = exports;
 
 
 
-    var ArityAtLeast = baselib.structs.makeStructureType(
+    var ArityAtLeast = plt.baselib.structs.makeStructureType(
         'arity-at-least', false, 1, 0, false, false);
 
 
@@ -21,7 +18,7 @@
     var arityAtLeastValue = function(x) { 
         var val = ArityAtLeast.accessor(x, 0);
         return val;
-    };
+    }
 
 
     ArityAtLeast.type.prototype.toString = function() {
@@ -38,17 +35,17 @@
 	} else if (isArityAtLeast(arity)) {
 	    return n >= arityAtLeastValue(arity);
 	} else {
-	    while (arity !== baselib.lists.EMPTY) {
+	    while (arity !== plt.types.EMPTY) {
 		if (typeof(arity.first) === 'number') {
 		    if (arity.first === n) { return true; }
-		} else if (isArityAtLeast(arity.first)) {
+		} else if (isArityAtLeast(arity)) {
 		    if (n >= arityAtLeastValue(arity.first)) { return true; }
 		}
 		arity = arity.rest;
 	    }
 	    return false;
 	}
-    };
+    }
 
 
 
@@ -57,12 +54,12 @@
     //////////////////////////////////////////////////////////////////////
 
     exports.ArityAtLeast = ArityAtLeast;
-    exports.makeArityAtLeast = function() { 
-        var args = [].slice.call(arguments);
-        return ArityAtLeast.constructor(args);
+    exports.arityAtLeast = function() { 
+        var result =  ArityAtLeast.constructor.apply(null, arguments);
+        return result;
     };
     exports.isArityAtLeast = isArityAtLeast;
     exports.isArityMatching = isArityMatching;
     exports.arityAtLeastValue = arityAtLeastValue;
 
-}(this.plt.baselib));
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib_exceptions.js

@@ -0,0 +1,133 @@
+// Exceptions
+
+(function(baselib) {
+    var exceptions = {};
+    baselib.exceptions = exceptions;
+
+
+
+    // Error type exports
+    var InternalError = function(val, contMarks) {
+	this.val = val;
+	this.contMarks = (contMarks ? contMarks : false);
+    }
+
+
+    var SchemeError = function(val) {
+	this.val = val;
+    }
+
+
+    var IncompleteExn = function(constructor, msg, otherArgs) {
+	this.constructor = constructor;
+	this.msg = msg;
+	this.otherArgs = otherArgs;
+    };
+
+
+    var Exn = plt.baselib.structs.makeStructureType(
+        'exn', 
+        false, 
+        2, 
+        0,
+        false,
+	function(args, name, k) {
+// 	    helpers.check(args[0], isString, name, 'string', 1);
+// 	    helpers.check(args[1], types.isContinuationMarkSet,
+//                           name, 'continuation mark set', 2);
+	    return k(args);
+	});
+
+    // (define-struct (exn:break exn) (continuation))
+    var ExnBreak = plt.baselib.structs.makeStructureType(
+        'exn:break', Exn, 1, 0, false,
+	function(args, name, k) {
+// 	    helpers.check(args[2], function(x) { return x instanceof ContinuationClosureValue; },
+// 			  name, 'continuation', 3);
+	    return k(args);
+	});
+
+    var ExnFail =
+        plt.baselib.structs.makeStructureType('exn:fail', 
+                                              Exn, 0, 0, false, false);
+
+    var ExnFailContract =
+        plt.baselib.structs.makeStructureType('exn:fail:contract',
+                                              ExnFail, 0, 0, false, false);
+
+    var ExnFailContractArity = 
+        plt.baselib.structs.makeStructureType('exn:fail:contract:arity', 
+                                              ExnFailContract, 0, 0, false, false);
+
+    var ExnFailContractVariable =
+        plt.baselib.structs.makeStructureType('exn:fail:contract:variable', 
+                                              ExnFailContract, 1, 0, false, false);
+
+    var ExnFailContractDivisionByZero = 
+        plt.baselib.structs.makeStructureType('exn:fail:contract:divide-by-zero',
+                                              ExnFailContract, 0, 0, false, false);
+
+
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+    // Exports
+
+    exceptions.InternalError = InternalError;
+    exceptions.internalError = function(v, contMarks) { return new InternalError(v, contMarks); };
+    exceptions.isInternalError = function(x) { return x instanceof InternalError; };
+
+
+    exceptions.SchemeError = SchemeError;
+    exceptions.schemeError = function(v) { return new SchemeError(v); };
+    exceptions.isSchemeError = function(v) { return v instanceof SchemeError; };
+
+
+    exceptions.IncompleteExn = IncompleteExn;
+    exceptions.incompleteExn = function(constructor, msg, args) { return new IncompleteExn(constructor, msg, args); };
+    exceptions.isIncompleteExn = function(x) { return x instanceof IncompleteExn; };
+
+
+    exceptions.Exn = Exn;
+    exceptions.exn = Exn.constructor;
+    exceptions.isExn = Exn.predicate;
+    exceptions.exnMessage = function(exn) { return Exn.accessor(exn, 0); };
+    exceptions.exnContMarks = function(exn) { return Exn.accessor(exn, 1); };
+    exceptions.exnSetContMarks = function(exn, v) { Exn.mutator(exn, 1, v); };
+
+    exceptions.ExnBreak = ExnBreak;
+    exceptions.exnBreak = ExnBreak.constructor;
+    exceptions.isExnBreak = ExnBreak.predicate;
+    exceptions.exnBreakContinuation = 
+        function(exn) { return ExnBreak.accessor(exn, 0); };
+
+    exceptions.ExnFail = ExnFail;
+    exceptions.exnFail = ExnFail.constructor;
+    exceptions.isExnFail = ExnFail.predicate;
+
+    exceptions.ExnFailContract = ExnFailContract;
+    exceptions.exnFailContract = ExnFailContract.constructor;
+    exceptions.isExnFailContract = ExnFailContract.predicate;
+
+    exceptions.ExnFailContractArity = ExnFailContractArity;
+    exceptions.exnFailContractArity = ExnFailContractArity.constructor;
+    exceptions.isExnFailContractArity = ExnFailContractArity.predicate;
+
+    exceptions.ExnFailContractVariable = ExnFailContractVariable;
+    exceptions.exnFailContractVariable = ExnFailContractVariable.constructor;
+    exceptions.isExnFailContractVariable = ExnFailContractVariable.predicate;
+    exceptions.exnFailContractVariableId = 
+        function(exn) { return ExnFailContractVariable.accessor(exn, 0); };
+
+
+    exceptions.ExnFailContractDivisionByZero = ExnFailContractDivisionByZero;
+    exceptions.exnFailContractDivisionByZero = ExnFailContractDivisionByZero.constructor;
+    exceptions.isExnFailContractDivisionByZero = ExnFailContractDivisionByZero.predicate;
+
+
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib_hash.js

@@ -0,0 +1,52 @@
+
+(function(baselib) {
+    var hash = {};
+
+    baselib.hash = hash;
+
+
+    
+    var _eqHashCodeCounter = 0;
+    var makeEqHashCode = function() {
+	_eqHashCodeCounter++;
+	return _eqHashCodeCounter;
+    };
+
+
+    // getHashCode: any -> (or fixnum string)
+    // Given a value, produces a hashcode appropriate for eq.
+    var getEqHashCode = function(x) {
+	if (typeof(x) === 'string') {
+	    return x;
+	}
+	if (typeof(x) === 'number') {
+	    return String(x);
+	}
+	if (x && !x._eqHashCode) {
+	    x._eqHashCode = makeEqHashCode();
+	}
+	if (x && x._eqHashCode) {
+	    return x._eqHashCode;
+	}
+	return 0;
+    };
+
+
+    // Creates a low-level hashtable, following the interface of 
+    // http://www.timdown.co.uk/jshashtable/
+    //
+    // Defined to use the getEqHashCode defined in baselib_hash.js.
+    var makeLowLevelEqHash = function() {
+	return new Hashtable(function(x) { return getEqHashCode(x); },
+			     function(x, y) { return x === y; });
+    };
+
+
+
+    hash.getEqHashCode = getEqHashCode;
+    hash.makeEqHashCode = makeEqHashCode;
+    hash.makeLowLevelEqHash = makeLowLevelEqHash;
+
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib_inspectors.js

@@ -0,0 +1,22 @@
+// Structure types
+
+(function(baselib) {
+    var exports = {};
+    baselib.inspectors = exports;
+
+
+    var Inspector = function() {
+    };
+    var DEFAULT_INSPECTOR = new Inspector();
+
+    Inspector.prototype.toString = function() {
+        return "#<inspector>";
+    };
+
+
+
+    exports.Inspector = Inspector;
+    exports.DEFAULT_INSPECTOR = DEFAULT_INSPECTOR;
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib_structs.js

@@ -0,0 +1,292 @@
+// Structure types
+
+(function(baselib) {
+    var structs = {};
+    baselib.structs = structs;
+
+
+
+
+
+
+    var StructType = function(name,             // string
+                              type,             // StructType
+                              numberOfArgs,     // number
+                              numberOfFields,   // number
+                              firstField,
+		              applyGuard,
+                              constructor,
+                              predicate, 
+                              accessor,
+                              mutator) {
+	this.name = name;
+	this.type = type;
+	this.numberOfArgs = numberOfArgs;
+	this.numberOfFields = numberOfFields;
+	this.firstField = firstField;
+
+	this.applyGuard = applyGuard;
+	this.constructor = constructor;
+	this.predicate = predicate;
+	this.accessor = accessor;
+	this.mutator = mutator;
+    };
+
+
+    StructType.prototype.toString = function(cache) {
+	return '#<struct-type:' + this.name + '>';
+    };
+
+
+    StructType.prototype.equals = function(other, aUnionFind) {
+	return this === other;
+    };
+
+
+
+
+
+    // guard-function: array string (array -> value)
+
+
+
+
+
+    // makeStructureType: string StructType number number boolean
+    //                    guard-function -> StructType
+    //
+    // Creates a new structure type.
+
+    var makeStructureType = function(theName,
+                                     parentType, 
+                                     initFieldCnt, 
+                                     autoFieldCnt, 
+                                     autoV, 
+                                     guard) {
+
+	// If no parent type given, then the parent type is Struct
+        parentType = parentType || DEFAULT_PARENT_TYPE;
+        guard = guard || DEFAULT_GUARD;
+
+
+
+        // rawConstructor creates a new struct type inheriting from
+        // the parent, with no guard checks.
+        var rawConstructor = function(name, args) {
+	    parentType.type.call(this, name, args);
+	    for (var i = 0; i < initFieldCnt; i++) {
+	        this._fields.push(args[i+parentType.numberOfArgs]);
+	    }
+	    for (var i = 0; i < autoFieldCnt; i++) {
+	        this._fields.push(autoV);
+	    }
+        };
+        rawConstructor.prototype = baselib.heir(parentType.type.prototype);
+
+
+
+	// Set type, necessary for equality checking
+        rawConstructor.prototype.type = rawConstructor;
+
+	// The structure type consists of the name, its constructor, a
+        // record of how many argument it and its parent type contains,
+        // the list of autofields, the guard, and functions corresponding
+        // to the constructor, the predicate, the accessor, and mutators.
+	var newType = new StructType(
+            theName,
+	    rawConstructor,
+	    initFieldCnt + parentType.numberOfArgs,
+	    initFieldCnt + autoFieldCnt,
+	    parentType.firstField + parentType.numberOfFields,
+	    function(args, name, k) {
+		return guard(args, name,
+			     function(result) {
+				 var parentArgs = result.slice(0, parentType.numberOfArgs);
+				 var restArgs = result.slice(parentType.numberOfArgs);
+				 return parentType.applyGuard(
+                                     parentArgs, name,
+				     function(parentRes) {
+                                         return k( parentRes.concat(restArgs) ); });
+			     });
+	    },
+            // constructor
+	    function() {
+		var args = [].slice.call(arguments);
+		return newType.applyGuard(
+                    args,
+		    baselib.Symbol.makeInstance(theName),
+		    function(res) { 
+                        return new rawConstructor(theName, res); });
+	    },
+
+            // predicate
+	    function(x) { 
+		return x instanceof rawConstructor; 
+	    },
+
+            // accessor
+	    function(x, i) { return x._fields[i + this.firstField]; },
+
+            // mutator
+	    function(x, i, v) { x._fields[i + this.firstField] = v; });
+	return newType;
+    };
+
+
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+
+
+    var Struct = function(constructorName, fields) {
+	this._constructorName = constructorName; 
+	this._fields = [];
+    };
+
+    Struct.prototype.toWrittenString = function(cache) { 
+	cache.put(this, true);
+	var buffer = [];
+	buffer.push("(");
+	buffer.push(this._constructorName);
+	for(var i = 0; i < this._fields.length; i++) {
+	    buffer.push(" ");
+	    buffer.push(plt.helpers.toWrittenString(this._fields[i], cache));
+	}
+	buffer.push(")");
+	return buffer.join("");
+    };
+
+    Struct.prototype.toDisplayedString = function(cache) {
+	return plt.helpers.toWrittenString(this, cache); 
+    };
+
+    Struct.prototype.toDomNode = function(params) {
+	params.put(this, true);
+	var node = document.createElement("div");
+	$(node).append(document.createTextNode("("));
+	$(node).append(document.createTextNode(this._constructorName));
+	for(var i = 0; i < this._fields.length; i++) {
+	    $(node).append(document.createTextNode(" "));
+	    $(node).append(plt.helpers.toDomNode(this._fields[i], params));
+	}
+	$(node).append(document.createTextNode(")"));
+	return node;
+    };
+
+
+    Struct.prototype.equals = function(other, aUnionFind) {
+	if ( other.type == undefined ||
+	     this.type !== other.type ||
+	     !(other instanceof this.type) ) {
+	    return false;
+	}
+
+	for (var i = 0; i < this._fields.length; i++) {
+	    if (! equals(this._fields[i],
+			 other._fields[i],
+			 aUnionFind)) {
+		return false;
+	    }
+	}
+	return true;
+    }
+
+    Struct.prototype.type = Struct;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+//     // Struct Procedure types
+//     var StructProc = function(type, name, numParams, isRest, usesState, impl) {
+//         PrimProc.call(this, name, numParams, isRest, usesState, impl);
+//         this.type = type;
+//     };
+//     StructProc.prototype = baselib.heir(PrimProc.prototype);
+
+//     var StructConstructorProc = function() {
+//         StructProc.apply(this, arguments);
+//     };
+//     StructConstructorProc.prototype = baselib.heir(StructProc.prototype);
+
+//     var StructPredicateProc = function() {
+//         StructProc.apply(this, arguments);
+//     };
+//     StructPredicateProc.prototype = baselib.heir(StructProc.prototype);
+
+//     var StructAccessorProc = function() {
+//         StructProc.apply(this, arguments);
+//     };
+//     StructAccessorProc.prototype = baselib.heir(StructProc.prototype);
+
+//     var StructMutatorProc = function() {
+//         StructProc.apply(this, arguments);
+//     };
+//     StructMutatorProc.prototype = baselib.heir(StructProc.prototype);
+
+
+
+
+
+
+
+
+    // Default structure guard just calls the continuation argument.
+    var DEFAULT_GUARD = function(args, name, k) { 
+        return k(args); 
+    };
+
+
+    // The default parent type refers to the toplevel Struct.
+    var DEFAULT_PARENT_TYPE = { type: Struct,
+			        numberOfArgs: 0,
+			        numberOfFields: 0,
+			        firstField: 0,
+			        applyGuard: DEFAULT_GUARD };
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+    structs.StructType = StructType;
+    structs.Struct = Struct;
+
+
+//     structs.StructProc = StructProc;
+//     structs.StructConstructorProc = StructConstructorProc;
+//     structs.StructPredicateProc = StructPredicateProc;
+//     structs.StructAccessorProc = StructAccessorProc;
+//     structs.StructMutatorProc = StructMutatorProc;
+
+
+    structs.makeStructureType = makeStructureType;
+
+    
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib_symbol.js

@@ -0,0 +1,55 @@
+// Structure types
+
+(function(baselib) {
+
+
+
+    //////////////////////////////////////////////////////////////////////
+    
+    // Symbols
+
+    //////////////////////////////////////////////////////////////////////
+    var Symbol = function(val) {
+        this.val = val;
+    };
+
+    var symbolCache = {};
+    
+    // makeInstance: string -> Symbol.
+    Symbol.makeInstance = function(val) {
+        // To ensure that we can eq? symbols with equal values.
+        if (!(val in symbolCache)) {
+	    symbolCache[val] = new Symbol(val);
+        } else {
+        }
+        return symbolCache[val];
+    };
+    
+    Symbol.prototype.equals = function(other, aUnionFind) {
+        return other instanceof Symbol &&
+            this.val === other.val;
+    };
+    
+
+    Symbol.prototype.toString = function(cache) {
+        return this.val;
+    };
+
+    Symbol.prototype.toWrittenString = function(cache) {
+        return this.val;
+    };
+
+    Symbol.prototype.toDisplayedString = function(cache) {
+        return this.val;
+    };
+
+
+
+
+    baselib.Symbol = Symbol;
+
+
+
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib_unionfind.js

@@ -0,0 +1,41 @@
+(function(baselib) {
+
+
+
+
+
+
+    // Union/find for circular equality testing.
+
+    var UnionFind = function() {
+	// this.parenMap holds the arrows from an arbitrary pointer
+	// to its parent.
+	this.parentMap = baselib.hash.makeLowLevelEqHash();
+    }
+
+    // find: ptr -> UnionFindNode
+    // Returns the representative for this ptr.
+    UnionFind.prototype.find = function(ptr) {
+	var parent = (this.parentMap.containsKey(ptr) ? 
+		      this.parentMap.get(ptr) : ptr);
+	if (parent === ptr) {
+	    return parent;
+	} else {
+	    var rep = this.find(parent);
+	    // Path compression:
+	    this.parentMap.put(ptr, rep);
+	    return rep;
+	}
+    };
+
+    // merge: ptr ptr -> void
+    // Merge the representative nodes for ptr1 and ptr2.
+    UnionFind.prototype.merge = function(ptr1, ptr2) {
+	this.parentMap.put(this.find(ptr1), this.find(ptr2));
+    };
+
+
+
+    baselib.UnionFind = UnionFind;
+
+})(this['plt'].baselib);

js-assembler/runtime-src/helpers.js

@@ -0,0 +1,912 @@
+// Helper functions for whalesong.
+//
+// Note: this originally came from js-vm, and may have cruft that
+// doesn't belong in whalesong.  I need to clean this up.
+
+
+
+if (! this['plt']) { this['plt'] = {}; }
+
+// Helpers library: includes a bunch of helper functions that will be used
+//
+//
+// FIXME: there's a circularity between this module and types, and that circularly
+// should not be there!
+
+
+//////////////////////////////////////////////////////////////
+
+// File of helper functions for primitives and world.
+
+
+(function(scope) {
+    var helpers = {};
+    scope.helpers = helpers;
+
+
+    // types refers to plt.types, and will be initialized later.
+    var types = scope['types'];
+    scope.link.ready('types', 
+                     function() { 
+                         types = scope['types'];
+                     });
+
+
+
+
+    // format: string [X ...] string -> string
+    // String formatting.
+    var format = function(formatStr, args, functionName) {
+	var throwFormatError = function() {
+	    functionName = functionName || 'format';
+	    var matches = formatStr.match(new RegExp('~[sSaA]', 'g'));
+	    var expectedNumberOfArgs = (matches === null ? 0 : matches.length);
+	    var errorStrBuffer = [functionName + ': format string requires ' + expectedNumberOfArgs
+				  + ' arguments, given ' + args.length + '; arguments were:',
+				  toWrittenString(formatStr)];
+	    for (var i = 0; i < args.length; i++) {
+		errorStrBuffer.push( toWrittenString(args[i]) );
+	    }
+
+	    throw new Error(errorStrBuffer.join(' '));
+	}
+
+	var pattern = new RegExp("~[sSaAnevE%~]", "g");
+	var buffer = args.slice(0);
+	var onTemplate = function(s) {
+	    if (s === "~~") {
+		return "~";
+	    } else if (s === '~n' || s === '~%') {
+		return "\n";
+	    } else if (s === '~s' || s === "~S") {
+		if (buffer.length === 0) {
+		    throwFormatError();
+		}
+		return toWrittenString(buffer.shift());
+	    } else if (s === '~e' || s === "~E") {
+		// FIXME: we don't yet have support for the error-print
+		// handler, and currently treat ~e just like ~s.
+		if (buffer.length === 0) {
+		    throwFormatError();
+		}
+		return toWrittenString(buffer.shift()); 
+            }
+            else if (s === '~v') {
+		if (buffer.length === 0) {
+		    throwFormatError();
+		}
+                // fprintf must do something more interesting here by
+                // printing the dom representation directly...
+		return toWrittenString(buffer.shift());
+	    } else if (s === '~a' || s === "~A") {
+		if (buffer.length === 0) {
+		    throwFormatError();
+		}
+		return toDisplayedString(buffer.shift());
+	    } else {
+		throw new Error(functionName + 
+                                ': string.replace matched invalid regexp');
+	    }
+	}
+	var result = formatStr.replace(pattern, onTemplate);
+	if (buffer.length > 0) {
+	    throwFormatError();
+	}
+	return result;
+    };
+
+
+
+
+    // forEachK: CPS( array CPS(array -> void) (error -> void) -> void )
+    // Iterates through an array and applies f to each element using CPS
+    // If an error is thrown, it catches the error and calls f_error on it
+    var forEachK = function(a, f, f_error, k) {
+	var forEachHelp = function(i) {
+	    if( i >= a.length ) {
+		if (k) {
+		    return k();
+		} else {
+		    return;
+		}
+	    }
+
+	    try {
+		return f(a[i], function() { return forEachHelp(i+1); });
+	    } catch (e) {
+		f_error(e);
+	    }
+	};
+	return forEachHelp(0);
+    };
+
+
+    // reportError: (or exception string) -> void
+    // Reports an error to the user, either at the console
+    // if the console exists, or as alerts otherwise.
+    var reportError = function(e) {
+	var reporter;
+	if (typeof(console) != 'undefined' && 
+	    typeof(console.log) != 'undefined') {
+	    reporter = (function(x) { console.log(x); });
+	} else {
+	    reporter = (function(x) { alert(x); });
+	}
+	if (typeof e == 'string') {
+	    reporter(e);
+	} else if ( types.isSchemeError(e) ) {
+	    if ( types.isExn(e.val) ) {
+		reporter( types.exnMessage(e.val) );
+	    }
+	    else {
+		reporter(e.val);
+	    }
+	} else if ( types.isInternalError(e) ) {
+	    reporter(e.val);
+	} else if (e.message) {
+	    reporter(e.message);
+	} else {
+	    reporter(e.toString());
+	}
+        //		if (plt.Kernel.lastLoc) {
+        //			var loc = plt.Kernel.lastLoc;
+        //			if (typeof(loc) === 'string') {
+        //			reporter("Error was raised around " + loc);
+        //			} else if (typeof(loc) !== 'undefined' &&
+        //				   typeof(loc.line) !== 'undefined') {
+        //			reporter("Error was raised around: "
+        //				 + plt.Kernel.locToString(loc));
+        //			}
+        //		}
+    };
+
+
+    var raise = function(v) {
+	throw types.schemeError(v);
+    };
+
+
+
+//     var throwCheckError = function(details, pos, args) {
+// 	var errorFormatStr;
+// 	if (args && args.length > 1) {
+// 	    var errorFormatStrBuffer = ['~a: expects type <~a> as ~a arguments, given: ~s; other arguments were:'];
+// 	    for (var i = 0; i < args.length; i++) {
+// 		if ( i != pos-1 ) {
+// 		    errorFormatStrBuffer.push(toWrittenString(args[i]));
+// 		}
+// 	    }
+// 	    errorFormatStr = errorFormatStrBuffer.join(' ');
+// 	}
+// 	else {
+// 	    errorFormatStr = "~a: expects argument of type <~a>, given: ~s";
+// 	    details.splice(2, 1);
+// 	}
+
+// 	raise( types.incompleteExn(types.exnFailContract,
+// 				   helpers.format(errorFormatStr, details),
+// 				   []) );
+//     };
+
+
+
+//     var check = function(x, f, functionName, typeName, position, args) {
+// 	if ( !f(x) ) {
+// 	    throwCheckError([functionName,
+// 			     typeName,
+// 			     helpers.ordinalize(position),
+// 			     x],
+// 			    position,
+// 			    args);
+// 	}
+//     };
+
+    var isList = function(x) {
+	var seenPairs = plt.baselib.hash.makeLowLevelEqHash();
+	while (true) {
+	    if (seenPairs.containsKey(x)) {
+		return true;
+	    } else if (x === types.EMPTY) {
+		return true;
+	    } else if (types.isPair(x)) {
+		seenPairs.put(x, true);
+		x = x.rest();
+	    } else {
+		return false;
+	    }
+	}
+    };
+
+    var isListOf = function(x, f) {
+	var seenPairs = plt.baselib.hash.makeLowLevelEqHash();
+	while (true) {
+	    if (seenPairs.containsKey(x)) {
+		return true;
+	    } else if (x === types.EMPTY) {
+		return true;
+	    } else if (types.isPair(x)) {
+		seenPairs.put(x, true);
+		if (f(x.first())) {
+		    x = x.rest();
+		} else {
+		    return false;
+		}
+	    } else {
+		return false;
+	    }
+	}
+    };
+
+//     var checkListOf = function(lst, f, functionName, typeName, position, args) {
+// 	if ( !isListOf(lst, f) ) {
+// 	    helpers.throwCheckError([functionName,
+// 				     'list of ' + typeName,
+// 				     helpers.ordinalize(position),
+// 				     lst],
+// 				    position,
+// 				    args);
+// 	}
+//     };
+
+
+    //	// remove: array any -> array
+    //	// removes the first instance of v in a
+    //	// or returns a copy of a if v does not exist
+    //	var remove = function(a, v) {
+    //		for (var i = 0; i < a.length; i++) {
+    //			if (a[i] === v) {
+    //				return a.slice(0, i).concat( a.slice(i+1, a.length) );
+    //			}
+    //		}
+    //		return a.slice(0);
+    //	};
+
+    // map: array (any -> any) -> array
+    // applies f to each element of a and returns the result
+    // as a new array
+    var map = function(f, a) {
+	var b = new Array(a.length);
+	for (var i = 0; i < a.length; i++) {
+	    b[i] = f(a[i]);
+	}
+	return b;
+    };
+
+
+    var concatMap = function(f, a) {
+	var b = [];
+	for (var i = 0; i < a.length; i++) {
+	    b = b.concat( f(a[i]) );
+	}
+	return b;
+    };
+
+
+    var schemeListToArray = function(lst) {
+	var result = [];
+	while ( !lst.isEmpty() ) {
+	    result.push(lst.first());
+	    lst = lst.rest();
+	}
+	return result;
+    }
+
+    // deepListToArray: any -> any
+    // Converts list structure to array structure.
+    var deepListToArray = function(x) {
+	var thing = x;
+	if (thing === types.EMPTY) {
+	    return [];
+	} else if (types.isPair(thing)) {
+	    var result = [];
+	    while (!thing.isEmpty()) {
+		result.push(deepListToArray(thing.first()));
+		thing = thing.rest();
+	    }
+	    return result;
+	} else {
+	    return x;
+	}
+    }
+
+
+    var flattenSchemeListToArray = function(x) {
+	if ( !isList(x) ) {
+	    return [x];
+	}
+
+	var ret = [];
+	while ( !x.isEmpty() ) {
+	    ret = ret.concat( flattenSchemeListToArray(x.first()) );
+	    x = x.rest();
+	}
+	return ret;
+    };
+
+
+
+    var ordinalize = function(n) {
+	// special case for 11th:
+	if ( n % 100 == 11 ) {
+	    return n + 'th';
+	}
+	var res = n;
+	switch( n % 10 ) {
+	case 1: res += 'st'; break;
+	case 2: res += 'nd'; break;
+	case 3: res += 'rd'; break;
+	default: res += 'th'; break;
+	}
+	return res;
+    }
+
+
+    var wrapJsValue = function(x) {
+	if (x === undefined) {
+	    return types.jsValue('undefined', x);
+	}
+	else if (x === null) {
+	    return types.jsValue('null', x);
+	}
+	else if (typeof(x) == 'function') {
+	    return types.jsValue('function', x);
+	}
+	else if ( x instanceof Array ) {
+	    return types.jsValue('array', x);
+	}
+	else if ( typeof(x) == 'string' ) {
+	    return types.jsValue("'" + x.toString() + "'", x);
+	}
+	else {
+	    return types.jsValue(x.toString(), x);
+	}
+    };
+
+
+    var getKeyCodeName = function(e) {
+	var code = e.charCode || e.keyCode;
+	var keyname;
+	switch(code) {
+	case 16: keyname = "shift"; break;
+	case 17: keyname = "control"; break;
+	case 19: keyname = "pause"; break;
+	case 27: keyname = "escape"; break;
+	case 33: keyname = "prior"; break;
+	case 34: keyname = "next"; break;
+	case 35: keyname = "end"; break;
+	case 36: keyname = "home"; break;
+	case 37: keyname = "left"; break;
+	case 38: keyname = "up"; break;
+	case 39: keyname = "right"; break;
+	case 40: keyname = "down"; break;
+	case 42: keyname = "print"; break;
+	case 45: keyname = "insert"; break;
+	case 46: keyname = String.fromCharCode(127); break;
+	case 106: keyname = "*"; break;
+	case 107: keyname = "+"; break;
+	case 109: keyname = "-"; break;
+	case 110: keyname = "."; break;
+	case 111: keyname = "/"; break;
+	case 144: keyname = "numlock"; break;
+	case 145: keyname = "scroll"; break;
+	case 186: keyname = ";"; break;
+	case 187: keyname = "="; break;
+	case 188: keyname = ","; break;
+	case 189: keyname = "-"; break;
+	case 190: keyname = "."; break;
+	case 191: keyname = "/"; break;
+	case 192: keyname = "`"; break;
+	case 219: keyname = "["; break;
+	case 220: keyname = "\\"; break;
+	case 221: keyname = "]"; break;
+	case 222: keyname = "'"; break;
+	default: if (code >= 96 && code <= 105) {
+	    keyname = (code - 96).toString();
+	}
+	    else if (code >= 112 && code <= 123) {
+		keyname = "f" + (code - 111);
+	    }
+	    else {
+		keyname = String.fromCharCode(code).toLowerCase();
+	    }
+	    break;
+	}
+	return keyname;
+    };
+
+
+
+
+
+    // maybeCallAfterAttach: dom-node -> void
+    // walk the tree rooted at aNode, and call afterAttach if the element has
+    // such a method.
+    var maybeCallAfterAttach = function(aNode) {
+	var stack = [aNode];
+	while (stack.length !== 0) {
+	    var nextNode = stack.pop();
+	    if (nextNode.afterAttach) {
+		nextNode.afterAttach(nextNode);
+	    }
+	    if (nextNode.hasChildNodes && nextNode.hasChildNodes()) {
+		var children = nextNode.childNodes;
+		for (var i = 0; i < children.length; i++) {
+		    stack.push(children[i]);
+		}
+	    }
+	}
+    };
+
+
+
+
+
+
+
+
+    // makeLocationDom: location -> dom
+    // Dom type that has special support in the editor through the print hook.
+    // The print hook is expected to look at the printing of dom values with
+    // this particular structure.  In the context of WeScheme, the environment
+    // will rewrite these to be clickable links.
+    var makeLocationDom = function(aLocation) {
+	var locationSpan = document.createElement("span");
+	var idSpan = document.createElement("span");
+	var offsetSpan = document.createElement("span");
+	var lineSpan = document.createElement("span");
+	var columnSpan = document.createElement("span");
+	var spanSpan = document.createElement("span");
+
+	locationSpan['className'] = 'location-reference';
+	idSpan['className'] = 'location-id';
+	offsetSpan['className'] = 'location-offset';
+	lineSpan['className'] = 'location-line';
+	columnSpan['className'] = 'location-column';
+	spanSpan['className'] = 'location-span';
+
+	idSpan.appendChild(document.createTextNode(String(aLocation.id)));
+	offsetSpan.appendChild(document.createTextNode(String(aLocation.offset)));
+	lineSpan.appendChild(document.createTextNode(String(aLocation.line)));
+	columnSpan.appendChild(document.createTextNode(String(aLocation.column)));
+	spanSpan.appendChild(document.createTextNode(String(aLocation.span)));
+
+	locationSpan.appendChild(idSpan);
+	locationSpan.appendChild(offsetSpan);
+	locationSpan.appendChild(lineSpan);
+	locationSpan.appendChild(columnSpan);   
+	locationSpan.appendChild(spanSpan);
+
+	return locationSpan;
+    };
+
+
+    var isLocationDom = function(thing) {
+	return (thing
+		&&
+		(thing.nodeType === Node.TEXT_NODE ||
+		 thing.nodeType === Node.ELEMENT_NODE)
+		&&
+		thing['className'] === 'location-reference');
+    };
+
+
+
+
+
+
+
+
+
+    // Inheritance.
+    var heir = function(parentPrototype) {
+	var f = function() {}
+	f.prototype = parentPrototype;
+	return new f();
+    };
+
+
+
+ 
+    // toWrittenString: Any Hashtable -> String
+    var toWrittenString = function(x, cache) {
+        if (! cache) { 
+     	    cache = plt.baselib.hash.makeLowLevelEqHash();
+        }
+        if (x === null) {
+            return "null";
+        }
+        if (x === true) { return "true"; }
+        if (x === false) { return "false"; }
+        if (typeof(x) === 'object') {
+	    if (cache.containsKey(x)) {
+		return "...";
+	    }
+        }
+        if (x == undefined) {
+	    return "#<undefined>";
+        }
+        if (typeof(x) == 'string') {
+	    return escapeString(x.toString());
+        }
+        if (typeof(x) != 'object' && typeof(x) != 'function') {
+	    return x.toString();
+        }
+
+        var returnVal;
+        if (typeof(x.toWrittenString) !== 'undefined') {
+	    returnVal = x.toWrittenString(cache);
+        } else if (typeof(x.toDisplayedString) !== 'undefined') {
+	    returnVal = x.toDisplayedString(cache);
+        } else {
+	    returnVal = x.toString();
+        }
+        cache.remove(x);
+        return returnVal;
+    };
+
+
+
+    // toDisplayedString: Any Hashtable -> String
+    var toDisplayedString = function(x, cache) {
+        if (! cache) {
+    	    cache = plt.baselib.hash.makeLowLevelEqHash();
+        }
+        if (x === null) {
+            return "null";
+        }
+        if (x === true) { return "true"; }
+        if (x === false) { return "false"; }
+        if (typeof(x) === 'object') {
+	    if (cache.containsKey(x)) {
+		return "...";
+	    }
+        }
+        if (x == undefined || x == null) {
+	    return "#<undefined>";
+        }
+        if (typeof(x) == 'string') {
+	    return x;
+        }
+        if (typeof(x) != 'object' && typeof(x) != 'function') {
+	    return x.toString();
+        }
+
+        var returnVal;
+        if (typeof(x.toDisplayedString) !== 'undefined') {
+	    returnVal = x.toDisplayedString(cache);
+        } else if (typeof(x.toWrittenString) !== 'undefined') {
+	    returnVal = x.toWrittenString(cache);
+        } else {
+	    returnVal = x.toString();
+        }
+        cache.remove(x);
+        return returnVal;
+    };
+
+
+
+
+    var ToDomNodeParameters = function(params) {
+        if (! params) { params = {}; }
+        this.cache = plt.baselib.hash.makeLowLevelEqHash();
+        for (var k in params) {
+            if (params.hasOwnProperty(k)) {
+                this[k] = params[k];
+            }
+        }
+        this.objectCounter = 0;
+    };
+
+    // getMode: -> (U "print" "display" "write")
+    ToDomNodeParameters.prototype.getMode = function() {
+        if (this.mode) { 
+            return this.mode; 
+        }
+        return 'print';
+    };
+
+    ToDomNodeParameters.prototype.containsKey = function(x) {
+        return this.cache.containsKey(x);
+    };
+
+    ToDomNodeParameters.prototype.get = function(x) {
+        return this.cache.get(x);
+    };
+
+    ToDomNodeParameters.prototype.remove = function(x) {
+        return this.cache.remove(x);
+    };
+
+    ToDomNodeParameters.prototype.put = function(x) {
+        this.objectCounter++;
+        return this.cache.put(x, this.objectCounter);
+    };
+
+
+    // toDomNode: scheme-value -> dom-node
+    var toDomNode = function(x, params) {
+        if (params === 'write') {
+            params = new ToDomNodeParameters({'mode' : 'write'});
+        } else if (params === 'print') {
+            params = new ToDomNodeParameters({'mode' : 'print'});
+        } else if (params === 'display') {
+            params = new ToDomNodeParameters({'mode' : 'display'});
+        } else {
+            params = params || new ToDomNodeParameters({'mode' : 'display'});
+        } 
+
+        if (jsnums.isSchemeNumber(x)) {
+	    var node = numberToDomNode(x, params);
+            $(node).addClass("number");
+            return node;
+        }
+        
+        if (x === null) {
+	    var node = document.createElement("span");
+	    node.appendChild(document.createTextNode("null"));
+            $(node).addClass("null");
+	    return node;
+        }
+
+        if (x === true) {
+	    var node = document.createElement("span");
+	    node.appendChild(document.createTextNode("true"));
+            $(node).addClass("boolean");
+	    return node;
+        }
+
+        if (x === false) {
+	    var node = document.createElement("span");
+	    node.appendChild(document.createTextNode("false"));
+            $(node).addClass("boolean");
+	    return node;
+        }
+
+        if (typeof(x) == 'object') {
+	    if (params.containsKey(x)) {
+		var node = document.createElement("span");
+		node.appendChild(document.createTextNode("#" + params.get(x)));
+		return node;
+	    }
+        }
+        if (x === undefined || x == null) {
+	    var node = document.createElement("span");
+	    node.appendChild(document.createTextNode("#<undefined>"));
+	    return node;
+        }
+
+        if (typeof(x) == 'string') {
+	    var wrapper = document.createElement("span");
+            wrapper.style["white-space"] = "pre";
+	    var node;
+            if (params.getMode() === 'write' || params.getMode() === 'print') {
+                node = document.createTextNode(toWrittenString(x));
+            } else {
+                node = document.createTextNode(toDisplayedString(x));
+            }
+	    wrapper.appendChild(node);
+            $(wrapper).addClass("string");
+	    return wrapper;
+        }
+
+        if (typeof(x) != 'object' && typeof(x) != 'function') {
+	    var node = document.createElement("span");
+	    node.appendChild(document.createTextNode(x.toString()));
+            $(node).addClass("procedure");
+	    return node;
+        }
+
+        var returnVal;
+        if (x.nodeType) {
+	    returnVal =  x;
+        } else if (typeof(x.toDomNode) !== 'undefined') {
+	    returnVal =  x.toDomNode(params);
+        } else if (params.getMode() === 'write' && 
+                   typeof(x.toWrittenString) !== 'undefined') {
+	    var node = document.createElement("span");
+	    node.appendChild(document.createTextNode(x.toWrittenString(params)));
+	    returnVal =  node;
+        } else if (params.getMode() === 'display' &&
+                   typeof(x.toDisplayedString) !== 'undefined') {
+	    var node = document.createElement("span");
+	    node.appendChild(document.createTextNode(x.toDisplayedString(params)));
+	    returnVal =  node;
+        } else {
+	    var node = document.createElement("span");
+	    node.appendChild(document.createTextNode(x.toString()));
+	    returnVal =  node;
+        }
+        params.remove(x);
+        return returnVal;
+    };
+
+
+
+    // numberToDomNode: jsnum -> dom
+    // Given a jsnum, produces a dom-node representation.
+    var numberToDomNode = function(n, params) {
+        var node;
+        if (jsnums.isExact(n)) {
+	    if (jsnums.isInteger(n)) {
+	        node = document.createElement("span");
+	        node.appendChild(document.createTextNode(n.toString()));
+	        return node;
+	    } else if (jsnums.isRational(n)) {
+	        return rationalToDomNode(n);
+	    } else if (jsnums.isComplex(n)) {
+	        node = document.createElement("span");
+	        node.appendChild(document.createTextNode(n.toString()));
+	        return node;
+	    } else {
+	        node = document.createElement("span");
+	        node.appendChild(document.createTextNode(n.toString()));
+	        return node;
+	    }
+        } else {
+	    node = document.createElement("span");
+	    node.appendChild(document.createTextNode(n.toString()));
+	    return node;
+        }
+    };
+
+    // rationalToDomNode: rational -> dom-node
+    var rationalToDomNode = function(n) {
+        var repeatingDecimalNode = document.createElement("span");
+        var chunks = jsnums.toRepeatingDecimal(jsnums.numerator(n),
+                                               jsnums.denominator(n),
+                                               {limit: 25});
+        repeatingDecimalNode.appendChild(document.createTextNode(chunks[0] + '.'))
+        repeatingDecimalNode.appendChild(document.createTextNode(chunks[1]));
+        if (chunks[2] === '...') {
+            repeatingDecimalNode.appendChild(
+                document.createTextNode(chunks[2]));
+        } else if (chunks[2] !== '0') {
+            var overlineSpan = document.createElement("span");
+            overlineSpan.style.textDecoration = 'overline';
+            overlineSpan.appendChild(document.createTextNode(chunks[2]));
+            repeatingDecimalNode.appendChild(overlineSpan);
+        }
+
+
+        var fractionalNode = document.createElement("span");
+        var numeratorNode = document.createElement("sup");
+        numeratorNode.appendChild(document.createTextNode(String(jsnums.numerator(n))));
+        var denominatorNode = document.createElement("sub");
+        denominatorNode.appendChild(document.createTextNode(String(jsnums.denominator(n))));
+        fractionalNode.appendChild(numeratorNode);
+        fractionalNode.appendChild(document.createTextNode("/"));
+        fractionalNode.appendChild(denominatorNode);
+
+        
+        var numberNode = document.createElement("span");
+        numberNode.appendChild(repeatingDecimalNode);
+        numberNode.appendChild(fractionalNode);
+        fractionalNode.style['display'] = 'none';
+
+        var showingRepeating = true;
+
+        numberNode.onclick = function(e) {
+            showingRepeating = !showingRepeating;
+            repeatingDecimalNode.style['display'] = 
+                (showingRepeating ? 'inline' : 'none')
+            fractionalNode.style['display'] = 
+                (!showingRepeating ? 'inline' : 'none')
+        };
+        numberNode.style['cursor'] = 'pointer';
+        return numberNode;
+    }
+
+
+
+
+
+
+    var escapeString = function(s) {
+        return '"' + replaceUnprintableStringChars(s) + '"';
+    };
+
+    var replaceUnprintableStringChars = function(s) {
+	var ret = [];
+	for (var i = 0; i < s.length; i++) {
+	    var val = s.charCodeAt(i);
+	    switch(val) {
+	    case 7: ret.push('\\a'); break;
+	    case 8: ret.push('\\b'); break;
+	    case 9: ret.push('\\t'); break;
+	    case 10: ret.push('\\n'); break;
+	    case 11: ret.push('\\v'); break;
+	    case 12: ret.push('\\f'); break;
+	    case 13: ret.push('\\r'); break;
+	    case 34: ret.push('\\"'); break;
+	    case 92: ret.push('\\\\'); break;
+	    default: if (val >= 32 && val <= 126) {
+		ret.push( s.charAt(i) );
+	    }
+		else {
+		    var numStr = val.toString(16).toUpperCase();
+		    while (numStr.length < 4) {
+			numStr = '0' + numStr;
+		    }
+		    ret.push('\\u' + numStr);
+		}
+		break;
+	    }
+	}
+	return ret.join('');
+    };
+
+
+
+
+
+
+    // clone: object -> object
+    // Copies an object.  The new object should respond like the old
+    // object, including to things like instanceof
+    var clone = function(obj) {
+        var C = function() {}
+        C.prototype = obj;
+        var c = new C();
+        for (property in obj) {
+	    if (obj.hasOwnProperty(property)) {
+	        c[property] = obj[property];
+	    }
+        }
+        return c;
+    };
+
+
+
+
+
+
+    ////////////////////////////////////////////////
+
+    helpers.format = format;
+    helpers.forEachK = forEachK;
+    helpers.reportError = reportError;
+    helpers.raise = raise;
+
+//     helpers.throwCheckError = throwCheckError;
+    helpers.isList = isList;
+    helpers.isListOf = isListOf;
+//     helpers.check = check;
+//     helpers.checkListOf = checkListOf;
+    
+    //	helpers.remove = remove;
+    helpers.map = map;
+    helpers.concatMap = concatMap;
+    helpers.schemeListToArray = schemeListToArray;
+    helpers.deepListToArray = deepListToArray;
+    helpers.flattenSchemeListToArray = flattenSchemeListToArray;
+
+    helpers.ordinalize = ordinalize;
+    helpers.wrapJsValue = wrapJsValue;
+
+    helpers.getKeyCodeName = getKeyCodeName;
+
+    helpers.maybeCallAfterAttach = maybeCallAfterAttach;
+
+    helpers.makeLocationDom = makeLocationDom;
+    helpers.isLocationDom = isLocationDom;
+
+
+    helpers.getEqHashCode = plt.baselib.hash.getEqHashCode;
+    helpers.makeLowLevelEqHash = plt.baselib.hash.makeLowLevelEqHash;
+
+    helpers.heir = heir;
+    helpers.escapeString = escapeString;
+    helpers.toWrittenString = toWrittenString;
+    helpers.toDisplayedString = toDisplayedString;
+
+
+    helpers.toDomNode = toDomNode;
+    helpers.ToDomNodeParameters = ToDomNodeParameters;
+
+    helpers.clone = clone;
+
+
+    scope.link.announceReady('helpers');
+})(this['plt']);
+
+/////////////////////////////////////////////////////////////////

js-assembler/runtime-src/jquery-protect-footer.js

@@ -0,0 +1,2 @@
+    }
+})(window);

js-assembler/runtime-src/js-numbers.js

@@ -36,7 +36,6 @@ if (typeof(exports) !== 'undefined') {
 
 
 (function() {
-    'use strict';
     // Abbreviation
     var Numbers = __PLTNUMBERS_TOP__;
     //var Numbers = jsnums;
@@ -241,21 +240,7 @@ if (typeof(exports) !== 'undefined') {
 
 
     // add: scheme-number scheme-number -> scheme-number
-    var add = function(x, y) {
-        var sum;
-        if (typeof(x) === 'number' && typeof(y) === 'number') {
-            sum = x + y;
-            if (isOverflow(sum)) {
-		return (makeBignum(x)).add(makeBignum(y));
-            }
-        }
-        if (x instanceof FloatPoint && y instanceof FloatPoint) {
-            return x.add(y);
-        }
-        return addSlow(x, y);        
-    };
-
-    var addSlow = makeNumericBinop(
+    var add = makeNumericBinop(
 	function(x, y) {
 	    var sum = x + y;
 	    if (isOverflow(sum)) {
@@ -299,22 +284,7 @@ if (typeof(exports) !== 'undefined') {
 
 
     // mulitply: scheme-number scheme-number -> scheme-number
-    var multiply = function(x, y) {
-        var prod;
-        if (typeof(x) === 'number' && typeof(y) === 'number') {
-	    prod = x * y;
-	    if (isOverflow(prod)) {
-		return (makeBignum(x)).multiply(makeBignum(y));
-            } else {
-                return prod;
-            }
-        }
-        if (x instanceof FloatPoint && y instanceof FloatPoint) {
-            return x.multiply(y);
-        }
-        return multiplySlow(x, y);
-    };
-    var multiplySlow = makeNumericBinop(
+    var multiply = makeNumericBinop(
 	function(x, y) {
 	    var prod = x * y;
 	    if (isOverflow(prod)) {

js-assembler/runtime-src/link.js

@@ -0,0 +1,56 @@
+// Lightweight linking of the modules.
+// There are circular dependencies across the modules unfortunately, so we
+// need a mechanism for letting them link to each other.
+if (! this['plt']) { this['plt'] = {}; }
+(function(scope) {
+    var link = {};
+    scope['link'] = link;
+
+
+    // link.ready: (string (string -> void)) -> void
+    // When the name announces that it's ready, calls the function f.
+    link.ready = function(name, f) {
+        readyWaiters[name] = readyWaiters[name] || [];
+        readyWaiters[name].push(f);
+
+        if (linkIsReady[name]) {
+            notifySingle(f, name);
+        }
+    };
+
+    // link.announceReady: string -> void
+    // Lets the world know that the name is ready.
+    link.announceReady = function(name) {
+        var i;
+        linkIsReady[name] = true;
+        notifyAll(name);
+    };
+ 
+
+
+    // notifyAll: string -> void
+    // Tell all listeners that the name is ready.
+    var notifyAll = function(name) {
+        var waiters = readyWaiters[name] || [], i;
+        for (i = 0 ; i < waiters.length; i++) {
+            notifySingle(waiters[i], name);
+        }                
+        readyWaiters[name] = [];
+    };
+
+
+    // Tell a single listener that the name is ready.
+    var notifySingle = function(f, name) {
+        setTimeout(function() { f(name); },
+                   0);
+    };
+
+
+    // linkIsReady: (Hashtable String Boolean)
+    var linkIsReady = {};   
+
+    // readyWaiters: (Hashtable String (Arrayof (String -> Void)))
+    var readyWaiters = {};
+
+
+})(this['plt']);

js.rkt

@@ -0,0 +1,3 @@
+#lang s-exp "lang/base.rkt"
+(require "js/main.rkt")
+(provide (all-from-out "js/main.rkt"))

js/js-impl.js

@@ -0,0 +1,36 @@
+EXPORTS['alert'] =
+    RUNTIME.makePrimitiveProcedure(
+        'alert',
+        1,
+        function(MACHINE) {
+            var elt = MACHINE.env[MACHINE.env.length - 1];
+            alert(String(elt));
+            return RUNTIME.VOID;
+        });
+
+
+EXPORTS['body'] = $(document.body);
+
+EXPORTS['$'] =
+    RUNTIME.makePrimitiveProcedure(
+        '$',
+        1,
+        function(MACHINE) {
+            var obj = MACHINE.env[MACHINE.env.length - 1];
+            return $(obj);
+        });
+
+EXPORTS['call-method'] = 
+    RUNTIME.makePrimitiveProcedure(
+        'call-method',
+        new RUNTIME.ArityAtLeast(2),
+        function(MACHINE) {
+            var obj = MACHINE.env[MACHINE.env.length - 1];
+            var methodName = MACHINE.env[MACHINE.env.length - 2];
+            var args = [];
+            for (var i = 0; i < MACHINE.argcount - 2; i++) {
+                args.push(MACHINE.env[MACHINE.env.length -1 - 2 - i]);
+            }
+            var result = obj[methodName].apply(obj, args);
+            return result;
+        });

js/main.rkt

@@ -1,9 +1,9 @@
 #lang s-exp "../lang/js/js.rkt"
 
-(require "structs.rkt")
-
 (declare-implementation
  #:racket "racket-impl.rkt"
  #:javascript ("js-impl.js")
- #:provided-values (resource->url))
-
+ #:provided-values (alert
+                    body
+                    call-method
+                    $))

js/racket-impl.rkt

@@ -0,0 +1,15 @@
+#lang s-exp "../lang/base.rkt"
+
+(provide alert body call-method $)
+
+(define (alert x)
+  (display x)
+  (newline))
+
+(define body 'blah)
+
+(define (call-method object method . args)
+  'not-done-yet)
+
+(define ($ name)
+  'not-done-yet)

lang/base.rkt

@@ -0,0 +1,3 @@
+#lang s-exp "kernel.rkt"
+(provide (all-from-out "kernel.rkt"))
+(require racket/private/modbeg)

lang/js/js.rkt

@@ -12,9 +12,9 @@
     (resolve-module-path a-module-path #f)))
   
 
-(define-for-syntax (resolve-implementation-path a-module-path)
+(define-for-syntax (read-implementation a-module-path)
   (let ([a-path (my-resolve-path a-module-path)])
-    (path->string a-path)))
+    (file->string a-path)))
 
 
 (define-syntax (declare-implementation stx)
@@ -26,10 +26,11 @@
          ([resolved-racket-module-name 
            (my-resolve-path (syntax-e #'racket-module-name))]
           [impl
-           (map (compose resolve-implementation-path syntax-e)
-                (syntax->list #'(javascript-module-name ...)))]
-          [(internal-name ...) (generate-temporaries #'(provided-name ...))]
-          [(set-internal-name! ...) (generate-temporaries #'(provided-name ...))])
+           (string-join 
+            (map (compose read-implementation syntax-e)
+                 (syntax->list #'(javascript-module-name ...)))
+            "\n")]
+          [(internal-name ...) (generate-temporaries #'(provided-name ...))])
        (syntax/loc stx
          (begin
            
@@ -48,41 +49,9 @@
                ))
 
            (require racket-module-name)
-           (begin
-             (define internal-name provided-name)
-             ;; Discouraging constant folding via set! to address issue 74
-             ;; https://github.com/dyoo/whalesong/issues/74
-             (define (set-internal-name! x)
-               (set! internal-name x)))
-           ...
+           (define internal-name provided-name) ...
            (provide (rename-out [internal-name provided-name] ...)))))]))
 
 
-(define-syntax (my-require stx)
-  (syntax-case stx ()
-    [(_ module-path ...)
-     (andmap (lambda (p) (module-path? (syntax-e p)))
-             (syntax->list #'(module-path ...)))
-     (with-syntax ([(required-path ...)
-                    (map (lambda (p)
-                           (my-resolve-path (syntax-e p)))
-                         (syntax->list #'(module-path ...)))])
-       (syntax/loc stx
-         (begin
-           (begin-for-syntax
-            (let* ([this-module 
-                    (variable-reference->resolved-module-path
-                     (#%variable-reference))]
-                   [key (resolved-module-path-name this-module)])
-              (record-module-require! key 'required-path)
-              ...
-              (void)))
-           (void))))]
-    [else
-     (raise-syntax-error #f "Expected module path" stx)]))
-     
-
-
 (provide declare-implementation
-         (rename-out [#%plain-module-begin #%module-begin]
-                     [my-require require]))
+         (rename-out [#%plain-module-begin #%module-begin]))

lang/js/query.rkt

@@ -2,60 +2,51 @@
 
 (require racket/contract
          racket/runtime-path
-         ;; racket/gui/base
          syntax/modresolve)
 
 
-(provide/contract [query (module-path? . -> . (listof string?))]
+(provide/contract [query (module-path? . -> . string?)]
                   [has-javascript-implementation? (module-path? . -> . boolean?)]
                   
                   [redirected? (path? . -> . boolean?)]
                   [follow-redirection (path? . -> . path?)]
-                  [collect-redirections-to (path? . -> . (listof path?))]
-
-                  [lookup-module-requires (path? . -> . (listof path?))])
+                  [collect-redirections-to (path? . -> . (listof path?))])
 
 (define-runtime-path record.rkt "record.rkt")
-(define ns (make-base-namespace))
-
-
-(define (my-resolve-module-path a-module-path)
-  (resolve-module-path a-module-path #f))
-
-
+(define ns (make-base-empty-namespace))
 
 ;; query: module-path -> string?
 ;; Given a module, see if it's implemented via Javascript.
 (define (query a-module-path)
-  (let ([resolved-path (my-resolve-module-path a-module-path)])
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
     (parameterize ([current-namespace ns])
-      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'lookup-javascript-implementation) resolved-path))))
 
 
 ;; has-javascript-implementation?:  module-path -> boolean
 (define (has-javascript-implementation? a-module-path)  
-  (let ([resolved-path (my-resolve-module-path a-module-path)])
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
     (parameterize ([current-namespace ns])
-      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'has-javascript-implementation?) resolved-path))))
   
 
 
 ;; redirected? path -> boolean
 (define (redirected? a-module-path)
-  (let ([resolved-path (my-resolve-module-path a-module-path)])
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
     (parameterize ([current-namespace ns])
-      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
       (path? ((dynamic-require-for-syntax record.rkt 'follow-redirection)
               resolved-path)))))
 
 
 ;; follow-redirection: module-path -> path
 (define (follow-redirection a-module-path)
-  (let ([resolved-path (my-resolve-module-path a-module-path)])
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
     (parameterize ([current-namespace ns])
-      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'follow-redirection)
        resolved-path))))
 
@@ -63,15 +54,8 @@
 
 ;; collect-redirections-to: module-path -> (listof path)
 (define (collect-redirections-to a-module-path)
-  (let ([resolved-path (my-resolve-module-path a-module-path)])
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
     (parameterize ([current-namespace ns])
-      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'collect-redirections-to)
        resolved-path))))
-
-
-(define (lookup-module-requires a-module-path)
-  (let ([resolved-path (my-resolve-module-path a-module-path)])
-    (parameterize ([current-namespace ns])
-      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
-      ((dynamic-require-for-syntax record.rkt 'lookup-module-requires) resolved-path))))

lang/js/record.rkt

@@ -7,13 +7,9 @@
          record-redirection!
          follow-redirection
 
-         #;record-exported-name!
+         record-exported-name!
          
-         collect-redirections-to
-
-         record-module-require!
-         lookup-module-requires
-         )
+         collect-redirections-to)
 
 
 (define-struct record (path impl))
@@ -22,12 +18,6 @@
 (define-struct redirection (from to))
 (define redirections '())
 
-
-
-(define-struct module-require (key path))
-(define module-requires '())
-
-
 ;; record-javascript-implementation!: path string -> void
 (define (record-javascript-implementation! a-path an-impl)
   (set! records (cons (make-record a-path an-impl)
@@ -76,28 +66,7 @@
        (loop (cdr redirections))])))
 
 
-
-(define (record-module-require! key path)
-  (set! module-requires
-        (cons (make-module-require key path)
-              module-requires)))
-
-
-(define (lookup-module-requires key)
-  (let loop ([requires module-requires])
-    (cond
-     [(null? requires)
-      '()]
-     [(equal? (module-require-key (car requires))
-              key)
-      (cons (module-require-path (car requires))
-            (loop (cdr requires)))]
-     [else
-      (loop (cdr requires))])))
-
-
-
-#;(define (record-exported-name! a-path internal-name external-name)
+(define (record-exported-name! a-path internal-name external-name)
   (printf "I need to remember to export ~s as ~s\n" internal-name external-name)
   (void))
 

lang/kernel.rkt

@@ -0,0 +1,451 @@
+#lang racket/base
+(require (prefix-in racket: (only-in racket/math pi sinh cosh sqr
+                                     sgn conjugate))
+         (prefix-in racket: racket/base)
+	 racket/local
+	 (for-syntax racket/base))
+
+
+
+;; constants
+(define constant:true #t)
+(define constant:false #f)
+(define constant:pi racket:pi)
+(define constant:e (racket:exp 1))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Primitive function stubs
+
+;; provide-stub-function
+(define-syntax (provide-stub-function stx)
+  (syntax-case stx ()
+    [(_ name-or-name-pair ...)
+     (with-syntax ([(provided-name ...)
+                    (map (lambda (name-or-pair)
+                           (syntax-case name-or-pair ()
+                             [x
+                              (identifier? #'x)
+                              #'x]
+                             [(x y)
+                              #'x]))
+                         (syntax->list #'(name-or-name-pair ...)))]
+                   [(impl-name ...) 
+                    (map (lambda (name)
+                           (syntax-case name ()
+                             [an-id
+                              (identifier? #'an-id)
+                              (datum->syntax name 
+                                             (string->symbol
+                                              (string-append "racket:"
+                                                             (symbol->string 
+                                                              (syntax-e name))))
+                                             name)]
+                             [(an-id an-impl-name)
+                              #'an-impl-name]))
+                         (syntax->list #'(name-or-name-pair ...)))])
+       (syntax/loc stx
+         (begin (begin (define (provided-name . args) 
+                         (racket:apply impl-name args))
+                       (provide provided-name))
+                ...)))]))
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Provides
+(provide (rename-out (constant:true true)
+                     (constant:false false)
+                     (constant:pi pi)
+                     (constant:e e))
+         null
+	 #%module-begin
+	 #%datum
+	 #%app
+	 #%top-interaction
+	 #%top
+         module
+         define
+	 define-values
+	 let-values
+	 let*-values
+	 define-struct
+         if
+	 cond
+	 else
+	 case
+	 quote
+	 quasiquote
+	 unquote
+	 unquote-splicing
+	 lambda
+	 case-lambda
+	 let
+	 let*
+	 letrec
+	 letrec-values
+	 local
+	 begin
+	 begin0
+	 set!
+	 and
+	 or
+	 when
+	 unless
+	 require
+	 for-syntax
+	 define-for-syntax
+	 begin-for-syntax
+	 prefix-in
+	 only-in
+	 provide
+	 planet
+	 all-defined-out
+	 all-from-out
+	 except-out
+	 rename-out
+	 struct-out
+	 define-syntax
+	 define-syntaxes
+
+
+         let/cc
+	 with-continuation-mark
+
+
+         
+
+
+         ;; Kernel inlinable
+         *
+	 -
+	 +
+	 =
+	 /
+	 sub1
+	 add1
+	 <
+	 >
+	 <=
+	 >=
+         cons
+         car
+         cdr
+         list
+         null?
+         not
+         eq?)
+
+
+(define (-identity x) x)
+
+(define (-undefined? x)
+  (letrec ([y y])
+    (eq? x y)))
+
+
+
+;; Many of these should be pushed upward rather than stubbed, so that
+;; Racket's compiler can optimize these.
+(provide-stub-function
+
+ current-output-port
+ current-print 
+ write
+ display
+ newline
+ displayln
+
+ 
+;;  current-continuation-marks
+
+;;  continuation-mark-set?
+;;  continuation-mark-set->list
+
+;;  make-struct-type
+;;  make-struct-field-accessor
+;;  make-struct-field-mutator
+;;  struct-type?
+;;  struct-constructor-procedure?
+;;  struct-predicate-procedure?
+;;  struct-accessor-procedure?
+;;  struct-mutator-procedure?
+;;  procedure-arity
+;;  procedure-arity-includes?
+;;  make-arity-at-least
+;;  arity-at-least?
+;;  arity-at-least-value
+;;  apply
+;;  values
+;;  call-with-values
+;;  compose
+;;  current-inexact-milliseconds
+;;  current-seconds
+  void
+;;  random
+;;  sleep
+;;  (identity -identity)
+;;  raise
+error
+
+;;  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-message
+;;  exn-continuation-marks
+
+;;  exn?
+;;  exn:fail?
+;;  exn:fail:contract?
+;;  exn:fail:contract:arity?
+;;  exn:fail:contract:variable?
+;;  exn:fail:contract:divide-by-zero?
+  abs
+  quotient
+  remainder
+  modulo
+;;  max
+;;  min
+  gcd
+  lcm
+  floor
+  ceiling
+  round
+  truncate
+  numerator
+  denominator
+  expt
+  exp
+  log
+  sin
+  sinh
+  cos
+  cosh
+  tan
+  asin
+  acos
+  atan
+  sqr
+  sqrt
+  integer-sqrt
+  sgn
+  make-rectangular
+  make-polar
+  real-part
+  imag-part
+  angle
+  magnitude
+  conjugate
+  ;;  inexact->exact
+;;  exact->inexact
+  number->string
+  string->number
+;;  procedure?
+  pair?
+;;  (undefined? -undefined?)
+;;  immutable?
+;;  void?
+symbol?
+;;  string?
+;;  char?
+;;  boolean?
+vector?
+;;  struct?
+;;  eof-object?
+;;  bytes?
+;;  byte?
+;;  number?
+;;  complex?
+;;  real?
+;;  rational?
+;;  integer?
+  exact?
+;;  inexact?
+;;  odd?
+;;  even?
+  zero?
+;;  positive?
+;;  negative?
+;;  box?
+;;  hash?
+;;  eqv?
+  equal?
+  caar
+;;  cadr
+;;  cdar
+;;  cddr
+;;  caaar
+;;  caadr
+;;  cadar
+;;  cdaar
+;;  cdadr
+;;  cddar
+;;  caddr
+;;  cdddr
+;;  cadddr
+  length
+;;  list?
+;;  list*
+;;  list-ref
+;;  list-tail
+  append
+  reverse
+  for-each
+  map
+;;  andmap
+;;  ormap
+memq
+;;  memv
+  member
+;;  memf
+  assq
+;;  assv
+;;  assoc
+;;  remove
+;;  filter
+;;  foldl
+;;  foldr
+;;  sort
+;;  build-list
+  box
+;;  box-immutable
+  unbox
+  set-box!
+;;  make-hash
+;;  make-hasheq
+;;  hash-set!
+;;  hash-ref
+;;  hash-remove!
+;;  hash-map
+;;  hash-for-each
+;;  make-string
+;;  string
+  string-length
+;;  string-ref
+;;  string=?
+;;  string-ci=?
+;;  string<?
+;;  string>?
+;;  string<=?
+;;  string>=?
+;;  string-ci<?
+;;  string-ci>?
+;;  string-ci<=?
+;;  string-ci>=?
+;;  substring
+  string-append
+;;  string->list
+;;  list->string
+;;  string-copy
+;;  string->symbol
+symbol->string
+  format
+  printf
+  fprintf
+;;  build-string
+;;  string->immutable-string
+;;  string-set!
+;;  string-fill!
+;;  make-bytes
+;;  bytes
+;;  bytes->immutable-bytes
+;;  bytes-length
+;;  bytes-ref
+;;  bytes-set!
+;;  subbytes
+;;  bytes-copy
+;;  bytes-fill!
+;;  bytes-append
+;;  bytes->list
+;;  list->bytes
+;;  bytes=?
+;;  bytes<?
+;;  bytes>?
+  make-vector
+  vector
+  vector-length
+  vector-ref
+  vector-set!
+  vector->list
+  list->vector
+;;  build-vector
+;;  char=?
+;;  char<?
+;;  char>?
+;;  char<=?
+;;  char>=?
+;;  char-ci=?
+;;  char-ci<?
+;;  char-ci>?
+;;  char-ci<=?
+;;  char-ci>=?
+;;  char-alphabetic?
+;;  char-numeric?
+;;  char-whitespace?
+;;  char-upper-case?
+;;  char-lower-case?
+;;  char->integer
+;;  integer->char
+;;  char-upcase
+;;  char-downcase
+
+ 
+;;  call-with-current-continuation
+  call/cc
+;;  call-with-continuation-prompt
+;;  abort-current-continuation
+;;  default-continuation-prompt-tag
+;;  make-continuation-prompt-tag
+;;  continuation-prompt-tag?
+
+;;  make-reader-graph
+;;  make-placeholder
+;;  placeholder-set!
+ )
+
+
+
+
+
+(provide
+ ;; FIXME:
+ ;; Extensions: these may need to be hidden in a JavaScript-implemented module
+ in-javascript-context?
+ viewport-width
+ viewport-height)
+
+
+
+;; in-javascript-context: -> boolean
+;; Produces true if we're in a JavaScript context.
+(define (in-javascript-context?)
+  #f)
+
+
+;; viewport-width: -> natural
+;; The viewport width in pixels.
+(define (viewport-width)
+  (error 'viewport-width "Not available outside JavaScript context."))
+
+
+;; viewport-height: -> natural
+;; The viewport height in pixels.
+(define (viewport-height)
+  (error 'viewport-width "Not available outside JavaScript context."))
+
+
+
+
+
+(provide set-car! set-cdr!)
+
+(define (set-car! x v)
+  (error 'set-car! "Not available outside JavaScript context."))
+
+(define (set-cdr! x v)
+  (error 'set-car! "Not available outside JavaScript context."))

lang/reader.rkt

@@ -6,4 +6,4 @@
 	    `(file ,(path->string base-lang-path)))
 
 (require racket/runtime-path)
-(define-runtime-path base-lang-path "../../lang/base.rkt")
+(define-runtime-path base-lang-path "base.rkt")

make-launcher.rkt

@@ -378,7 +378,7 @@
                   (and m (cdr m)))))
     ;; Normal launcher:
     (make-embedding-executable
-      (string-append dest ".exe") (eq? kind 'mred) #f null null null flags aux #t variant)
+     dest (eq? kind 'mred) #f null null null flags aux #t variant)
     ;; Independent launcher (needed for Setup PLT):
     (begin
       (install-template dest kind "mzstart.exe" "mrstart.exe")
@@ -719,11 +719,7 @@
 (require racket/runtime-path)
 
 (define-runtime-path whalesong-path "whalesong.rkt")
-(define-runtime-path whalesong-gui-path "whalesong-gui.rkt")
 
 (make-racket-launcher (list (path->string whalesong-path))
                       "whalesong"
                       '())
-(make-racket-launcher (list (path->string whalesong-gui-path))
-                      "whalesong-gui"
-                      '())

make/make-structs.rkt

@@ -3,8 +3,7 @@
 (require "../compiler/il-structs.rkt"
          "../compiler/bootstrapped-primitives.rkt"
          "../compiler/expression-structs.rkt"
-         "get-dependencies.rkt"
-	 "../promise.rkt")
+         "get-dependencies.rkt")
 
 
 
@@ -20,44 +19,28 @@
 
 (define-struct: StatementsSource ([stmts : (Listof Statement)])
   #:transparent)
-(define-struct: MainModuleSource ([path : Path])
+(define-struct: MainModuleSource ([source : Source])
   #:transparent)
 (define-struct: ModuleSource ([path : Path])
   #:transparent)
 (define-struct: SexpSource ([sexp : Any])
   #:transparent)
-(define-struct: UninterpretedSource ([path : Path]
-                                     [datum : String]
-                                     [neighbors : (Listof Source)])
+(define-struct: UninterpretedSource ([datum : String])
   #:transparent)
 
 
 
-(: source-name (Source -> String))
-(define (source-name a-source)
-  (cond
-   [(StatementsSource? a-source)
-    "<StatementsSource>"]
-   [(UninterpretedSource? a-source)
-    (format "<UninterpretedSource ~a>" (UninterpretedSource-path a-source))]
-   [(MainModuleSource? a-source)
-    (format "<MainModuleSource ~a>" (MainModuleSource-path a-source))]
-   [(SexpSource? a-source)
-    "<SexpSource>"]
-   [(ModuleSource? a-source)
-    (format "<ModuleSource ~a>"
-            (ModuleSource-path a-source))]))
-
-
-
 (define-struct: Configuration
   ([wrap-source : (Source -> Source)]
    [should-follow-children? : (Source -> Boolean)]
-   [on-source : (Source 
-                 (U Expression #f) 
-                 (MyPromise (Listof Statement)) 
-                 -> Void)]
-   [after-source : (Source -> Void)]
+   [on-module-statements : (Source
+                            (U Expression #f)
+                            (Listof Statement)
+                            -> Void)]
+   [after-module-statements : (Source
+                               (U Expression #f)
+                               (Listof Statement)
+                               -> Void)]
    [after-last : (-> Void)])
   #:mutable)
 
@@ -69,7 +52,7 @@
      (when (and ast (expression-module-path ast))
        (printf "debug build configuration: visiting ~s\n"
                (expression-module-path ast))))
-   (lambda (src)
+   (lambda (src ast stmt)
      (void))
    (lambda ()
      (void))))
@@ -78,6 +61,8 @@
 
 
 
-(: only-bootstrapped-code : (MyPromise StatementsSource))
+(: only-bootstrapped-code : StatementsSource)
 (define only-bootstrapped-code
-  (my-delay (make-StatementsSource (get-bootstrapping-code))))
+  (make-StatementsSource (get-bootstrapping-code)))
+
+

make/make.rkt

@@ -0,0 +1,157 @@
+#lang typed/racket/base
+
+(require "../compiler/compiler.rkt"
+         "../compiler/il-structs.rkt"
+         "../compiler/lexical-structs.rkt"
+         "../compiler/compiler-structs.rkt"
+         "../compiler/expression-structs.rkt"
+         "../parameters.rkt"
+         "../sets.rkt"
+         "get-dependencies.rkt"
+         "make-structs.rkt"
+         racket/list
+         racket/match)
+
+
+(require/typed "../parser/parse-bytecode.rkt"
+               [parse-bytecode (Any -> Expression)])
+
+(require/typed "../get-module-bytecode.rkt"
+               [get-module-bytecode ((U String Path Input-Port) -> Bytes)])
+
+
+(provide make
+         current-module-source-compiling-hook
+         get-ast-and-statements)
+
+
+(: current-module-source-compiling-hook
+   (Parameterof (Source -> Source)))
+(define current-module-source-compiling-hook
+  (make-parameter (lambda: ([s : Source]) s)))
+
+
+
+
+
+(: get-ast-and-statements (Source -> (values (U False Expression)
+                                             (Listof Statement))))
+(define (get-ast-and-statements a-source)
+  (cond
+   [(StatementsSource? a-source)
+    (values #f (StatementsSource-stmts a-source))]
+
+   [(UninterpretedSource? a-source)
+    (values #f '())]
+   
+   [(MainModuleSource? a-source)
+    (let-values ([(ast stmts)
+                  (get-ast-and-statements (MainModuleSource-source a-source))])
+      (let ([maybe-module-locator (find-module-locator ast)])
+        (cond
+         [(ModuleLocator? maybe-module-locator)
+          (values ast (append stmts
+                             ;; Set the main module name
+                              (list (make-PerformStatement
+                                     (make-AliasModuleAsMain!
+                                      maybe-module-locator)))))]
+         [else
+          (values ast stmts)])))]
+
+   [else
+    (let ([ast
+           (cond
+            [(ModuleSource? a-source)
+             (parse-bytecode (ModuleSource-path a-source))]
+            [(SexpSource? a-source)
+             (let ([source-code-op (open-output-bytes)])
+               (write (SexpSource-sexp a-source) source-code-op)
+               (parse-bytecode
+                (open-input-bytes
+                 (get-module-bytecode
+                  (open-input-bytes
+                   (get-output-bytes source-code-op))))))])])
+      (values ast
+              (compile ast 'val next-linkage/drop-multiple)))]))
+
+
+
+(: find-module-locator ((U Expression False) -> (U False ModuleLocator)))
+;; Tries to look for the module locator of this expression.
+(define (find-module-locator exp)
+  (match exp
+    [(struct Top ((? Prefix?)
+                  (struct Module (name
+                                  (and path (? ModuleLocator?))
+                                  prefix
+                                  requires
+                                  provides
+                                  code))))
+     path]
+    [else
+     #f]))
+
+
+
+
+(: make ((Listof Source) Configuration -> Void))
+(define (make sources config)
+  (parameterize ([current-seen-unimplemented-kernel-primitives
+                  ((inst new-seteq Symbol))])
+
+    (match config
+      [(struct Configuration (wrap-source
+                              should-follow-children?
+                              on-module-statements
+                              after-module-statements
+                              after-last))
+
+
+       (: follow-dependencies ((Listof Source) -> Void))
+       (define (follow-dependencies sources)
+         (define visited ((inst make-hash Any Boolean)))
+
+         (: collect-new-dependencies
+            (Source (U False Expression) -> (Listof Source)))
+         (define (collect-new-dependencies this-source ast)
+           (cond
+            [(eq? ast #f)
+             empty]
+            [(not (should-follow-children? this-source))
+             empty]
+            [else
+             (let* ([dependent-module-names (get-dependencies ast)]
+                    [paths
+                     (foldl (lambda: ([mp : ModuleLocator]
+                                      [acc : (Listof Source)])
+                                     (let ([rp [ModuleLocator-real-path mp]])
+                                       (cond [((current-kernel-module-locator?)
+                                               mp)
+                                              acc]
+                                             [(path? rp)
+                                              (cons (make-ModuleSource rp) acc)]
+                                             [else
+                                              acc])))
+                            '()
+                            dependent-module-names)])
+               paths)]))
+         
+         (let: loop : Void ([sources : (Listof Source) sources])
+           (cond
+            [(empty? sources)
+             (after-last)]
+            [(hash-has-key? visited (first sources))
+             (loop (rest sources))]
+            [else
+             (hash-set! visited (first sources) #t)
+             (let*-values ([(this-source)
+                             ((current-module-source-compiling-hook)
+                              (first sources))]
+                           [(ast stmts)
+                            (get-ast-and-statements this-source)])
+               (on-module-statements this-source ast stmts)
+               (loop (append (map wrap-source (collect-new-dependencies this-source ast))
+                             (rest sources)))
+               (after-module-statements this-source ast stmts))])))
+
+       (follow-dependencies (map wrap-source sources))])))

notes/racket-days-abstract.txt

@@ -0,0 +1,51 @@
+What is Whalesong?
+
+    Whalesong is a compiler from Racket bytecode to JavaScript.
+
+
+Why would anyone care?
+
+    * Because it allows Racket programs to be deployed on the web.
+
+    * Furthermore, Racket programs can access native JavaScript APIs.
+
+    * Because my previous attempt at this produced a slower evaluator;
+    this is much faster.
+
+
+What do you want to show?
+
+    I want to show the tool in action, programs that use it
+       - like World programming, FFI
+
+    I want to show performance numbers (which means benchmarks...)
+
+    I also want to show some of the internals, to show why the
+    JavaScript context makes things more complicated.
+
+
+How do you use it?
+
+    I have a command line tool that consumes Racket programs and
+    produces standalone JavaScript applications.
+
+    I'll be using this as the underlying evaluator for WeScheme
+
+       Why?  Performance.
+
+
+What were the technical advantages of your approach?
+
+    Reusing the Racket compiler.  Strong possibility of reusing most
+    of the Racket standard library, as soon as we can bootstrap
+    racket/base.
+
+What were some of the technical challenges?
+
+    Supporting the features of the Racket virtual machine (tail calls,
+    continuations)
+
+
+What needs to be done next?
+
+    Adding enough primitives to run racket/base

parameters.rkt

@@ -0,0 +1,75 @@
+#lang typed/racket/base
+
+(require "compiler/expression-structs.rkt"
+         "compiler/lexical-structs.rkt"
+         "sets.rkt"
+         racket/path)
+
+
+(provide current-defined-name
+         current-module-path
+         current-root-path
+         current-warn-unimplemented-kernel-primitive
+         current-seen-unimplemented-kernel-primitives
+         current-kernel-module-locator?
+         current-compress-javascript?)
+
+
+
+(: current-module-path (Parameterof (U False Path)))
+(define current-module-path 
+  (make-parameter (build-path (current-directory) "anonymous-module.rkt")))
+
+
+(: current-root-path (Parameterof Path))
+(define current-root-path
+  (make-parameter (normalize-path (current-directory))))
+
+
+
+(: current-warn-unimplemented-kernel-primitive (Parameterof (Symbol -> Void)))
+(define current-warn-unimplemented-kernel-primitive
+  (make-parameter
+   (lambda: ([id : Symbol])
+            (printf "WARNING: Primitive Kernel Value ~s has not been implemented\n"
+                    id))))
+
+
+(: current-kernel-module-locator? (Parameterof (ModuleLocator -> Boolean)))
+;; Produces true if the given module locator should be treated as a root one.
+(define current-kernel-module-locator?
+  (make-parameter
+   (lambda: ([locator : ModuleLocator])
+            (or (and (eq? (ModuleLocator-name locator) '#%kernel)
+                     (eq? (ModuleLocator-real-path locator) '#%kernel))
+                (eq? (ModuleLocator-name locator)
+                     'whalesong/lang/kernel.rkt)))))
+
+
+
+
+(: current-compress-javascript? (Parameterof Boolean))
+(define current-compress-javascript? (make-parameter #f))
+
+
+
+
+
+;;; Do not touch the following parameters: they're used internally by package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(: current-seen-unimplemented-kernel-primitives (Parameterof (Setof Symbol)))
+(define current-seen-unimplemented-kernel-primitives
+  (make-parameter
+   ((inst new-seteq Symbol))))
+
+
+
+
+
+;;; These parameters below will probably go away soon.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(: current-defined-name (Parameterof (U Symbol LamPositionalName)))
+(define current-defined-name (make-parameter 'unknown))
+

parser/baby-parser.rkt

@@ -5,6 +5,7 @@
          "../compiler/lexical-structs.rkt"
          "../helpers.rkt"
          "../parameters.rkt"
+         "lam-entry-gensym.rkt"
          racket/list)
 
 (provide (rename-out (-parse parse)))
@@ -15,11 +16,6 @@
     (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)]
@@ -91,9 +87,7 @@
                          (EnvLexicalReference-unbox? address))]
          [(EnvPrefixReference? address)
           (make-ToplevelRef (EnvPrefixReference-depth address)
-                            (EnvPrefixReference-pos address)
-                            #f
-                            #t)]))]
+                            (EnvPrefixReference-pos address))]))]
 
     [(define-values? exp)
      (make-DefValues (map (lambda (id) 

parser/lam-entry-gensym.rkt

@@ -0,0 +1,14 @@
+#lang typed/racket/base
+
+
+(define-values (make-lam-label reset-lam-label-counter!/unit-testing)
+  (let ([n 0])
+    (values
+     (lambda ()
+       (set! n (add1 n))
+       (string->symbol (format "lamEntry~a" n)))
+     (lambda ()
+       (set! n 0)))))
+
+
+(provide make-lam-label reset-lam-label-counter!/unit-testing)

parser/parse-bytecode-5.1.1.rkt

@@ -0,0 +1,732 @@
+#lang racket/base
+
+;; Parsing Racket 5.1.1 bytecode structures into our own structures.
+(require "typed-module-path.rkt"
+         "lam-entry-gensym.rkt"
+         "path-rewriter.rkt"
+         "../compiler/expression-structs.rkt"
+         "../compiler/lexical-structs.rkt"
+         "../parameters.rkt"
+         "../get-module-bytecode.rkt"
+         syntax/modresolve
+         compiler/zo-parse
+         racket/path
+         racket/match
+         racket/list)
+
+
+(provide parse-bytecode
+         reset-lam-label-counter!/unit-testing)
+
+
+
+;; current-module-path-index-resolver: (module-path-index (U Path #f) -> (U Symbol Path)) -> void
+;; The module path index resolver figures out how to translate module path indices to module names.
+(define current-module-path-index-resolver 
+  (make-parameter 
+   (lambda (mpi relative-to)
+     (cond
+       [(eq? mpi #f)
+        (current-module-path)]
+       [(self-module-path-index? mpi)
+        (current-module-path)]
+       [else
+        (resolve-module-path-index mpi relative-to)]))))
+
+
+(define current-module-path-resolver 
+  (make-parameter 
+   (lambda (module-path relative-to)
+     (resolve-module-path module-path relative-to))))
+
+
+
+(define (self-module-path-index? mpi)
+  (let-values ([(x y) (module-path-index-split mpi)])
+    (and (eq? x #f)
+         (eq? y #f))))
+
+
+(define (explode-module-path-index mpi)
+  (let-values ([(x y) (module-path-index-split mpi)])
+    (cond
+      [(module-path-index? y)
+       (cons x (explode-module-path-index y))]
+      [else
+       (list x y)])))
+   
+
+
+
+;; seen-closures: (hashof symbol -> symbol)
+;; As we're parsing, we watch for closure cycles.  On any subsequent time where
+;; we see a closure cycle, we break the cycle by generating an EmptyClosureReference.
+;; The map is from the gen-id to the entry-point label of the lambda.
+(define seen-closures (make-parameter (make-hasheq)))
+
+
+
+
+
+
+;; Code is copied-and-pasted from compiler/decompile.  Maps the primval ids to their respective
+;; symbolic names.
+(define primitive-table
+  ;; Figure out number-to-id mapping for kernel functions in `primitive'
+  (let ([bindings
+         (let ([ns (make-base-empty-namespace)])
+           (parameterize ([current-namespace ns])
+             (namespace-require ''#%kernel)
+             (namespace-require ''#%unsafe)
+             (namespace-require ''#%flfxnum)
+             (namespace-require ''#%futures)
+             (for/list ([l (namespace-mapped-symbols)])
+               (cons l (with-handlers ([exn:fail? (lambda (x) 
+                                                    #f)])
+                         (compile l))))))]
+        [table (make-hash)])
+    (for ([b (in-list bindings)])
+      (let ([v (and (cdr b)
+                    (zo-parse (let ([out (open-output-bytes)])
+                                (write (cdr b) out)
+                                (close-output-port out)
+                                (open-input-bytes (get-output-bytes out)))))])
+        (let ([n (match v
+                   [(struct compilation-top (_ prefix (struct primval (n)))) n]
+                   [else #f])])
+          (hash-set! table n (car b)))))
+    table))
+
+
+
+
+
+
+
+
+;; parse-bytecode: (U Input-Port Path) -> Expression
+;;
+;; Given an input port, assumes the input is the byte representation of compiled-code.
+;;
+;; Given a path, assumes the path is for a module.  It gets the module bytecode, and parses
+;; that.
+;;
+;; TODO: this may be doing too much work.  It doesn't quite feel like the right elements
+;; are being manipulated here.
+(define (parse-bytecode in)
+  (cond
+    [(input-port? in)
+     (parameterize ([seen-closures (make-hasheq)])
+       (let ([compilation-top (zo-parse in)])
+         (parse-top compilation-top)))]
+    
+    [(compiled-expression? in)
+     (let ([op (open-output-bytes)])
+       (write in op)
+       (parse-bytecode (open-input-bytes (get-output-bytes op))))]
+
+    [(path? in)
+     (let*-values ([(normal-path) (normalize-path in)]
+                   [(base file-path dir?) (split-path normal-path)])
+       (parameterize ([current-module-path normal-path]
+                      [current-directory (cond [(path? base)
+                                                base]
+                                               [else
+                                                (error 'parse-bytecode)])])
+         (parse-bytecode
+          (open-input-bytes (get-module-bytecode normal-path)))))]    
+    [else
+     (error 'parse-bytecode "Don't know how to parse from ~e" in)]))
+
+
+         
+
+
+
+
+(define (parse-top a-top)
+  (match a-top
+    [(struct compilation-top (max-let-depth prefix code))
+     (maybe-fix-module-name
+      (make-Top (parse-prefix prefix) 
+                (parse-top-code code)))]))
+
+
+
+;; maybe-fix-module-name: expression -> expression
+;; When we're compiling a module directly from memory, it doesn't have a file path.
+;; We rewrite the ModuleLocator to its given name.
+(define (maybe-fix-module-name exp)
+  (match exp
+    [(struct Top (top-prefix 
+                  (struct Module ((and name (? symbol?))
+                                  (struct ModuleLocator ('self 'self))
+                                  module-prefix
+                                  module-requires
+                                  module-provides
+                                  module-code))))
+     (make-Top top-prefix
+               (make-Module name
+                            (make-ModuleLocator name name) (current-module-path)
+                            module-prefix
+                            module-requires
+                            module-provides
+                            module-code))]
+    [else
+     exp]))
+
+
+
+(define (parse-prefix a-prefix)
+  (match a-prefix
+    [(struct prefix (num-lifts toplevels stxs))
+     (make-Prefix 
+      (append (map parse-prefix-toplevel toplevels)
+              (map (lambda (x) #f) stxs)
+              (if (empty? stxs) empty (list #f))
+              (build-list num-lifts (lambda (i) #f))))]))
+
+
+;; parse-top-code: (U form Any -> Expression)
+(define (parse-top-code code)
+  (cond
+    [(form? code)
+     (parse-form code)]
+    [else
+     (make-Constant code)]))
+
+
+;; parse-prefix-toplevel: (U #f symbol global-bucket module-variable) -> (U False Symbol GlobalBucket ModuleVariable)
+(define (parse-prefix-toplevel a-toplevel)
+  (cond
+    [(eq? a-toplevel #f)
+     #f]
+    [(symbol? a-toplevel)
+     a-toplevel]
+    [(global-bucket? a-toplevel)
+     (make-GlobalBucket (global-bucket-name a-toplevel))]
+    [(module-variable? a-toplevel)
+     (let ([resolver (current-module-path-index-resolver)])
+       (make-ModuleVariable (module-variable-sym a-toplevel)
+                            (let ([resolved-path-name
+                                   (resolver (module-variable-modidx a-toplevel) (current-module-path))])
+                              (wrap-module-name resolved-path-name))))]))
+
+(define (wrap-module-name resolved-path-name)
+  (cond
+    [(symbol? resolved-path-name)
+     (make-ModuleLocator resolved-path-name resolved-path-name)]
+    [(path? resolved-path-name)
+     (let ([rewritten-path (rewrite-path resolved-path-name)])
+       (cond
+         [(symbol? rewritten-path)
+          (make-ModuleLocator (rewrite-path resolved-path-name)
+                           (normalize-path resolved-path-name))]
+         [else
+          (error 'wrap-module-name "Unable to resolve module path ~s."
+                 resolved-path-name)]))]))
+          
+       
+
+
+
+;; parse-form: form -> (U Expression)
+(define (parse-form a-form)
+  (cond
+    [(def-values? a-form)
+     (parse-def-values a-form)]
+
+    [(def-syntaxes? a-form)
+     (parse-def-syntaxes a-form)]
+    
+    [(req? a-form)
+     (parse-req a-form)]
+    
+    [(seq? a-form)
+     (parse-seq a-form)]
+    
+    [(splice? a-form)
+     (parse-splice a-form)]
+    
+    [(mod? a-form)
+     (parse-mod a-form)]
+    
+    [(expr? a-form)
+     (parse-expr a-form)]
+
+    [else
+     (error 'parse-form "~s" a-form)]))
+
+
+;; parse-def-values: def-values -> Expression
+(define (parse-def-values form)
+  (match form 
+    [(struct def-values (ids rhs))
+     (make-DefValues (map parse-toplevel ids)
+                     (parse-expr-seq-constant rhs))]))
+
+
+
+(define (parse-def-syntaxes form)
+  ;; Currently, treat def-syntaxes as a no-op.  The compiler will not produce
+  ;; syntax transformers.
+  (make-Constant (void)))
+
+
+
+(define (parse-req form)
+  (let ([resolver (current-module-path-resolver)])
+    (match form
+      [(struct req (reqs dummy))
+       (let ([require-statement (parse-req-reqs reqs)])
+         (match require-statement
+           [(list '#%require (and (? module-path?) path))
+            (let ([resolved-path ((current-module-path-resolver) path (current-module-path))])
+              (cond
+                [(symbol? resolved-path)
+                 (make-Require (make-ModuleLocator resolved-path resolved-path))]
+                [(path? resolved-path)
+                 (let ([rewritten-path (rewrite-path resolved-path)])
+                   (cond
+                     [(symbol? rewritten-path)
+                      (make-Require (make-ModuleLocator rewritten-path
+                                                     (normalize-path resolved-path)))]
+                     [else
+                      (printf "Internal error: I don't know how to handle the require for ~s" require-statement)
+                      (error 'parse-req)]))]
+                [else
+                 (printf "Internal error: I don't know how to handle the require for ~s" require-statement)
+                 (error 'parse-req)]))]
+           [else
+            (printf "Internal error: I don't know how to handle the require for ~s" require-statement)
+            (error 'parse-req)]))])))
+     
+;; parse-req-reqs: (stx -> (listof ModuleLocator))
+(define (parse-req-reqs reqs)
+  (match reqs
+    [(struct stx (encoded))
+     (unwrap-wrapped encoded)]))
+
+(define (unwrap-wrapped encoded)
+  (cond [(wrapped? encoded)
+         (match encoded 
+           [(struct wrapped (datum wraps certs))
+            (unwrap-wrapped datum)])]
+        [(pair? encoded)
+         (cons (unwrap-wrapped (car encoded))
+               (unwrap-wrapped (cdr encoded)))]
+        [(null? encoded)
+         null]
+        [else
+         encoded]))
+
+
+
+
+;; parse-seq: seq -> Expression
+(define (parse-seq form)
+  (match form
+    [(struct seq (forms))
+     (make-Seq (map parse-form-item forms))]))
+
+
+;; parse-form-item: (U form Any) -> Expression
+(define (parse-form-item item)
+  (cond
+    [(form? item)
+     (parse-form item)]
+    [else
+     (make-Constant item)]))
+
+
+;; parse-splice: splice -> Expression
+(define (parse-splice form)
+  (match form
+    [(struct splice (forms))
+     (make-Splice (map parse-splice-item forms))]))
+
+
+;; parse-splice-item: (U form Any) -> Expression
+(define (parse-splice-item item)
+  (cond
+    [(form? item)
+     (parse-form item)]
+    [else
+     (make-Constant item)]))
+
+
+;; parse-mod: mod -> Expression
+(define (parse-mod form)
+  (match form
+    [(struct mod (name srcname self-modidx prefix provides requires
+       body syntax-body unexported max-let-depth dummy lang-info
+       internal-context))
+     (let ([self-path 
+            ((current-module-path-index-resolver)
+             self-modidx
+             (current-module-path))])
+       (cond
+        [(symbol? self-path)
+         (make-Module name
+                      (make-ModuleLocator self-path self-path)
+                      (parse-prefix prefix)
+                      (parse-mod-requires self-modidx requires)
+                      (parse-mod-provides self-modidx provides)
+                      (parse-mod-body body))]
+        [else
+         (let ([rewritten-path (rewrite-path self-path)])
+           (cond
+             [(symbol? rewritten-path)
+              (make-Module name
+                           (make-ModuleLocator rewritten-path 
+                                            (normalize-path self-path))
+                           (parse-prefix prefix)
+                           (parse-mod-requires self-modidx requires)
+                           (parse-mod-provides self-modidx provides)
+                           (parse-mod-body body))]
+             [else
+              (error 'parse-mod "Internal error: unable to resolve module path ~s" self-path)]))]))]))
+
+
+;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleLocator)
+(define (parse-mod-requires enclosing-module-path-index requires)
+  ;; We only care about phase 0 --- the runtime.
+  (let ([resolver (current-module-path-index-resolver)])
+    (let loop ([requires requires])
+      (cond
+        [(empty? requires)
+         empty]
+        [(= (car (first requires))
+              0)
+         (map (lambda (m) 
+                (let ([enclosing-path (resolver enclosing-module-path-index (current-module-path))])
+                  (cond
+                    [(symbol? enclosing-path)
+                     (wrap-module-name (resolver m (current-module-path)))]
+                    [(path? enclosing-path)
+                     (wrap-module-name (resolver m enclosing-path))])))
+              (cdr (first requires)))]
+        [else
+         (loop (rest requires))]))))
+
+
+
+(define (parse-mod-provides enclosing-module-path-index provides)
+  (let* ([resolver
+          (current-module-path-index-resolver)]
+         [enclosing-path
+          (resolver enclosing-module-path-index (current-module-path))]
+         [subresolver
+          (lambda (p)
+            (cond
+             [(symbol? enclosing-path)
+              (wrap-module-name (resolver p (current-module-path)))]
+             [(path? enclosing-path)
+              (wrap-module-name (resolver p enclosing-path))]))])
+    (let loop ([provides provides])
+      (cond
+       [(empty? provides)
+        empty]
+       [(= (first (first provides)) 0)
+        (let ([provided-values (second (first provides))])
+          (for/list ([v provided-values])
+                    (match v
+                      [(struct provided (name src src-name nom-mod
+                                              src-phase protected? insp))
+                       (make-ModuleProvide src-name name (subresolver src))])))]
+       [else
+        (loop (rest provides))]))))
+
+
+
+
+
+
+;; parse-mod-body: (listof (or/c form? any/c)) -> Expression
+(define (parse-mod-body body)
+  (let ([parse-item (lambda (item)
+                      (cond
+                        [(form? item)
+                         (parse-form item)]
+                        [else
+                         (make-Constant item)]))])
+  (make-Splice (map parse-item body))))
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (parse-expr expr)
+  (cond
+    [(lam? expr)
+     (parse-lam expr (make-lam-label))]
+    [(closure? expr)
+     (parse-closure expr)]
+    [(case-lam? expr)
+     (parse-case-lam expr)]
+    [(let-one? expr)
+     (parse-let-one expr)]
+    [(let-void? expr)
+     (parse-let-void expr)]
+    [(install-value? expr)
+     (parse-install-value expr)]
+    [(let-rec? expr)
+     (parse-let-rec expr)]
+    [(boxenv? expr)
+     (parse-boxenv expr)]
+    [(localref? expr)
+     (parse-localref expr)]
+    [(toplevel? expr)
+     (parse-toplevel expr)]
+    [(topsyntax? expr)
+     (parse-topsyntax expr)]
+    [(application? expr)
+     (parse-application expr)]
+    [(branch? expr)
+     (parse-branch expr)]
+    [(with-cont-mark? expr)
+     (parse-with-cont-mark expr)]
+    [(beg0? expr)
+     (parse-beg0 expr)]
+    [(varref? expr)
+     (parse-varref expr)]
+    [(assign? expr)
+     (parse-assign expr)]
+    [(apply-values? expr)
+     (parse-apply-values expr)]
+    [(primval? expr)
+     (parse-primval expr)]))
+
+(define (parse-lam expr entry-point-label)
+  (match expr
+    [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))
+     (let ([lam-name (extract-lam-name name)])
+       (make-Lam lam-name 
+                 num-params 
+                 rest?
+                 (parse-expr-seq-constant body)
+                 (vector->list closure-map)
+                 entry-point-label))]))
+  
+
+;; parse-closure: closure -> (U Lam EmptyClosureReference)
+;; Either parses as a regular lambda, or if we come across the same closure twice,
+;; breaks the cycle by creating an EmptyClosureReference with the pre-existing lambda
+;; entry point.
+(define (parse-closure expr)
+  (match expr
+    [(struct closure (code gen-id))
+     (let ([seen (seen-closures)])
+       (cond
+         [(hash-has-key? seen gen-id)
+          (match code
+            [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))
+             (let ([lam-name (extract-lam-name name)])
+               (make-EmptyClosureReference lam-name 
+                                           num-params 
+                                           rest?
+                                           (hash-ref seen gen-id)))])]
+         [else
+          (let ([fresh-entry-point (make-lam-label)])
+            (hash-set! seen gen-id fresh-entry-point)
+            (parse-lam code fresh-entry-point))]))]))
+
+
+
+;; extract-lam-name: (U Symbol Vector) -> (U Symbol LamPositionalName)
+(define (extract-lam-name name)
+  (cond
+    [(symbol? name)
+     name]
+    [(vector? name)
+     (match name
+       [(vector (and (? symbol?) sym)
+                (and (? path?) source) 
+                (and (? number?) line)
+                (and (? number?) column)
+                (and (? number?) offset)
+                (and (? number?) span)
+                _)
+        (let ([try-to-rewrite (rewrite-path source)])
+          (make-LamPositionalName sym
+                                  (if try-to-rewrite
+                                      (symbol->string try-to-rewrite)
+                                      (path->string source))
+                                  line
+                                  column 
+                                  offset
+                                  span))]
+       [(vector (and (? symbol?) sym)
+                (and (? symbol?) source) 
+                (and (? number?) line)
+                (and (? number?) column)
+                (and (? number?) offset)
+                (and (? number?) span)
+                _)
+        (make-LamPositionalName sym
+                                (symbol->string source)
+                                line
+                                column 
+                                offset
+                                span)]
+       [else
+        (string->symbol (format "~s" name))])]
+    [else
+     'unknown
+     ;; The documentation says that the name must be a symbol or vector, but I'm seeing cases
+     ;; where it returns the empty list when there's no information available.
+     ]))
+
+
+
+
+(define (parse-case-lam exp)
+  (match exp
+    [(struct case-lam (name clauses))
+     (let ([case-lam-label (make-lam-label)])
+       (make-CaseLam (extract-lam-name name)
+                     (map (lambda (l) 
+                            (cond
+                              [(closure? l)
+                               (parse-closure l)]
+                              [else
+                               (parse-lam l (make-lam-label))]))
+                          clauses)
+                     case-lam-label))]))
+
+
+(define (parse-let-one expr)
+  (match expr
+    [(struct let-one (rhs body flonum? unused?))
+     ;; fixme: use flonum? and unused? to generate better code.
+     (make-Let1 (parse-expr-seq-constant rhs)
+                (parse-expr-seq-constant body))]))
+
+
+;; parse-expr-seq-constant: (U expr seq Any) -> Expression
+(define (parse-expr-seq-constant x)
+  (cond
+    [(expr? x) (parse-expr x)]
+    [(seq? x) (parse-seq x)]
+    [else (make-Constant x)]))
+
+
+(define (parse-let-void expr)
+  (match expr
+    [(struct let-void (count boxes? body))
+     (make-LetVoid count (parse-expr-seq-constant body) boxes?)]))
+
+
+(define (parse-install-value expr)
+  (match expr
+    [(struct install-value (count pos boxes? rhs body))
+     (make-Seq (list (make-InstallValue count pos (parse-expr-seq-constant rhs) boxes?)
+                     (parse-expr-seq-constant body)))]))
+
+
+(define (parse-let-rec expr)
+  (match expr
+    [(struct let-rec (procs body))
+     (make-LetRec (map (lambda (p) (parse-lam p (make-lam-label)))
+                       procs)
+                  (parse-expr-seq-constant body))]))
+
+(define (parse-boxenv expr)
+  (match expr
+    [(struct boxenv (pos body))
+     (make-BoxEnv pos (parse-expr-seq-constant body))]))
+
+
+(define (parse-localref expr)
+  (match expr
+    [(struct localref (unbox? pos clear? other-clears? flonum?))
+     ;; FIXME: we should use clear? at the very least: as I understand it,
+     ;; this is here to maintain safe-for-space behavior.
+     ;; We should also make use of flonum information to generate better code.
+     (make-LocalRef pos unbox?)]))
+
+
+(define (parse-toplevel expr)
+  (match expr
+    ;; FIXME: we should also keep track of const? and ready? to produce better code, and to
+    ;; do the required runtime checks when necessary (const?=#f, ready?=#f)
+    [(struct toplevel (depth pos const? ready?))
+     (make-ToplevelRef depth pos)]))
+
+
+(define (parse-topsyntax expr)
+  ;; We should not get into this because we're only parsing the runtime part of
+  ;; the bytecode.  Treated as a no-op.
+  (make-Constant (void)))
+
+
+(define (parse-application expr)
+  (match expr
+    [(struct application (rator rands))
+     (make-App (parse-application-rator rator)
+               (map parse-application-rand rands))]))
+
+(define (parse-application-rator rator)
+  (cond
+    [(expr? rator)
+     (parse-expr rator)]
+    [(seq? rator)
+     (parse-seq rator)]
+    [else
+     (make-Constant rator)]))
+
+(define (parse-application-rand rand)
+  (cond
+    [(expr? rand)
+     (parse-expr rand)]
+    [(seq? rand)
+     (parse-seq rand)]
+    [else
+     (make-Constant rand)]))
+
+
+(define (parse-branch expr)
+  (match expr
+    [(struct branch (test then else))
+     (make-Branch (parse-expr-seq-constant test)
+                  (parse-expr-seq-constant then)
+                  (parse-expr-seq-constant else))]))
+
+
+(define (parse-with-cont-mark expr)
+  (match expr
+    [(struct with-cont-mark (key val body))
+     (make-WithContMark (parse-expr-seq-constant key)
+                        (parse-expr-seq-constant val)
+                        (parse-expr-seq-constant body))]))
+
+(define (parse-beg0 expr)
+  (match expr
+    [(struct beg0 (seq))     
+     (make-Begin0 (map parse-expr-seq-constant seq))]))
+
+
+(define (parse-varref expr)
+  (match expr
+    [(struct varref (toplevel))
+     (make-VariableReference (parse-toplevel toplevel))]))
+
+(define (parse-assign expr)
+  (match expr
+    [(struct assign ((struct toplevel (depth pos const? ready?)) rhs undef-ok?))
+     (make-ToplevelSet depth pos (parse-expr-seq-constant rhs))]))
+
+
+(define (parse-apply-values expr)
+  (match expr
+    [(struct apply-values (proc args-expr))
+     (make-ApplyValues (parse-expr-seq-constant proc)
+                       (parse-expr-seq-constant args-expr))]))
+
+
+(define (parse-primval expr)
+  (match expr
+    [(struct primval (id))
+     (let ([name (hash-ref primitive-table id)])
+       (make-PrimitiveKernelValue name))]))

parser/parse-bytecode.rkt

@@ -0,0 +1,32 @@
+#lang racket/base
+(require "../version-case/version-case.rkt"
+         racket/file
+         (prefix-in whalesong: "../version.rkt")
+         (for-syntax racket/base))
+
+(version-case
+  [(version>= (version) "5.1.1")
+   (begin      
+     (require "parse-bytecode-5.1.1.rkt")
+     (provide (except-out (all-from-out "parse-bytecode-5.1.1.rkt")
+                          parse-bytecode)))]
+  [else
+   (error 'parse-bytecode "Whalesong doesn't have a compatible parser for Racket ~a" (version))])
+
+
+(provide (rename-out [my-parse-bytecode parse-bytecode]))
+
+
+(define (my-parse-bytecode x)
+  (cond
+    [(path? x)
+     (parse-bytecode x)]
+    [else
+     (parse-bytecode x)]))
+
+
+(define cache-dir (build-path (find-system-path 'pref-dir)
+                              "whalesong"
+                              whalesong:version))
+(unless (directory-exists? cache-dir)
+  (make-directory* cache-dir))

parser/path-rewriter.rkt

@@ -5,14 +5,11 @@
          racket/path
          racket/contract
          racket/list
-         racket/runtime-path
-         racket/string)
+         racket/runtime-path)
 
 
 
-(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))]
-                  [within-root-path? (complete-path? . -> . boolean?)]
-                  [within-whalesong-path? (complete-path? . -> . boolean?)])
+(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))])
 
 
 
@@ -34,35 +31,28 @@
 (define (rewrite-path a-path)
   (let ([a-path (normalize-path a-path)])
     (cond
-     [(within-whalesong-path? a-path)
+     [(within-this-project-path? a-path)
       (string->symbol
        (string-append "whalesong/"
-                      (my-path->string
+                      (path->string
                        (find-relative-path normal-whalesong-path a-path))))]
      [(within-collects? a-path)
       (string->symbol
        (string-append "collects/"
-                      (my-path->string
+                      (path->string
                        (find-relative-path collects-path a-path))))]
-     [(within-root-path? a-path)
+     [(within-root? a-path)
       (string->symbol
        (string-append "root/"
-                      (my-path->string
+                      (path->string
                        (find-relative-path (current-root-path) a-path))))]
      [else 
       #f])))
 
 
-
-;; Like path->string, but I force the path separator to be '/' rather than the platform
-;; specific one.
-(define (my-path->string a-path)
-  (string-join (map path->string (explode-path a-path)) "/"))
-
-
        
 
-(define (within-root-path? a-path)
+(define (within-root? a-path)
   (within? (current-root-path) a-path))
 
 
@@ -70,7 +60,7 @@
   (within? collects-path a-path))
 
 
-(define (within-whalesong-path? a-path)
+(define (within-this-project-path? a-path)
   (within? normal-whalesong-path a-path))
 
 

parser/typed-module-path.rkt

@@ -0,0 +1,63 @@
+#lang typed/racket/base
+
+(define-type RelativeString String)
+(define-type UserString String)
+(define-type PackageString String)
+
+
+
+
+(define-type ModulePath (U (List 'quote Symbol)
+                           RelativeString
+                           (Pairof 'lib (Pairof RelativeString (Listof RelativeString)))
+                           Symbol
+                           (List 'file String)
+                           (List 'planet Symbol)
+                           (List 'planet String)
+                           (Pairof 'planet 
+                                   (Pairof RelativeString
+                                           (Pairof (U (List UserString PackageString)
+                                                      (List UserString PackageString Natural)
+                                                      (List UserString PackageString Natural MinorVersion))
+                                                   (Listof RelativeString))))))
+                                            
+
+(define-type MinorVersion (U Natural
+                             (List Natural Natural)
+                             (List '= Natural)
+                             (List '+ Natural)
+                             (List '- Natural)))
+
+
+(require/typed racket/base                       
+               
+               [opaque ModulePathIndex module-path-index?]
+               [opaque ResolvedModulePath resolved-module-path?]
+                        
+               [module-path-index-resolve 
+                (ModulePathIndex -> ResolvedModulePath)]
+               
+               [module-path-index-join
+                ((U ModulePath #f)
+                 (U ModulePathIndex ResolvedModulePath #f) ->
+                 ModulePathIndex)]
+               
+               [module-path-index-split 
+                (ModulePathIndex -> (values (U ModulePath #f)
+                                            (U ModulePathIndex ResolvedModulePath #f)))]
+               
+               [resolved-module-path-name
+                (ResolvedModulePath -> (U Path Symbol))]
+               [make-resolved-module-path ((U Symbol Path) -> ResolvedModulePath)])
+                                            
+
+
+(provide 
+ 
+ ModulePath
+ ResolvedModulePath
+         
+ ModulePathIndex
+ module-path-index-resolve
+ module-path-index-join
+ module-path-index-split)

parser/where-is-collects.rkt

@@ -0,0 +1,18 @@
+#lang typed/racket/base
+(require/typed racket/path
+               (normalize-path (Path -> Path)))
+(require/typed typed/racket/base
+               (relative-path? (Any -> Boolean))
+               (find-executable-path (Path Path -> Path)))
+
+(provide collects-path)
+
+(define collects-path
+  (normalize-path
+   (let ([p (find-system-path 'collects-dir)])
+     (cond
+      [(relative-path? p)
+       (find-executable-path (find-system-path 'exec-file)
+                             (find-system-path 'collects-dir))]
+      [else
+       p]))))

private/command.rkt

@@ -117,7 +117,7 @@
 ;; are eaten in the process.
 (define (wrap-to-count str n)
   (cond
-    [(<= (string-length str) n) (list str)]
+    [(< (string-length str) n) (list str)]
     [(regexp-match-positions #rx"\n" str 0 n)
      =>
      (λ (posn)

scribblings/manual.scrbl

@@ -3,27 +3,19 @@
           planet/version
           planet/resolver
           scribble/eval
-          scribble/bnf
           racket/sandbox
-          racket/port
-          racket/list
           (only-in racket/contract any/c)
+          ;          (for-label racket/base)
+          (for-label (this-package-in lang/base))
+          (for-label (this-package-in js))
+
+
           racket/runtime-path
           "scribble-helpers.rkt"
           "../js-assembler/get-js-vm-implemented-primitives.rkt")
 
-@(require racket/runtime-path)
-@(define-runtime-path git-head-path "../.git/refs/heads/master")
 
-
-@(require (for-label (this-package-in js))
-          (for-label (this-package-in lang/base))
-          (for-label (this-package-in resource)
-          (for-label (this-package-in web-world))))
-
-
-
-@inject-javascript-inline|{
+@inject-javascript|{
   var _gaq = _gaq || [];
   _gaq.push(['_setAccount', 'UA-24146890-1']);
   _gaq.push(['_trackPageview']);
@@ -36,9 +28,6 @@
 }|
 
 
-@inject-javascript-src{http://hashcollision.org/whalesong/examples/runtime.js}
-
-
 @(define-runtime-path whalesong-path "..")
 
 
@@ -52,18 +41,72 @@
 
 
 
-@title{Whalesong Internals}
-@author+email["Danny Yoo" "dyoo@hashcollision.org"]
+@title{Whalesong: a Racket to JavaScript compiler}
+@author+email["Danny Yoo" "dyoo@cs.wpi.edu"]
+
+
+
+@centered{@smaller{Source code can be found at:
+@url{https://github.com/dyoo/whalesong}.  The latest version of this
+document lives in @url{http://hashcollision.org/whalesong}.}}
 
 
 
 
-@section{Installing Whalesong from github}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@; Warning Will Robinson, Warning!
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@centered{@larger{@bold{@italic{Warning: this is work in progress!}}}}
 
-Although Whalesong has been deployed to
-@link["http://planet.racket-lang.org"]{PLaneT}, you can download the
-sources from the github repository and run from there instead.  Doing
-so requires doing a little bit of manual work.  The steps are:
+
+
+
+
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Introduction}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+Whalesong is a compiler from Racket to JavaScript; it takes Racket
+programs and translates them so that they can run stand-alone on a
+user's web browser.  It should allow Racket programs to run with
+(hopefully!) little modification, and provide access through the foreign-function
+interface to native JavaScript APIs.  The included runtime library
+also includes a framework to programming the web in functional
+event-driven style.
+
+
+The GitHub source repository to Whalesong can be found at
+@url{https://github.com/dyoo/whalesong}.
+
+
+
+Prerequisites: at least @link["http://racket-lang.org/"]{Racket
+5.1.1}, and a @link["http://www.java.com"]{Java 1.6} SDK.
+      @; (This might be superfluous information, so commented out
+      @;  for the moment...)
+      @;The majority of the project is written
+      @;@link["http://docs.racket-lang.org/ts-guide/index.html"]{Typed
+      @;Racket}, and Racket 5.1.1 and above provides the support necessary to
+      @;compile Whalesong; otherwise, compilation may take an unusual amount
+      @;of time.
+
+
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Getting started}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+@subsection{Installing Whalesong}
+
+At the time of this writing, although Whalesong has been deployed to
+@link["http://planet.racket-lang.org"]{PLaneT}, what's up there is probably
+already out of date!  You may want to get the latest sources instead
+of using the version on PLaneT.  Doing so
+requires doing a little bit of manual work.  The steps are:
 
 @itemlist[
 @item{Check Whalesong out of Github.}
@@ -82,35 +125,363 @@ Next, let's set up a @link["http://docs.racket-lang.org/planet/Developing_Packag
 parent directory that contains the @filepath{whalesong} repository, and
 then run this on your command line:
 @verbatim|{
-$ planet link dyoo whalesong.plt 1 5 whalesong
+$ planet link dyoo whalesong.plt 1 0 whalesong
 }|
-(You may need to adjust the @tt{1} and @tt{5} major/minor numbers a bit to be larger
+(You may need to adjust the @tt{1} and @tt{0} major/minor numbers a bit to be larger
 than the latest version that's on PLaneT at the time.)
 
 
-Let's make the @filepath{whalesong} launcher somewhere appropriate.  Run Racket with the following
-@racket[require]:
-@racketblock[
-(require (planet dyoo/whalesong/make-launcher))
-]
-This will create a @filepath{whalesong} executable in the current working directory.
-
 
 Finally, we need to set up Whalesong with @tt{raco setup}.
 Here's how to do this at the command
 line:
 @verbatim|{
-$ raco setup -P dyoo whalesong.plt 1 5
+$ raco setup -P dyoo whalesong.plt 1 0
 }|
-This should compile Whalesong.  Any time the source code in
-@filepath{whalesong} changes, we should repeat this @tt{raco setup}
-step again.
+This should compile Whalesong, as well as set up the @filepath{whalesong} executable.
+Any time the source code in @filepath{whalesong} changes, we should repeat
+this @tt{raco setup} step again.
+
+
+At this point, you should be able to rung @filepath{whalesong} from the command line.
+@verbatim|{
+$ ./whalesong
+Expected one of the following: [build, get-runtime, get-javascript].                    
+           }|
+and if this does appear, then Whalesong should be installed successfully.
+
+
+
+
+@subsection{Running Whalesong}
+
+Let's try making a simple, standalone executable.  At the moment, the
+program must be written in the base language of @racket[(planet
+dyoo/whalesong)].  This restriction unfortunately  prevents arbitrary
+@racketmodname[racket/base] programs from compiling at the moment;
+the developers (namely, dyoo) will be working to remove this
+restriction as quickly as possible.
+
+
+Write a @filepath{hello.rkt} with the following content
+@filebox["hello.rkt"]{
+@codeblock{
+    #lang planet dyoo/whalesong
+    (display "hello world")
+    (newline)
+}}
+This program is a regular Racket program, and can be executed normally,
+@verbatim|{
+$ racket hello.rkt 
+hello world
+$
+}|
+However, it can also be packaged with @filepath{whalesong}.
+@verbatim|{
+    $ whalesong build hello.rkt
+
+    $ ls -l hello.xhtml
+    -rw-rw-r-- 1 dyoo nogroup 692213 Jun  7 18:00 hello.xhtml
+}|
+Running @tt{whalesong build} on a Racket program will produce a self-contained
+@filepath{.xhtml} file.  If you open this file in your favorite web browser,
+you should see a triumphant message show on screen.
+
+
+We can do something slightly more interesting.  Let's write a Whalesong program
+that accesses the JavaScript DOM.  Call this file @filepath{dom-play.rkt}.
+@filebox["dom-play.rkt"]{
+@codeblock|{
+#lang planet dyoo/whalesong
+
+;; Uses the JavaScript FFI, which provides bindings for:
+;; $ and call
+(require (planet dyoo/whalesong/js))
+
+;; insert-break: -> void
+(define (insert-break)
+  (call-method ($ "<br/>") "appendTo" body)
+  (void))
+
+;; write-message: any -> 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, and show some content
+;; on the browser.
+(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))]))
+}|}
+This program uses the @link["http:/jquery.com"]{JQuery} API provided by @racketmodname[(planet dyoo/whalesong/js)],
+as well as the native JavaScript FFI to produce output on the browser.
+If w run Whalesong on this program, and view the resulting @filepath{dom-play.xhtml} in your
+web browser, we should see a pale, green page with some output.
 
 
 
 
 
 
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Extended example}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(This example needs to use modules.  It should also show how we can use the
+other command-line options to compress the javascript, and how to
+use @tt{get-javascript} and @tt{get-runtime}, to allow the user to 
+build a customized html file.)
+
+
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Reference}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(This section should describe the whalesong language.)
+
+
+
+@subsection{The @filepath{whalesong} command-line}
+
+(This section should describe the whalesong launcher and the options
+we can use.)
+
+(We want to add JavaScript compression here as an option.)
+
+(We also need an example that shows how to use the get-javascript and get-runtime
+commands to do something interesting...)
+
+@subsection{@tt{build}}
+
+@subsection{@tt{get-runtime}}
+
+@subsection{@tt{get-javascript}}
+
+
+
+
+@section{The Whalesong language}
+
+@defmodule/this-package[lang/base]
+
+This needs to at least show all the bindings available from the base
+language.
+
+@defthing[true boolean]{The boolean value @racket[#t].}
+@defthing[false boolean]{The boolean value @racket[#f].}
+@defthing[pi number]{The math constant @racket[pi].}
+@defthing[e number]{The math constant @racket[pi].}
+@defthing[null null]{The empty list value @racket[null].}
+
+
+
+@defform[(let/cc id body ...)]{}
+@defform[(null? ...)]{}
+@defform[(not ...)]{}
+@defform[(eq? ...)]{}
+@defform[(equal? ...)]{}
+@defform[(void ...)]{}
+
+
+
+@subsection{IO}
+@defform[(current-output-port ...)]{}
+@defform[(current-print ...)]{}
+@defform[(write ...)]{}
+@defform[(display ...)]{}
+@defform[(newline ...)]{}
+@defform[(format ...)]{}
+@defform[(printf ...)]{}
+@defform[(fprintf ...)]{}
+@defform[(displayln ...)]{}
+
+
+
+@subsection{Numeric operations}
+
+@defform[(+ ...)]{}
+@defform[(- ...)]{}
+@defform[(* ...)]{}
+@defform[(/ ...)]{}
+@defform[(= ...)]{}
+@defform[(add1 ...)]{}
+@defform[(sub1 ...)]{}
+@defform[(< ...)]{}
+@defform[(<= ...)]{}
+@defform[(> ...)]{}
+@defform[(>= ...)]{}
+@defform[(abs ...)]{}
+@defform[(quotient ...)]{}
+@defform[(remainder ...)]{}
+@defform[(modulo ...)]{}
+@defform[(gcd ...)]{}
+@defform[(lcm ...)]{}
+@defform[(floor ...)]{}
+@defform[(ceiling ...)]{}
+@defform[(round ...)]{}
+@defform[(truncate ...)]{}
+@defform[(numerator ...)]{}
+@defform[(denominator ...)]{}
+@defform[(expt ...)]{}
+@defform[(exp ...)]{}
+@defform[(log ...)]{}
+@defform[(sin ...)]{}
+@defform[(sinh ...)]{}
+@defform[(cos ...)]{}
+@defform[(cosh ...)]{}
+@defform[(tan ...)]{}
+@defform[(asin ...)]{}
+@defform[(acos ...)]{}
+@defform[(atan ...)]{}
+@defform[(sqr ...)]{}
+@defform[(sqrt ...)]{}
+@defform[(integer-sqrt ...)]{}
+@defform[(sgn ...)]{}
+@defform[(make-rectangular ...)]{}
+@defform[(make-polar ...)]{}
+@defform[(real-part ...)]{}
+@defform[(imag-part ...)]{}
+@defform[(angle ...)]{}
+@defform[(magnitude ...)]{}
+@defform[(conjugate ...)]{}
+@defform[(number->string ...)]{}
+@defform[(string->number ...)]{}
+@defform[(pair? ...)]{}
+@defform[(exact? ...)]{}
+
+
+
+@subsection{List operations}
+@defform[(cons ...)]{}
+@defform[(car ...)]{}
+@defform[(cdr ...)]{}
+@defform[(list ...)]{}
+@defform[(length ...)]{}
+@defform[(append ...)]{}
+@defform[(reverse ...)]{}
+@defform[(map ...)]{}
+@defform[(member ...)]{}
+
+
+
+@subsection{Vector operations}
+
+@defform[(make-vector ...)]{}
+@defform[(vector ...)]{}
+@defform[(vector-length ...)]{}
+@defform[(vector-ref ...)]{}
+@defform[(vector-set! ...)]{}
+@defform[(vector->list ...)]{}
+@defform[(list->vector ...)]{}
+
+
+
+
+@subsection{Misc}
+
+The bindings here might relocate!
+
+@defproc[(in-javascript-context?) boolean]{Returns true if the running context
+supports JavaScript-specific functions.}
+
+@defform[(viewport-width)]{
+Can only be called in a JavaScript context.
+
+Returns wthe width of the viewport.
+}
+
+@defform[(viewport-height)]{
+Can only be called in a JavaScript context.
+
+Returns the height of the viewport.
+}
+
+
+
+
+
+
+@section{The JavaScript API}
+
+@defmodule/this-package[js]{
+
+
+This needs to describe what hooks we've got from the JavaScript side
+of things.
+
+In particular, we need to talk about the plt namespace constructed by
+the runtime, and the major, external bindings, like
+@tt{plt.runtime.invokeMains}.
+
+The contracts here are not quite right either.  I want to use JQuery
+as the type in several of the bindings here, but don't quite know how
+to teach Scribble about them yet.
+
+
+
+@defproc[(alert [msg string?]) void]{
+
+Displays an alert.  Currently implemented using JavaScript's
+@litchar{alert} function.}
+
+@defthing[body any/c]{
+A JQuery-wrapped value representing the body of the DOM.
+}
+
+@defproc[(call-method [object any/c] 
+                      [method-name string?]
+                      [arg any/c] ...) any/c]{
+
+Calls the method of the given object, assuming @racket[object] is a
+JavaScript value that supports that method call.  The raw return
+value is passed back.
+
+For example,
+@racketblock[(call-method body "css" "background-color")]
+should return the css color of the body.
+}
+
+
+
+@defproc[($ [locator any/c]) any/c]{
+
+Uses JQuery to construct or collect a set of DOM elements, as
+described in the @link["http://api.jquery.com/jQuery/"]{JQuery
+documentation}.
+
+For example,
+@racketblock[(call-method ($ "<h1>Hello World</h1>")
+                          "appendTo"
+                          body)]
+will construct a @tt{h1} header, and append it to
+the document body.
+
+
+}
+
+
+
+
+
+
+}
+
 @;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 @section{Internals}
 @;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -226,79 +597,6 @@ they're finished.
 
 
 
-@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-@subsection{A manual run through components}
-@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-Let's try to use some of the modules in Whalesong manually and see
-what comes out.  For example, we'd like to see what the compiler produces when
-we compile the following code:
-@filebox["factorial.rkt"]{
-@codeblock|{
-#lang planet dyoo/whalesong
-(define (f x)
-  (if (= x 0)
-      1
-      (* x (f (sub1 x)))))
-
-(provide f)
-}|
-}
-
-First, we can use the internal module
-@racketmodname/this-package[get-module-bytecode] and
-@racketmodname/this-package[parser/parse-bytecode] to read
-@filepath{factorial.rkt} into an AST.
-
-@interaction[#:eval my-evaluator
-(require (planet dyoo/whalesong/get-module-bytecode)
-         (planet dyoo/whalesong/parser/parse-bytecode))
-
-(define bytecode 
-  (get-module-bytecode 
-   (open-input-string 
-    (string-append "#lang planet dyoo/whalesong\n"
-                   "(define (f x)\n"
-                   "  (if (= x 0)\n"
-                   "      1\n"
-                   "      (* x (f (sub1 x)))))\n\n"
-                   "(provide f)"))))
-
-(define ast (parse-bytecode (open-input-bytes bytecode)))
-ast                    
-                    ]
-
-At this point, we have an ast, using the structures defined in
-@racketmodname/this-package[compiler/expression-structs] and
-@racketmodname/this-package[compiler/lexical-structs].  This AST
-should be similar to the one described by
-@racketmodname[compiler/zo-parse] library, though the one in Whalesong
-is intended to be independent of the Racket version.
-
-We can now compile the AST into intermediate form.
-
-@interaction[#:eval my-evaluator
-(require (planet dyoo/whalesong/compiler/compiler)
-         (planet dyoo/whalesong/compiler/compiler-structs))
-
-(define stmts (compile ast 'val next-linkage/drop-multiple))
-]
-
-The compilation process translates the AST into a linear sequence of
-intermediate-level statements.  Finally, we can assemble this sequence
-into JavaScript by using @racketmodname/this-package[js-assembler/assemble].
-@interaction[#:eval my-evaluator
-(require (planet dyoo/whalesong/js-assembler/assemble))
-
-(define op (open-output-string))
-(assemble/write-invoke stmts op)
-(define js-code (get-output-string op))
-js-code
-]
-The ugly string stored in @racket[js-code] is the final result
-of the compilation.
-
-
 
 @;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 @subsection{Values}
@@ -321,27 +619,27 @@ All values should support the following functions
 
 Numbers are represented with the
 @link["https://github.com/dyoo/js-numbers"]{js-numbers} JavaScript
-library.  We re-exports it as a @tt{plt.baselib.numbers} namespace
-which provides the numeric tower API.
+library, which introduces a @tt{jsnums} namespace which provides the
+numeric tower API.
 
-Example uses of the @tt{plt.baselib.numbers} library include:
+Example uses of the @tt{js-numbers} library include:
 
 @itemlist[
 @item{Creating integers: @verbatim{42}  @verbatim{16}}
 
-@item{Creating big integers: @verbatim{plt.baselib.numbers.makeBignum("29837419826")}}
+@item{Creating big integers: @verbatim{jsnums.makeBignum("29837419826")}}
 
-@item{Creating floats: @verbatim{plt.baselib.numbers.makeFloat(3.1415)}}
+@item{Creating floats: @verbatim{jsnums.makeFloat(3.1415)}}
 
-@item{Predicate for numbers: @verbatim{plt.baselib.numbers.isSchemeNumber(42)}}
+@item{Predicate for numbers: @verbatim{jsnums.isSchemeNumber(42)}}
 
-@item{Adding two numbers together: @verbatim{plt.baselib.numbers.add(42, plt.baselib.numbers.makeFloat(3.1415))}}
+@item{Adding two numbers together: @verbatim{jsnums.add(42, jsnums.makeFloat(3.1415))}}
 
-@item{Converting a plt.baselib.numbers number back into native JavaScript floats: @verbatim{plt.baselib.numbers.toFixnum(...)}}
+@item{Converting a jsnums number back into native JavaScript floats: @verbatim{jsnums.toFixnum(...)}}
 ]
 
-Do all arithmetic using the functions in the @tt{plt.baselib.numbers} namespace.
-One thing to also remember to do is apply @tt{plt.baselib.numbers.toFixnum} to any
+Do all arithmetic using the functions in the @tt{jsnums} namespace.
+One thing to also remember to do is apply @tt{jsnums.toFixnum} to any
 native JavaScript function that expects numbers.
 
 
@@ -396,12 +694,9 @@ return @tt{plt.runtime.VOID}.
 
 
 @subsection{Undefined}
-The undefined value is JavaScript's @tt{undefined}.
+The undefined values is 
 
 
-@subsection{EOF}
-The eof object is @tt{plt.runtime.EOF}
-
 
 @subsubsection{Boxes}
 Boxes can be constructed with @tt{plt.runtime.makeBox(x)}.  They can be
@@ -425,7 +720,7 @@ structure types can be made with plt.runtime.makeStructureType.  For example,
         3,          // required number of arguments
         0,          // number of automatically-filled fields
         false,      // OPTIONAL: the auto-v value
-        false       // OPTIONAL: a guard procedure
+        false,      // OPTIONAL: a guard procedure
         );
 }|
 
@@ -501,8 +796,6 @@ browser for testing output.
 
 
 
-
-
 @;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 @subsection{What's in @tt{js-vm} that's missing from Whalesong?}
 @;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -525,6 +818,7 @@ We need to bring around the following types previously defined in @tt{js-vm}:
 @item{regexp}
 @item{byteRegexp}
 @item{character}
+@item{box}
 @item{placeholder}
 @item{path}
 @item{bytes}
@@ -532,6 +826,8 @@ We need to bring around the following types previously defined in @tt{js-vm}:
 @item{keywords}
 @item{hash}
 @item{hasheq}
+@item{color}
+@item{structs}
 @item{struct types}
 @item{exceptions}
 @item{thread cells}
@@ -543,6 +839,22 @@ We need to bring around the following types previously defined in @tt{js-vm}:
 @item{readerGraph}
 ]
 
+
+
+@(define missing-primitives
+   (let ([in-whalesong-ht (make-hash)])
+     (for ([name whalesong-primitive-names])
+          (hash-set! in-whalesong-ht name #t))
+     (filter (lambda (name)
+               (not (hash-has-key? in-whalesong-ht name)))
+             js-vm-primitive-names))))
+
+
+What are the list of primitives in @filepath{js-vm-primitives.js} that we
+haven't yet exposed in whalesong?  We're missing @(number->string (length missing-primitives)):
+   @(apply itemlist (map (lambda (name)
+                           (item (symbol->string name)))
+                         missing-primitives))
         
 
 
@@ -558,167 +870,20 @@ I'll be attacking once things stabilize.)
 
 
 
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Acknowledgements}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@;; shriram, kathi, emmanuel, everyone who helped with moby and wescheme
+@;;
+@;; also need to list out all the external libraries we're using
+@;; and the license.
 
 
-
-
-
-
-
-
-
-
-@section{The Whalesong language}
-
-@defmodule/this-package[lang/base]
-
-This needs to at least show all the bindings available from the base
-language.
-
-@defthing[true boolean]{The boolean value @racket[#t].}
-@defthing[false boolean]{The boolean value @racket[#f].}
-@defthing[pi number]{The math constant @racket[pi].}
-@defthing[e number]{The math constant @racket[pi].}
-@defthing[null null]{The empty list value @racket[null].}
-
-@defproc[(boolean? [v any/c]) boolean?]{Returns true if v is @racket[#t] or @racket[#f]}
-
-
-
-@defform[(let/cc id body ...)]{}
-@defform[(null? ...)]{}
-@defform[(not ...)]{}
-@defform[(eq? ...)]{}
-@defform[(equal? ...)]{}
-@defform[(void ...)]{}
-@defform[(quote ...)]{}
-@defform[(quasiquote ...)]{}
-
-
-
-@subsection{IO}
-@defform[(current-output-port ...)]{}
-@defform[(current-print ...)]{}
-@defform[(write ...)]{}
-@defform[(write-byte ...)]{}
-@defform[(display ...)]{}
-@defform[(newline ...)]{}
-@defform[(format ...)]{}
-@defform[(printf ...)]{}
-@defform[(fprintf ...)]{}
-@defform[(displayln ...)]{}
-
-
-
-@subsection{Numeric operations}
-@defform[(number? ...)]{}
-@defform[(+ ...)]{}
-@defform[(- ...)]{}
-@defform[(* ...)]{}
-@defform[(/ ...)]{}
-@defform[(= ...)]{}
-@defform[(add1 ...)]{}
-@defform[(sub1 ...)]{}
-@defform[(< ...)]{}
-@defform[(<= ...)]{}
-@defform[(> ...)]{}
-@defform[(>= ...)]{}
-@defform[(abs ...)]{}
-@defform[(quotient ...)]{}
-@defform[(remainder ...)]{}
-@defform[(modulo ...)]{}
-@defform[(gcd ...)]{}
-@defform[(lcm ...)]{}
-@defform[(floor ...)]{}
-@defform[(ceiling ...)]{}
-@defform[(round ...)]{}
-@defform[(truncate ...)]{}
-@defform[(numerator ...)]{}
-@defform[(denominator ...)]{}
-@defform[(expt ...)]{}
-@defform[(exp ...)]{}
-@defform[(log ...)]{}
-@defform[(sin ...)]{}
-@defform[(sinh ...)]{}
-@defform[(cos ...)]{}
-@defform[(cosh ...)]{}
-@defform[(tan ...)]{}
-@defform[(asin ...)]{}
-@defform[(acos ...)]{}
-@defform[(atan ...)]{}
-@defform[(sqr ...)]{}
-@defform[(sqrt ...)]{}
-@defform[(integer-sqrt ...)]{}
-@defform[(sgn ...)]{}
-@defform[(make-rectangular ...)]{}
-@defform[(make-polar ...)]{}
-@defform[(real-part ...)]{}
-@defform[(imag-part ...)]{}
-@defform[(angle ...)]{}
-@defform[(magnitude ...)]{}
-@defform[(conjugate ...)]{}
-@defform[(string->number ...)]{}
-@defform[(number->string ...)]{}
-@defform[(random ...)]{}
-@defform[(exact? ...)]{}
-@defform[(integer? ...)]{}
-@defform[(zero? ...)]{}
-
-@subsection{String operations}
-@defform[(string? s)]{}
-@defform[(string ...)]{}
-@defform[(string=? ...)]{}
-@defform[(string->symbol ...)]{}
-@defform[(string-length ...)] {}
-@defform[(string-ref ...)] {}
-@defform[(string-append ...)] {}
-@defform[(string->list ...)] {}
-@defform[(list->string ...)] {}
-
-
-
-@subsection{Character operations}
-@defform[(char? ch)]{}
-@defform[(char=? ...)]{}
-
-
-
-
-@subsection{Symbol operations}
-@defform[(symbol? ...)]{}
-@defform[(symbol->string? ...)]{}
-
-
-
-@subsection{List operations}
-@defform[(pair? ...)]{}
-@defform[(cons ...)]{}
-@defform[(car ...)]{}
-@defform[(cdr ...)]{}
-@defform[(list ...)]{}
-@defform[(length ...)]{}
-@defform[(append ...)]{}
-@defform[(reverse ...)]{}
-@defform[(map ...)]{}
-@defform[(for-each ...)]{}
-@defform[(member ...)]{}
-@defform[(list-ref ...)]{}
-@defform[(memq ...)]{}
-@defform[(assq ...)]{}
-
-
-
-@subsection{Vector operations}
-@defform[(vector? ...)]{}
-@defform[(make-vector ...)]{}
-@defform[(vector ...)]{}
-@defform[(vector-length ...)]{}
-@defform[(vector-ref ...)]{}
-@defform[(vector-set! ...)]{}
-@defform[(vector->list ...)]{}
-@defform[(list->vector ...)]{}
-
-
-
-@section{Writing Extensions in JavaScript}
-[FIXME]
+Whalesong uses code and utilities from the following external projects:
+@itemlist[
+@item{   jshashtable (@url{http://www.timdown.co.uk/jshashtable/})}
+@item{   js-numbers (@url{http://github.com/dyoo/js-numbers/})}
+@item{   JSON (@url{http://www.json.org/js.html})}
+@item{   jquery (@url{http://jquery.com/})}
+@item{   Google Closure Compiler (@url{http://code.google.com/p/closure-compiler/})}
+]

scribblings/scribble-helpers.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+
+(provide inject-javascript)
+
+(require scribble/core
+         scribble/html-properties
+         scriblib/render-cond)
+
+;; Adds JavaScript if we're rendering in HTML.
+(define (inject-javascript . body)
+  (cond-element 
+   [latex ""]
+   [html (make-element (make-style #f (list (make-script-property "text/javascript"
+                                                           body)))
+                '())]
+   [text ""]))
+
+
+;;(define (google-analytics)
+;;  (make-tag 

simulator/simulator-helpers.rkt

@@ -0,0 +1,117 @@
+#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]
+      [(ContinuationMarkSet? 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)))]
+   [(ContinuationMarkSet? v)
+    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/simulator-primitives.rkt

@@ -0,0 +1,276 @@
+#lang racket/base
+(require "simulator-structs.rkt"
+         "simulator-helpers.rkt"
+         "../compiler/il-structs.rkt"
+         racket/math
+         racket/list
+         (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 (extract-arity proc)
+  (let loop ([racket-arity (procedure-arity proc)])
+    (cond
+      [(number? racket-arity)
+       racket-arity]
+      [(arity-at-least? racket-arity)
+       (make-ArityAtLeast (arity-at-least-value racket-arity))]
+      [(list? racket-arity)
+       (map loop racket-arity)])))
+                
+
+
+
+(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))
+                           (extract-arity name)
+                           'exported-name)]
+               ...)
+           (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 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-cadr (lambda (x)
+                  (MutablePair-h (MutablePair-t x))))
+
+(define my-caddr (lambda (x)
+                  (MutablePair-h (MutablePair-t (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 my-member (lambda (x l)
+                    (let loop ([l l])
+                      (cond
+                        [(null? l)
+                         #f]
+                        [(MutablePair? l)
+                         (cond
+                           [(equal? x (MutablePair-h l))
+                            l]
+                           [else
+                            (loop (MutablePair-t l))])]
+                        [else
+                         (error 'member "not a list: ~s" l)]))))
+
+(define my-reverse (lambda (l)
+                    (let loop ([l l]
+                               [acc null])
+                      (cond
+                        [(null? l)
+                         acc]
+                        [(MutablePair? l)
+                         (loop (MutablePair-t l)
+                               (make-MutablePair (MutablePair-h l) acc))]
+                        [else
+                         (error 'member "not a list: ~s" l)]))))
+
+
+(define my-printf (lambda (fmt args)
+                     (apply printf fmt (map (lambda (x)
+                                              (PrimitiveValue->racket x))
+                                            args))))
+
+
+
+(define current-continuation-marks   
+  (letrec ([f (case-lambda [(a-machine)
+                            (f a-machine default-continuation-prompt-tag-value)]
+                           [(a-machine tag)
+                            (make-ContinuationMarkSet
+                             (let loop ([frames (machine-control a-machine)])
+                               (cond
+                                 [(empty? frames)
+                                  empty]
+                                 [else
+                                  (append (hash-map (frame-marks (first frames))
+                                                    cons)
+                                          (if (eq? tag (frame-tag (first frames)))
+                                              empty
+                                              (loop (rest frames))))])))])])
+    (make-primitive-proc (lambda (machine . args) (apply f machine args))
+                         '(0 1)
+                         'current-continuation-marks)))
+                        
+
+(define continuation-mark-set->list
+  ;; not quite correct: ContinuationMarkSets need to preserve frame structure a bit more. 
+  ;; At the very least, we need to keep track of prompt tags somewhere.
+  (let ([f (lambda (a-machine mark-set key)
+             (let ([marks (ContinuationMarkSet-marks mark-set)])
+               (foldr make-MutablePair
+                      null
+                      (map cdr (filter (lambda (k+v)
+                                         (eq? (car k+v) key))
+                                       marks)))))])
+    (make-primitive-proc (lambda (machine . args) (apply f machine args))
+                         '2 ;; fixme: should deal with prompt tags too
+                         'current-continuation-marks)))
+
+
+
+
+
+(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-cadr cadr)
+						     (my-caddr caddr)
+                                                     (my-pair? pair?)
+                                                     (my-set-car! set-car!)
+                                                     (my-set-cdr! set-cdr!)
+                                                     (my-member member)
+                                                     (my-reverse reverse)
+                                                     
+                                                     
+                                                     (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)
+                                                     vector-length
+                                                     make-vector
+                                                     
+                                                     
+                                                     equal?
+                                                     symbol?
+                                                     
+                                                     
+                                                     (my-printf printf)
+                                                     )
+                                      #:constants (null pi e
+                                                        current-continuation-marks
+                                                        continuation-mark-set->list)))
+
+

simulator/simulator-structs.rkt

@@ -0,0 +1,202 @@
+#lang typed/racket/base
+
+(provide (all-defined-out))
+
+(require "../compiler/il-structs.rkt"
+         "../compiler/expression-structs.rkt"
+         "../compiler/lexical-structs.rkt")
+
+
+
+
+;; A special "label" in the system that causes evaluation to stop.
+(define-struct: halt ())
+(define HALT (make-halt))
+
+
+
+(define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean
+                                                   Null VoidValue
+                                                   undefined
+                                                   
+                                                   primitive-proc 
+                                                   closure
+                                                   
+                                                   (Vectorof PrimitiveValue)
+                                                   MutablePair
+
+                                                   ContinuationMarkSet
+
+                                                   ToplevelReference
+                                                   )))
+(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]
+                         [argcount : SlotValue]
+                         [env : (Listof SlotValue)]
+                         [control : (Listof frame)]
+
+                         [pc : Natural]                  ;; program counter
+                         [text : (Vectorof Statement)]   ;; text of the program
+
+                         [modules : (HashTable Symbol module-record)]
+                         
+                         ;; other metrics for debugging
+                         [stack-size : Natural]
+                         
+                         ;; compute position from label
+                         [jump-table : (HashTable Symbol Natural)]
+                         )
+  #:transparent
+  #:mutable)
+
+
+(define-struct: module-record ([name : Symbol]
+                               [self-path : Symbol]
+                               [label : Symbol]
+                               [invoked? : Boolean]
+                               [namespace : (HashTable Symbol PrimitiveValue)]
+                               [toplevel : (U False toplevel)])
+  #:transparent
+  #:mutable)
+
+
+(define-type frame (U GenericFrame CallFrame PromptFrame))
+
+
+(define-struct: GenericFrame ([temps : (HashTable Symbol PrimitiveValue)]
+                              [marks : (HashTable PrimitiveValue PrimitiveValue)])
+  #:transparent)
+
+
+(define-struct: CallFrame ([return : (U LinkedLabel halt)]
+                           ;; The procedure being called.  Used to optimize self-application
+                           [proc : (U closure #f)]
+                           ;; TODO: add continuation marks
+                           [temps : (HashTable Symbol PrimitiveValue)]
+                           [marks : (HashTable PrimitiveValue PrimitiveValue)])
+  #:transparent
+  #:mutable)  ;; mutable because we want to allow mutation of proc.
+
+(define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
+                             [return : (U LinkedLabel halt)]
+                             [env-depth : Natural]
+                             [temps : (HashTable Symbol PrimitiveValue)]
+                             [marks : (HashTable PrimitiveValue PrimitiveValue)])
+  #:transparent)
+
+
+(: frame-temps (frame -> (HashTable Symbol PrimitiveValue)))
+(define (frame-temps a-frame)
+  (cond
+    [(GenericFrame? a-frame)
+     (GenericFrame-temps a-frame)]
+    [(CallFrame? a-frame)
+     (CallFrame-temps a-frame)]
+    [(PromptFrame? a-frame)
+     (PromptFrame-temps a-frame)]))
+
+
+(: frame-marks (frame -> (HashTable PrimitiveValue PrimitiveValue)))
+(define (frame-marks a-frame)
+  (cond
+    [(GenericFrame? a-frame)
+     (GenericFrame-marks a-frame)]
+    [(CallFrame? a-frame)
+     (CallFrame-marks a-frame)]
+    [(PromptFrame? a-frame)
+     (PromptFrame-marks a-frame)]))
+
+
+(: frame-tag (frame -> (U ContinuationPromptTagValue #f)))
+(define (frame-tag a-frame)
+  (cond
+    [(GenericFrame? a-frame)
+     #f]
+    [(CallFrame? a-frame)
+     #f]
+    [(PromptFrame? a-frame)
+     (PromptFrame-tag a-frame)]))
+
+
+
+(define-struct: ContinuationPromptTagValue ([name : Symbol])
+  #:transparent)
+
+(define default-continuation-prompt-tag-value 
+  (make-ContinuationPromptTagValue 'default-continuation-prompt))
+
+
+
+(define-struct: ContinuationMarkSet ([marks : (Listof (Pairof PrimitiveValue PrimitiveValue))])
+  #:transparent)
+
+
+
+
+
+
+
+(define-struct: toplevel ([names : (Listof (U #f Symbol GlobalBucket ModuleVariable))]
+                          [vals : (Listof PrimitiveValue)])
+  #:transparent
+  #:mutable)
+
+
+
+
+
+;; Primitive procedure wrapper
+(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)]
+                                [arity : Arity]
+                                [display-name : (U Symbol LamPositionalName)])
+  #:transparent)
+
+
+
+
+;; Compiled procedure closures
+(define-struct: closure ([label : Symbol]
+                         [arity : Arity]
+                         [vals : (Listof SlotValue)]
+                         [display-name : (U Symbol LamPositionalName)])
+  #:transparent
+  #:mutable)
+
+
+
+
+(define-struct: ToplevelReference ([toplevel : toplevel]
+                                   [pos : Natural])
+  #:transparent)
+                
+
+;; undefined value
+(define-struct: undefined ()
+  #:transparent)
+
+
+
+(define-predicate PrimitiveValue? PrimitiveValue)
+(define-predicate frame? frame)
+
+

tests/browser-evaluate.rkt

@@ -0,0 +1,438 @@
+#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
+         simple-js-evaluate
+         (struct-out error-happened)
+         (struct-out evaluated))
+
+
+
+(define-struct error-happened (str t) #:transparent)
+(define-struct evaluated (stdout value t
+                                 browser) #:transparent)
+
+
+
+
+(define ch
+  (let ()
+    (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 ch 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"))))
+    
+    
+    ch))
+
+
+
+(define *alarm-timeout* 30000)
+
+(define (handle-comet ch req)
+  (let/ec return
+    (let* ([alarm (alarm-evt (+ (current-inexact-milliseconds) *alarm-timeout*))]
+           [javascript-compiler+program (sync ch alarm)]
+           [op (open-output-bytes)])
+      (cond
+        [(eq? javascript-compiler+program alarm)
+         (try-again-response)]
+        [else
+         (let ([javascript-compiler (first javascript-compiler+program)]
+               [program (second javascript-compiler+program)])
+
+         (with-handlers ([exn:fail? (lambda (exn)
+                                      (displayln 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') {
+                   delete req.onreadystateschange;
+                   setTimeout(function() { sendRequest(url, callback, postData); }, 0);
+                   return;
+                }
+                delete req.onreadystateschange;
+		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);
+                    //}
+                    try {
+                        var invoke = eval(req.responseText)();
+                    } catch (e) {
+                        if (window.console && window.console.log && e.stack) { window.console.log(e.stack); }
+                        throw e;
+                    }
+                    var output = [];
+                    var startTime, endTime;
+                    var params = { currentDisplayer: function(MACHINE, v) {
+                                                         $(document.body).append(v);
+                                                         output.push($(v).text()); } };
+
+                    var successCalled = false;
+                    var onSuccess = function(v) {
+                        if (successCalled) { return; }
+                        successCalled = true;
+                        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 failCalled = false;
+                    var onFail = function(machine, e) {
+                        if (failCalled) { return; }
+                        failCalled = true;
+                        endTime = new Date();
+                        sendRequest("/eval", function(req) { setTimeout(comet, 0); },
+                            "e=" + encodeURIComponent(String(e.stack || 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)))))
+
+
+
+
+
+
+
+;; make-evaluate: (Any output-port) -> (sexp -> (values string number))
+;; 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)
+  ;; 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 (list javascript-compiler e))
+    (let ([result (channel-get ch)])
+      (cond [(error-happened? result)
+             (raise result)]
+            [else
+             result])))
+  
+  evaluate)
+
+
+(define simple-js-evaluate
+  (make-evaluate (lambda (p op)
+                   (display "(function() {" op)
+                   (display "    return (function(succ, fail, params) {" op)
+                   (display p op)
+                   (display "\n               succ(); });" op)
+                   (display " })" op))))
+
+
+#;(simple-js-evaluate "alert('hello world');")

tests/browser-harness.rkt

@@ -0,0 +1,104 @@
+#lang racket/base
+
+
+;; Provides a harness for running programs on the browser and
+;; examining their results.
+
+;; Provides a test form that expects the path of a program and its
+;; expected output.
+
+
+(require "browser-evaluate.rkt"
+         "../js-assembler/package.rkt"
+         "../make/make-structs.rkt"
+         racket/port
+         racket/path
+         racket/runtime-path
+         racket/runtime-path
+         (for-syntax racket/base
+                     racket/path
+                     racket/port))
+
+(define evaluate (make-evaluate 
+                  (lambda (program op)
+
+                    (fprintf op "(function () {")
+                    
+   		    (displayln (get-runtime) op)
+                    
+                    (newline op)
+                    
+                    (fprintf op "var innerInvoke = ")
+                    (package-anonymous program
+                                       #:should-follow-children? (lambda (src) #t)
+                                       #:output-port op)
+                    (fprintf op "();\n")
+                    
+                    (fprintf op #<<EOF
+return (function(succ, fail, params) {
+            var machine = new plt.runtime.Machine();
+            return innerInvoke(machine,
+                               function() { plt.runtime.invokeMains(machine, succ, fail); },
+                               fail,
+                               params);
+        });
+});
+EOF
+                             )
+                    
+                    )))
+
+
+
+;; We use a customized error structure that supports
+;; source location reporting.
+(define-struct (exn:fail:error-on-test exn:fail)
+  (srcloc)
+  #:property prop:exn:srclocs
+             (lambda (a-struct)
+               (list (exn:fail:error-on-test-srcloc a-struct))))
+
+
+
+
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ original-source-file-path)
+     (with-syntax ([expected-file-path
+                    (regexp-replace "\\.rkt$"
+                                    (syntax-e
+                                     #'original-source-file-path)
+                                    ".expected")])
+
+       #'(test original-source-file-path expected-file-path))]
+    [(_ original-source-file-path expected-file-path)
+     (with-syntax ([stx stx]
+                   [source-file-path (parameterize ([current-directory
+                                        (current-load-relative-directory)])
+                                       (normalize-path (syntax-e #'original-source-file-path)))]
+                   [exp (parameterize ([current-directory
+                                        (current-load-relative-directory)])
+                          (call-with-input-file (syntax-e #'expected-file-path)
+                            port->string))])
+       (quasisyntax/loc #'stx
+         (begin
+           (printf "running test on ~s..." original-source-file-path)
+           (let* ([src-path source-file-path]
+                  [result (evaluate (make-MainModuleSource (make-ModuleSource src-path)))]
+                  [output (evaluated-stdout result)])
+             (cond [(string=? output exp)
+                    (printf " ok (~a milliseconds)\n" (evaluated-t result))]
+                   [else
+                    (printf " error!\n")
+                    (raise (make-exn:fail:error-on-test
+                            (format "Expected ~s, got ~s" exp output)
+                            (current-continuation-marks)
+                            (srcloc '#,(syntax-source #'stx)
+                                    '#,(syntax-line #'stx)
+                                    '#,(syntax-column #'stx)
+                                    '#,(syntax-position #'stx)
+                                    '#,(syntax-span #'stx))))])))))]))
+           
+
+
+(provide test)