still working on this...

Makefile

@@ -0,0 +1,49 @@
+# 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
+
+test-more:
+	raco make -v --disable-inline tests/run-more-tests.rkt
+	racket tests/run-more-tests.rkt
+
+
+
+
+
+doc:
+	racket make-last-commit-name.rkt
+	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
+Create a simple, standalong executable of your program.  At the
-prevents arbitrary racket/base programs from compiling, and we'll be working to
+moment, the program must be written in the base language of whalesong.
-remove this restriction.)
+(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
+    $ ls -l hello.xhtml
-    -rw-rw-r-- 1 dyoo nogroup 692213 Jun  7 18:00 hello.html
+    -rw-rw-r-- 1 dyoo nogroup 692213 Jun  7 18:00 hello.xhtml
-
-To build standalone executable of your program, provide --as-standalone-html
-flag.
-
-    $ ./whalesong.rkt build --as-standalone-html hello.rkt
-
-    $ ls -l
-    -rw-rw-r-- 1 dyoo nogroup 692213 Jun  7 18:00 hello.html
-
-NOTE: Earlier versions had --as-standalone-xhtml flag, which is now removed.
 
 
 [FIXME: add more examples]
@@ -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.
 

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

bf/lang/reader.rkt

@@ -1,5 +1,5 @@
 #lang s-exp syntax/module-reader
-#:language (lambda () 'whalesong/bf/language)
+(planet dyoo/whalesong/bf/language)   ;; switched from (planet dyoo/bf/language)
 #:read my-read
 #:read-syntax my-read-syntax
 #:info my-get-info

bf/language.rkt

@@ -1,4 +1,4 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
 (require "semantics.rkt"
          (for-syntax racket/base))

bf/semantics.rkt

@@ -1,4 +1,4 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
 ;; This is a second semantics for the language that tries to go for speed,
 ;; at the expense of making things a little more complicated.

compiler/analyzer-structs.rkt

@@ -1,8 +1,7 @@
 #lang typed/racket/base
 
 
-(require "arity-structs.rkt"
+(require "expression-structs.rkt"
-         "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-TestAndJumpStatement (make-TestOne (make-Reg 'argcount)) on-single-value)
+       ,(make-TestAndJumpStatement (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))
 
 
@@ -57,7 +56,6 @@
 
 (define-struct: ToplevelRef ([depth : Natural]
                              [pos : Natural]
-                             [constant? : Boolean]
                              [check-defined? : Boolean]) #:transparent)
 
 (define-struct: LocalRef ([depth : Natural]
@@ -158,16 +156,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~a" l n)))))
-          (string->symbol (format "_~a" 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"
+         "kernel-primitives.rkt")
-         "arity-structs.rkt")
 
 
 
@@ -35,10 +34,10 @@
                       CompiledProcedureEntry
                       CompiledProcedureClosureReference
                       ModuleEntry
-                      ModulePredicate
+                      IsModuleInvoked
+		      IsModuleLinked
                       PrimitiveKernelValue
-                      VariableReference
+                      VariableReference))
-                      ))
 
 
 ;; Targets: these are the allowable lhs's for a targetted assignment.
@@ -46,12 +45,8 @@
                        EnvLexicalReference
                        EnvPrefixReference
                        PrimitivesReference                   
-                       GlobalsReference
                        ControlFrameTemporary
-                       ModulePrefixTarget
+                       ModulePrefixTarget))
-                       ))
-
-(define-struct: ModuleVariableThing () #:transparent)
 
 
 ;; When we need to store a value temporarily in the top control frame, we can use this as a target.
@@ -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,17 +100,16 @@
 (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]
+;; Produces true if the module has been loaded into the machine
-                                 [pred : (U 'invoked? 'linked?)])
+(define-struct: IsModuleLinked ([name : ModuleLocator])
   #:transparent)
 
 
@@ -172,11 +118,10 @@
 (define-type StraightLineStatement (U
                                     DebugPrint
                                     Comment
-                                    MarkEntryPoint
                                     
-                                    AssignImmediate
+                                    AssignImmediateStatement
-                                    AssignPrimOp
+                                    AssignPrimOpStatement
-                                    Perform
+                                    PerformStatement
                                     
                                     PopEnvironment
                                     PushEnvironment
@@ -187,14 +132,12 @@
                                     PushControlFrame/Prompt
                                     PopControlFrame))
 
-(define-type BranchingStatement (U Goto TestAndJump))
+(define-type BranchingStatement (U GotoStatement TestAndJumpStatement))
                                  
 
 ;; instruction sequences
 (define-type UnlabeledStatement (U StraightLineStatement BranchingStatement))
 
-(define-predicate UnlabeledStatement? UnlabeledStatement)
-
 
 ;; Debug print statement.
 (define-struct: DebugPrint ([value : OpArg])
@@ -212,27 +155,11 @@
   #:transparent)
 
 
-;; Returns a pair of labels, the first being the mutiple-value-return
+(define-struct: AssignImmediateStatement ([target : Target]
-;; label and the second its complementary single-value-return label.
+                                          [value : OpArg])
-(: new-linked-labels (Symbol -> (Values Symbol LinkedLabel)))
-(define (new-linked-labels sym)
-  (define a-label-multiple (make-label (string->symbol (format "~aMultiple" sym))))
-  (define a-label (make-LinkedLabel (make-label sym) a-label-multiple))
-  (values a-label-multiple a-label))
-
-
-
-
-
-;; FIXME: it would be nice if I can reduce AssignImmediate and
-;; AssignPrimOp into a single Assign statement, but I run into major
-;; issues with Typed Racket taking minutes to compile.  So we're
-;; running into some kind of degenerate behavior.
-(define-struct: AssignImmediate ([target : Target]
-                                 [value : OpArg])
   #:transparent)
-(define-struct: AssignPrimOp ([target : Target]
+(define-struct: AssignPrimOpStatement ([target : Target]
-                              [op : PrimitiveOperator])
+                                       [op : PrimitiveOperator])
   #:transparent)
 
 
@@ -265,12 +192,12 @@
 (define-struct: PushControlFrame/Call ([label : LinkedLabel]) 
   #:transparent)
 
-(define-struct: PushControlFrame/Prompt
+(define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
-  ([tag : (U OpArg DefaultContinuationPromptTag)]
+                                         [label : LinkedLabel]
-   [label : LinkedLabel])
+                                         ;; TODO: add handler and arguments
+                                         )
   #:transparent)
 
-
 (define-struct: DefaultContinuationPromptTag ()
   #:transparent)
 (define default-continuation-prompt-tag 
@@ -279,18 +206,18 @@
 
 
 
-(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]
+(define-struct: TestAndJumpStatement ([op : PrimitiveTest]
                                       [label : Symbol])
   #:transparent)
 
@@ -299,35 +226,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
+                                  ApplyPrimitiveProcedure
                                   
-                                  ModuleVariable
-                                  PrimitivesReference
-                                  GlobalsReference
 
                                   MakeBoxedEnvironmentValue
 
                                   CaptureEnvironment
                                   CaptureControl
                                   
-                                  CallKernelPrimitiveProcedure
+                                  CallKernelPrimitiveProcedure))
-                                  ApplyPrimitiveProcedure
-                                  ))
 
 ;; Gets the label from the closure stored in the 'proc register and returns it.
 (define-struct: GetCompiledProcedureEntry ()
@@ -351,19 +266,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 +310,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 +329,14 @@
                                      [pos : Natural])
   #:transparent)
 
-;; Check that the global can be defined.
+;; Check the closure procedure value in 'proc and make sure it can accept the
-;; If not, raise an error and stop evaluation.
+;; # of arguments (stored as a number in the argcount register.).
-(define-struct: CheckGlobalBound! ([name : Symbol])
+(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 +345,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 +409,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 +428,14 @@
 
 ;; Given the module locator, do any finalizing operations, like
 ;; setting up the module namespace.
-(define-struct: FinalizeModuleInvokation! ([path : ModuleLocator]
+(define-struct: FinalizeModuleInvokation! ([path : ModuleLocator])
-                                           [provides : (Listof ModuleProvide)])
   #:transparent)
 
 
 
 (define-type PrimitiveCommand (U                                
                                CheckToplevelBound!
-                               CheckGlobalBound!
+                               CheckClosureArity!
-                               CheckClosureAndArity!
                                CheckPrimitiveArity!
 
                                ExtendEnvironment/Prefix!
@@ -546,7 +456,6 @@
                                RestoreEnvironment!
                                RestoreControl!
                                
-                               LinkModule!
                                InstallModuleEntry!
                                MarkModuleInvoked!
                                AliasModuleAsMain!
@@ -556,16 +465,10 @@
 
 
 
-(define-type InstructionSequence (U Symbol
+(define-type InstructionSequence (U Symbol LinkedLabel Statement instruction-sequence))
-                                    LinkedLabel
+(define-struct: instruction-sequence ([statements : (Listof Statement)])
-                                    UnlabeledStatement
-                                    instruction-sequence-list
-                                    instruction-sequence-chunks))
-(define-struct: instruction-sequence-list ([statements : (Listof Statement)])
   #:transparent)
-(define-struct: instruction-sequence-chunks ([chunks : (Listof InstructionSequence)])
+(define empty-instruction-sequence (make-instruction-sequence '()))
-  #:transparent)
-(define empty-instruction-sequence (make-instruction-sequence-list '()))
 
 
 (define-predicate Statement? Statement)
@@ -573,45 +476,20 @@
 
 (: statements (InstructionSequence -> (Listof Statement)))
 (define (statements s)
-  (reverse (statements-fold (inst cons Statement (Listof Statement))
+  (cond [(symbol? s) 
-                            '() s)))
+         (list s)]
-
+        [(LinkedLabel? s)
-
+         (list s)]
-(: statements-fold (All (A) ((Statement A -> A) A InstructionSequence -> A)))
+        [(Statement? s)
-(define (statements-fold f acc seq)
+         (list s)]
-  (cond
+        [else
-   [(symbol? seq)
+         (instruction-sequence-statements s)]))
-    (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)))
 
 
 
@@ -620,4 +498,19 @@
 
 
 
+
+
+
+
+;; 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))]
+  (let: ([prefix-references : (Setof EnvWholePrefixReference) (new-set)]
-         [lexical-references : (Setof EnvLexicalReference) ((inst new-set EnvLexicalReference))])
+         [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-pos target))]
-                              (EnvPrefixReference-modvar? 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]
+                                    [pos : Natural])
-                                    [modvar? : Boolean])
   #:transparent)
 
 (define-struct: EnvWholePrefixReference ([depth : Natural])

compiler/optimize-il.rkt

@@ -0,0 +1,165 @@
+#lang typed/racket/base
+(require "expression-structs.rkt"
+         "il-structs.rkt"
+         "lexical-structs.rkt"
+         (prefix-in ufind: "../union-find.rkt")
+         racket/list)
+
+(provide optimize-il)
+
+;; perform optimizations on the intermediate language.
+;;
+
+
+
+(: optimize-il ((Listof Statement) -> (Listof Statement)))
+(define (optimize-il statements)
+  ;; For now, replace pairs of PushEnvironment / AssignImmediate(0, ...)
+  ;; We should do some more optimizations here, like peephole...
+  (let* ([statements (filter not-no-op? statements)])
+    (let loop ([statements statements])
+      (cond
+       [(empty? statements)
+        empty]
+       [else
+        (let ([first-stmt (first statements)])
+          (: default (-> (Listof Statement)))
+          (define (default)
+            (cons first-stmt
+                  (loop (rest statements))))
+          (cond
+           [(empty? (rest statements))
+            (default)]
+           [else
+            (let ([second-stmt (second statements)])
+              (cond
+               [(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]
+    
+    [(TestAndJumpStatement? 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)
+                          (ToplevelRef-check-defined? 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

examples/eli-number-puzzle.rkt

@@ -1,10 +1,10 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
 ;; Eli's puzzle
 ;;
 ;;    http://lists.racket-lang.org/users/archive/2011-July/046849.html
 
-(require whalesong/world)
+(require (planet dyoo/whalesong/world))
           
 (define-struct world (seq output))
 

examples/expanding-circle.rkt

@@ -1,7 +1,6 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
-(require whalesong/world
+(require (planet dyoo/whalesong/world))
-         whalesong/image)
 
 
 (define handler (on-tick add1 1))

examples/hello-bf.rkt

@@ -1,4 +1,4 @@
-#lang whalesong/bf
+#lang planet dyoo/whalesong/bf
 
 +++++ +++++             initialize counter (cell #0) to 10
 [                       use loop to set the next four cells to 70/100/30/10

examples/hello.rkt

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

examples/image-library-example.rkt

@@ -1,6 +1,6 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
-(require whalesong/image)
+(require (planet dyoo/whalesong/image))
 
 (printf "images.rkt\n")
 
@@ -615,10 +615,3 @@
 
 "(step-count? 0)"
 (step-count? 0)
-
-
-
-(beside/align "top"
-              (rectangle 20 100 "solid" "black")
-              (rectangle 20 120 "solid" "black")
-              (rectangle 20  80 "solid" "black"))

examples/logo.rkt

@@ -1,6 +1,6 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
-(require whalesong/image)
+(require (planet dyoo/whalesong/image))
 
 
 (define lst

examples/pacman.rkt

@@ -1,7 +1,6 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
-(require whalesong/world
+(require (planet dyoo/whalesong/world))
-         whalesong/image)
 
 
 ;; Constants:

examples/rain-world-program.rkt

@@ -1,8 +1,7 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
-(require whalesong/world
+(require (planet dyoo/whalesong/world)
-         whalesong/image
+         (planet dyoo/whalesong/js))
-         whalesong/js)
 
 ;; Occupy the whole screen.
 (void (call-method body "css" "margin" 0))

examples/whale.rkt

@@ -1,7 +1,6 @@
-#lang whalesong
+#lang planet dyoo/whalesong
 
-(require whalesong/world
+(require (planet dyoo/whalesong/world))
-         whalesong/image)
 
 (define-struct world (x direction))
 

examples/window-size.rkt

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

excerpt.html

@@ -0,0 +1,82 @@
+<!DOCTYPE html>
+<html>
+<head></head>
+
+<body>
+
+
+<p>If people say that Racket is just a Lisp, they are short-selling
+Racket a little.  It's more accurate to say that Racket is a language
+laboratory, because it supports many different languages,
+including <tt><a href="http://docs.racket-lang.org/lazy/index.html">lazy</a></tt>,
+ <tt><a href="http://docs.racket-lang.org/frtime/index.html">frtime</a></tt>,
+and the
+HTDP <a href="http://docs.racket-lang.org/htdp-langs/index.html">teaching</a>
+languages.</p>
+
+<p>However, these examples are all problematic: they lack the power to
+convince.  Skeptics may accept that Racket has a lot of Lisp dialects,
+but surely, they may add, there's a world of difference between a
+simple dialect of Lisp and a different programming language.  And even
+though each of these language examples use wildly different semantics,
+their differences are drowning in the homogenous sea of
+parentheses.</p>
+
+<p>In order to make the point that Racket is a language laboratory, we
+must show examples of Racket languages that look nothing like Lisp.
+Let's take a stab at the heart of the problem.  What would happen if
+we showed a Racket program like this?
+
+<code>
+<pre>
+#lang planet dyoo/bf
+++++++[>++++++++++++<-]>.
+>++++++++++[>++++++++++<-]>+.
++++++++..+++.>++++[>+++++++++++<-]>.
+<+++[>----<-]>.<<<<<+++[>+++++<-]>.
+>>.+++.------.--------.>>+.
+</pre>
+</code>
+
+To put this in polite terms: what in the $@#! is this?</p>
+
+<p>This
+is <tt><a href="http://en.wikipedia.org/wiki/Brainfuck">brainf*ck</a></tt>.  If
+we enter this in DrRacket, it runs.  If we
+use <a href="http://docs.racket-lang.org/raco/index.html">raco</a> on
+it, we can create standalone executables.</p>
+
+<p>What exactly is going on?  All Racket programs start with
+a <tt>#lang</tt> line, as we saw in the example above.
+This <tt>#lang</tt> line is the hook we use to extend Racket toward
+different programming languages.  More specifically, the
+<tt>planet dyoo/bf</tt> part of the <tt>#lang</tt> line names a
+specific Racket module, which tells Racket how to do two things:
+
+<ul>
+    <li>how to parse the surface syntax into abstract syntax trees</li>
+    <li>how to attach semantics to each of the phrases of a language</li>
+</ul>
+
+Both these pieces are not too mysterious: they're the
+<a href="http://en.wikipedia.org/wiki/Compiler#The_structure_of_a_compiler">front-end</a>
+of a traditional compiler, and one of the distinguishing features of
+Racket is that, not only is its front-end programmable, but pleasingly
+so: it's an afternoon's worth of time to implement 
+<tt>brainf*ck</tt> from scratch.
+</p>
+
+
+<p>Toward that end, I've written a self-contained tutorial
+at <a href="http://hashcollision.org/brainfudge">http://hashcollision.org/brainfudge</a>
+that shows the entire process, of how to write an implementation of
+the <tt>brainf*ck</tt> language into Racket and how to deploy it on
+<a href="http://planet.racket-lang.org/">PLaneT</a>.  I'd love to hear
+any comments or suggestions about the tutorial.
+</p>
+
+
+
+</body>
+</html>
+

get-module-bytecode.rkt

@@ -0,0 +1,63 @@
+#lang racket/base
+(require racket/path
+         racket/runtime-path
+         syntax/modcode
+         "language-namespace.rkt"
+         "logger.rkt")
+
+(provide get-module-bytecode)
+
+
+(define-runtime-path kernel-language-path
+  "lang/kernel.rkt")
+
+  
+(define (get-module-bytecode x)
+  (log-debug "grabbing module bytecode for ~s" 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))))

image/main.rkt

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

image/private/colordb.js

@@ -2,9 +2,9 @@
 // JavaScript land...
 
 
-var colorNamespace = MACHINE.modules['whalesong/image/private/color.rkt'].getExternalExports();
+var colorNamespace = MACHINE.modules['whalesong/image/private/color.rkt'].namespace;
-var colorStruct = colorNamespace.get('struct:color');
+var colorStruct = colorNamespace['struct:color'];
-var makeColor = function(r,g,b,a) { return colorStruct.constructor([r,g,b,a]); };
+var makeColor = colorStruct.constructor;
 
 
 

image/private/js-impl.js

@@ -4,7 +4,6 @@ var makeClosure = plt.baselib.functions.makeClosure;
 var finalizeClosureCall = plt.baselib.functions.finalizeClosureCall;
 var PAUSE = plt.runtime.PAUSE;
 
-var checkSymbolOrString = plt.baselib.check.checkSymbolOrString;
 
 var isString = plt.baselib.strings.isString;
 var isSymbol = plt.baselib.symbols.isSymbol;
@@ -37,12 +36,9 @@ var isFontWeight = function(x){
 	|| (x === false);		// false is also acceptable
 };
 var isMode = function(x) {
-	return ((isString(x) || isSymbol(x)) &&
+    return ((isString(x) || isSymbol(x)) &&
-          (x.toString().toLowerCase() == "solid" ||
+	    (x.toString().toLowerCase() == "solid" ||
-           x.toString().toLowerCase() == "outline")) ||
+	     x.toString().toLowerCase() == "outline"));
-         ((jsnums.isReal(x)) &&
-          (jsnums.greaterThanOrEqual(x, 0) &&
-           jsnums.lessThanOrEqual(x, 255)));
 };
 
 var isPlaceX = function(x) {
@@ -70,24 +66,8 @@ var isStyle = function(x) {
 
 
 
-// Useful trigonometric functions based on htdp teachpack
 
-// excess : compute the Euclidean excess
-//  Note: If the excess is 0, then C is 90 deg.
-//        If the excess is negative, then C is obtuse.
-//        If the excess is positive, then C is acuse.
-function excess(sideA, sideB, sideC) {
-  return sideA*sideA + sideB*sideB - sideC*sideC;
-}
 
-// return c^2 = a^2 + b^2 - 2ab cos(C)
-function cosRel(sideA, sideB, angleC) {
-  return (sideA*sideA) + (sideB*sideB) - (2*sideA*sideB*Math.cos(angleC * Math.PI/180));
-}
-
-var less = function(lhs, rhs) {
-  return (rhs - lhs) > 0.00001;
-}
 
 var checkString = plt.baselib.check.checkString;
 var checkStringOrFalse = plt.baselib.check.makeCheckArgumentType(
@@ -152,14 +132,11 @@ var checkPlaceY = plt.baselib.check.makeCheckArgumentType(
 var checkAngle = plt.baselib.check.makeCheckArgumentType(
     isAngle,
     "finite real number between 0 and 360");
-var checkRotateAngle = plt.baselib.check.makeCheckArgumentType(
-    isRotateAngle,
-    "finite real number between -360 and 360");
 
 
 var checkMode = plt.baselib.check.makeCheckArgumentType(
     isMode,
-    'solid or outline or [0-255]');
+    'solid or outline');
 
 
 var checkSideCount = plt.baselib.check.makeCheckArgumentType(
@@ -183,17 +160,9 @@ var checkListofColor = plt.baselib.check.makeCheckListofArgumentType(
 
 
 
-//////////////////////////////////////////////////////////////////////
 
-EXPORTS['image=?'] =
+
-    makePrimitiveProcedure(
+//////////////////////////////////////////////////////////////////////
-        'image=?',
-        2,
-        function(MACHINE) {
-          var img1 = checkImageOrScene(MACHINE,'image=?', 0);
-          var img2 = checkImageOrScene(MACHINE,'image=?', 1);
-         return img1.equals(img2);
-        });
 
 
 EXPORTS['image-color?'] =
@@ -201,7 +170,7 @@ EXPORTS['image-color?'] =
         'image-color?',
         1,
         function(MACHINE) {
-            var elt = MACHINE.e[MACHINE.e.length - 1];
+            var elt = MACHINE.env[MACHINE.env.length - 1];
             return (isColorOrColorString(elt));
         });
 
@@ -212,7 +181,7 @@ EXPORTS['mode?'] =
         'mode?',
         1,
         function(MACHINE) {
-            return isMode(MACHINE.e[MACHINE.e.length - 1]);
+            return isMode(MACHINE.env[MACHINE.env.length - 1]);
         });
 
 EXPORTS['x-place?'] = 
@@ -220,7 +189,7 @@ EXPORTS['x-place?'] =
         'x-place?',
         1,
         function(MACHINE) {
-            return isPlaceX(MACHINE.e[MACHINE.e.length - 1]);
+            return isPlaceX(MACHINE.env[MACHINE.env.length - 1]);
         });
 
 EXPORTS['y-place?'] = 
@@ -228,7 +197,7 @@ EXPORTS['y-place?'] =
         'y-place?',
         1,
         function(MACHINE) {
-            return isPlaceY(MACHINE.e[MACHINE.e.length - 1]);
+            return isPlaceY(MACHINE.env[MACHINE.env.length - 1]);
         });
 
 EXPORTS['angle?'] = 
@@ -236,7 +205,7 @@ EXPORTS['angle?'] =
         'angle?',
         1,
         function(MACHINE) {
-            return isAngle(MACHINE.e[MACHINE.e.length - 1]);
+            return isAngle(MACHINE.env[MACHINE.env.length - 1]);
         });
 
 EXPORTS['side-count?'] = 
@@ -244,7 +213,7 @@ EXPORTS['side-count?'] =
         'side-count?',
         1,
         function(MACHINE) {
-            return isSideCount(MACHINE.e[MACHINE.e.length - 1]);
+            return isSideCount(MACHINE.env[MACHINE.env.length - 1]);
         });
 
 
@@ -253,7 +222,7 @@ EXPORTS['step-count?'] =
         'step-count?',
             1,
         function(MACHINE) {
-            return isStepCount(MACHINE.e[MACHINE.e.length - 1]);
+            return isStepCount(MACHINE.env[MACHINE.env.length - 1]);
         });
 
 
@@ -262,7 +231,7 @@ EXPORTS['image?'] =
         'image?',
             1,
         function(MACHINE) {
-            return isImage(MACHINE.e[MACHINE.e.length - 1]);
+            return isImage(MACHINE.env[MACHINE.env.length - 1]);
         });
 
 
@@ -311,17 +280,19 @@ EXPORTS['text/font'] =
         });
 
 
-EXPORTS['bitmap/url'] = 
+EXPORTS['image-url'] = 
     makeClosure(
-        'bitmap/url',
+        'image-url',
         1,
         function(MACHINE) {
-            var url = checkString(MACHINE, 'bitmap/url', 0);
+            var url = checkString(MACHINE, 'image-url', 0);
+            var oldArgcount = MACHINE.argcount;
             PAUSE(
                 function(restart) {
                     var rawImage = new Image();
                     rawImage.onload = function() {
                         restart(function(MACHINE) {
+                            MACHINE.argcount = oldArgcount;
                             finalizeClosureCall(
                                 MACHINE, 
                                 makeFileImage(url.toString(),
@@ -330,12 +301,12 @@ EXPORTS['bitmap/url'] =
                     };
                     rawImage.onerror = function(e) {
                         restart(function(MACHINE) {
-                            plt.baselib.exceptions.raiseFailure(
+                            plt.baselib.exceptions.raise(
                                 MACHINE, 
-                                plt.baselib.format.format(
+                                new Error(plt.baselib.format.format(
                                     "unable to load ~a: ~a",
-                                    [url,
+                                    url,
-                                     e.message]));
+                                    e.message)));
                         });
                     }
                     rawImage.src = url.toString();
@@ -343,100 +314,11 @@ EXPORTS['bitmap/url'] =
             );
         });
 
+
 EXPORTS['open-image-url'] = 
-    plt.baselib.functions.renameProcedure(EXPORTS['bitmap/url'],
+    plt.baselib.functions.renameProcedure(EXPORTS['image-url'],
                                           'open-image-url');
 
-EXPORTS['image-url'] = 
-    plt.baselib.functions.renameProcedure(EXPORTS['bitmap/url'],
-                                          'image-url');
-
-
-EXPORTS['video/url'] =
-    makeClosure(
-        'video/url',
-        1,
-        function(MACHINE) {
-            var path = checkString(MACHINE, 'video/url', 0);
-            PAUSE(
-                function(restart) {
-                  var rawVideo = document.createElement('video');
-                  rawVideo.src = path.toString();
-                  rawVideo.addEventListener('canplay', function() {
-                    restart(function(MACHINE) {
-                            function pause(){ rawVideo.pause(); return true;};
-                            finalizeClosureCall(
-                              MACHINE,
-                              makeFileVideo(path.toString(), rawVideo));
-//                    aState.addBreakRequestedListener(pause);
-                    });
-                  });
-                  rawVideo.addEventListener('error', function(e) {
-                    restart(function(MACHINE) {
-                        plt.baselib.exceptions.raiseFailure(
-                            MACHINE, 
-                            plt.baselib.format.format(
-                                "unable to load ~a: ~a",
-                                [url,
-                                 e.message]));
-                    });
-                  });
-                  rawVideo.src = path.toString();
-                }
-            );
-        });
-
-// We keep a cache of loaded sounds:
-var audioCache = {};
-
-EXPORTS['play-sound'] =
-    makeClosure(
-        'play-sound',
-        1,
-        function(MACHINE) {
-            var path = checkString(MACHINE, 'play-sound', 0);
-            var fileAudio = audioCache[path];
-            if (fileAudio) {
-                // the sound was already loaded
-                finalizeClosureCall(
-                    MACHINE,
-                    fileAudio.play());
-            }
-            else {
-               // this sound has never been played before
-               PAUSE(
-                   function(restart) {
-                      fileAudio = makeFileAudio(path.toString());
-                      audioCache[path] = fileAudio;
-                      // let the audio file load before playing...
-                      fileAudio.loading = true;
-                      // (fileAudio.audio is the raw html5 Audio object)
-                      fileAudio.audio.addEventListener('canplay', function() {
-                          // ignore canplay events that follow the initial load
-                          if(fileAudio.loading) {
-                            restart(function(MACHINE) {
-                              finalizeClosureCall(
-                                  MACHINE,
-                                  fileAudio.play());
-                              });
-                            fileAudio.loading = false; // we're done loading
-                          }
-                      })
-                      fileAudio.audio.addEventListener('error', function(e) {
-                          restart(function(MACHINE) {
-                              plt.baselib.exceptions.raiseFailure(
-                                  MACHINE,
-                                  plt.baselib.format.format(
-                                      "unable to load ~a: ~a",
-                                      [path,
-                                      e.message]));
-                              });
-                      });
-                  });
-            }
-        });
-
-
 
 EXPORTS['overlay'] = 
     makePrimitiveProcedure(
@@ -446,7 +328,7 @@ EXPORTS['overlay'] =
 	    var img1 = checkImage(MACHINE, "overlay", 0);
 	    var img2 = checkImage(MACHINE, "overlay", 1);
             var restImages = [];
-	    for (var i = 2; i < MACHINE.a; i++) {
+	    for (var i = 2; i < MACHINE.argcount; i++) {
 		restImages.push(checkImage(MACHINE, "overlay", i));
 	    }
             
@@ -474,22 +356,6 @@ EXPORTS['overlay/xy'] =
 				    jsnums.toFixnum(deltaY));
         });
 
-EXPORTS['overlay/offset'] = 
-    makePrimitiveProcedure(
-        'overlay/offset',
-        4,
-        function(MACHINE) {
-	    var img1 = checkImage(MACHINE, "overlay/offset", 0);
-	    var deltaX = checkReal(MACHINE, "overlay/offset", 1);
-	    var deltaY = checkReal(MACHINE, "overlay/offset", 2);
-	    var img2 = checkImage(MACHINE, "overlay/offset", 3);
-            var middleX = (img1.getWidth() - img2.getWidth()) / 2;
-            var middleY = (img1.getHeight() - img2.getHeight()) / 2;
-	    return makeOverlayImage(img1,
-				    img2,
-				    jsnums.toFixnum(middleX) + deltaX,
-				    jsnums.toFixnum(middleY) + deltaY);
-        });
 
 
  EXPORTS['overlay/align'] = 
@@ -502,7 +368,7 @@ EXPORTS['overlay/offset'] =
 	     var img1 = checkImage(MACHINE, "overlay/align", 2);
 	     var img2 = checkImage(MACHINE, "overlay/align", 3);
              var restImages = [];
-	     for (var i = 4; i < MACHINE.a; i++) {
+	     for (var i = 4; i < MACHINE.argcount; i++) {
                  restImages.push(checkImage(MACHINE, "overlay/align", i));
              }
 	     var img = makeOverlayImage(img1,
@@ -529,7 +395,7 @@ EXPORTS['underlay'] =
 	    var img1 = checkImage(MACHINE, "underlay", 0);
 	    var img2 = checkImage(MACHINE, "underlay", 1);
 	    var restImages = [];
-	    for (var i = 2; i < MACHINE.a; i++) {
+	    for (var i = 2; i < MACHINE.argcount; i++) {
 		restImages.push(checkImage(MACHINE, "underlay", i));
 	    }
 
@@ -556,23 +422,6 @@ EXPORTS['underlay/xy'] =
 				    -(jsnums.toFixnum(deltaY)));
         });
 
-EXPORTS['underlay/offset'] = 
-    makePrimitiveProcedure(
-        'underlay/offset',
-        4,
-        function(MACHINE) {
-	    var img1 = checkImage(MACHINE, "underlay/offset", 0);
-	    var deltaX = checkReal(MACHINE, "underlay/offset", 1);
-	    var deltaY = checkReal(MACHINE, "underlay/offset", 2);
-	    var img2 = checkImage(MACHINE, "underlay/offset", 3);
-            var middleX = (img1.getWidth() - img2.getWidth()) / 2;
-            var middleY = (img1.getHeight() - img2.getHeight()) / 2;
-	    return makeOverlayImage(img2,
-				    img1,
-				    -(jsnums.toFixnum(middleX) + deltaX),
-				    -(jsnums.toFixnum(middleY) + deltaY));
-        });
-
 EXPORTS['underlay/align'] = 
     makePrimitiveProcedure(
         'underlay/align',
@@ -583,7 +432,7 @@ EXPORTS['underlay/align'] =
 	    var img1 = checkImage(MACHINE, "underlay/align", 2);
 	    var img2 = checkImage(MACHINE, "underlay/align", 3);
             var restImages = [];
-            for (var i = 4; i < MACHINE.a; i++) {
+            for (var i = 4; i < MACHINE.argcount; i++) {
                 restImages.push(checkImage(MACHINE, "underlay/align", i));
             }
 	    
@@ -611,7 +460,7 @@ EXPORTS['beside'] =
 	    var img1 = checkImage(MACHINE, "beside", 0);
 	    var img2 = checkImage(MACHINE, "beside", 1);
             var restImages = [];
-	    for (var i = 2; i < MACHINE.a; i++) {
+	    for (var i = 2; i < MACHINE.argcount; i++) {
                 restImages.push(checkImage(MACHINE, "beside", i));
             }
 	    
@@ -637,7 +486,7 @@ EXPORTS['beside/align'] =
 	    var img1 = checkImage(MACHINE, "beside/align", 1);
 	    var img2 = checkImage(MACHINE, "beside/align", 2);
             var restImages = [];
-            for (var i = 3; i < MACHINE.a; i++) {
+            for (var i = 3; i < MACHINE.argcount; i++) {
                 restImages.push(checkImage(MACHINE, "beside/align", i));
             }
 
@@ -665,7 +514,7 @@ EXPORTS['above'] =
 	    var img1 = checkImage(MACHINE, "above", 0);
 	    var img2 = checkImage(MACHINE, "above", 1);
 	    var restImages = [];
-            for (var i = 2; i < MACHINE.a; i++) {
+            for (var i = 2; i < MACHINE.argcount; i++) {
                 restImages.push(checkImage(MACHINE, "above", i));
             }
 	    
@@ -692,7 +541,7 @@ EXPORTS['above/align'] =
 	    var img1 = checkImage(MACHINE, "above/align", 1);
 	    var img2 = checkImage(MACHINE, "above/align", 2);
             var restImages = [];
-            for (var i = 3; i < MACHINE.a; i++) {
+            for (var i = 3; i < MACHINE.argcount; i++) {
 	        restImages.push(checkImage(MACHINE, "above/align", i));
             }
 
@@ -717,42 +566,16 @@ EXPORTS['above/align'] =
 EXPORTS['empty-scene'] =
     makePrimitiveProcedure(
         'empty-scene',
-        plt.baselib.lists.makeList(2, 3),
+	2,
 	function(MACHINE) {
 	    var width = checkNonNegativeReal(MACHINE, 'empty-scene', 0);
 	    var height = checkNonNegativeReal(MACHINE, 'empty-scene', 1);
-            var color = (MACHINE.a===3)? checkColor(MACHINE, 'empty-scene', 2) : null;
+	    return makeSceneImage(jsnums.toFixnum(width), 
-
-            return makeSceneImage(jsnums.toFixnum(width),
                                   jsnums.toFixnum(height),
-                                  color,
                                   [],
                                   true);
 	});
 
-EXPORTS['put-image'] =
-    makePrimitiveProcedure(
-        'put-image',
-        4,
-        function(MACHINE) {
-	    var picture = checkImage(MACHINE, "put-image", 0);
-	    var x = checkReal(MACHINE, "put-image", 1);
-	    var y = checkReal(MACHINE, "put-image", 2);
-            var background = checkImageOrScene(MACHINE, "place-image", 3);
-	    if (isScene(background)) {
-		return background.add(picture, jsnums.toFixnum(x), background.getHeight() - jsnums.toFixnum(y));
-	    } else {
-                var newScene = makeSceneImage(background.getWidth(),
-                                              background.getHeight(),
-                                              null,
-                                              [],
-                                              false);
-		newScene = newScene.add(background, background.getWidth()/2, background.getHeight()/2);
-          newScene = newScene.add(picture, jsnums.toFixnum(x), background.getHeight() - jsnums.toFixnum(y));
-		return newScene;
-	    }
-
-        });
 
 
 EXPORTS['place-image'] = 
@@ -767,13 +590,12 @@ EXPORTS['place-image'] =
 	    if (isScene(background)) {
 		return background.add(picture, jsnums.toFixnum(x), jsnums.toFixnum(y));
 	    } else {
-                var newScene = makeSceneImage(background.getWidth(),
+		var newScene = makeSceneImage(background.getWidth(),
-                                              background.getHeight(),
+					      background.getHeight(),
-                                              null,
+					      [], 
-                                              [],
+					      false);
-                                              false);
+		newScene = newScene.add(background.updatePinhole(0, 0), 0, 0);
-		newScene = newScene.add(background, background.getWidth()/2, background.getHeight()/2);
+		newScene = newScene.add(picture, jsnums.toFixnum(x), jsnums.toFixnum(y));
-          newScene = newScene.add(picture, jsnums.toFixnum(x), jsnums.toFixnum(y));
 		return newScene;
 	    }
 
@@ -787,55 +609,49 @@ EXPORTS['place-image/align'] =
         6,
         function(MACHINE) {
 	    var img = checkImage(MACHINE, "place-image/align", 0);
-	    var x = jsnums.toFixnum(checkReal(MACHINE, "place-image/align", 1));
+	    var x = checkReal(MACHINE, "place-image/align", 1);
-	    var y = jsnums.toFixnum(checkReal(MACHINE, "place-image/align", 2));
+	    var y = checkReal(MACHINE, "place-image/align", 2);
 	    var placeX = checkPlaceX(MACHINE, "place-image/align", 3);
 	    var placeY = checkPlaceY(MACHINE, "place-image/align", 4);
 	    var background = checkImageOrScene(MACHINE, "place-image/align", 5);
 	    
-            var pinholeX = img.pinholeX || img.getWidth() / 2;
-            var pinholeY = img.pinholeY || img.getHeight() / 2;
-
 	    // calculate x and y based on placeX and placeY
-	    if (placeX == "left") x = x + pinholeX;
+	    if (placeX == "left") x = x + img.pinholeX;
-	    else if (placeX == "right") x = x - pinholeX;
+	    else if (placeX == "right") x = x - img.pinholeX;
-	    if (placeY == "top") y = y + pinholeY;
+	    if (placeY == "top") y = y + img.pinholeY;
-	    else if (placeY == "bottom") y = y - pinholeY;
+	    else if (placeY == "bottom") y = y - img.pinholeY;
 
 	    if (isScene(background)) {
-		return background.add(img, x, y);
+		return background.add(img, jsnums.toFixnum(x), jsnums.toFixnum(y));
 	    } else {
-                var newScene = makeSceneImage(background.getWidth(),
+		var newScene = makeSceneImage(background.getWidth(),
-                                              background.getHeight(),
+					      background.getHeight(),
-                                              null,
+					      [], 
-                                              [],
+					      false);
-                                              false);
+		newScene = newScene.add(background.updatePinhole(0, 0), 0, 0);
-		newScene = newScene.add(background, background.getWidth()/2, background.getHeight()/2);
+		newScene = newScene.add(img, jsnums.toFixnum(x), jsnums.toFixnum(y));
-                newScene = newScene.add(img, x, y);
 		return newScene;
             }
         });
 
-//////////////////////////////////////////////////////////////////////
+
-// rotate: angle image -> image
+
-// Rotates image by angle degrees in a counter-clockwise direction.
+
+
+
+
 EXPORTS['rotate'] = 
     makePrimitiveProcedure(
         'rotate',
         2,
         function(MACHINE) {
-	    var angle = checkRotateAngle(MACHINE, "rotate", 0);
+	    var angle = checkAngle(MACHINE, "rotate", 0);
-	    var angle360 = angle % 360;
 	    var img = checkImage(MACHINE, "rotate", 1);
-	    // convert to clockwise rotation for makeRotateImage
+	    return makeRotateImage(jsnums.toFixnum(-angle), img);
-	    if (angle360 < 0) {
-		return makeRotateImage(jsnums.toFixnum(-(360 + angle360)), img);
-	    } else {
-		return makeRotateImage(jsnums.toFixnum(-angle360), img);
-	    }
         });
 
 
+
 EXPORTS['scale'] = 
     makePrimitiveProcedure(
         'scale',
@@ -946,7 +762,7 @@ EXPORTS['add-line'] =
 				     jsnums.toFixnum(y2-y1),
 				     c,
 				     true);
-	    return makeOverlayImage(line, img, x1, y1);
+	    return makeOverlayImage(line, img, "middle", "middle");
         });
 
 
@@ -963,21 +779,18 @@ EXPORTS['scene+line'] =
 	    var y2 = checkReal(MACHINE,	"scene+line", 4);
 	    var c = checkColor(MACHINE, "scene+line", 5);
 	    // make a scene containing the image
-            var newScene = makeSceneImage(jsnums.toFixnum(img.getWidth()), 
+	    var newScene = makeSceneImage(jsnums.toFixnum(img.getWidth()), 
-                                          jsnums.toFixnum(img.getHeight()),
+					  jsnums.toFixnum(img.getHeight()), 
-                                          null,
+					  [],
-                                          [],
+					  true);
-                                          false);
+	    newScene = newScene.add(img.updatePinhole(0, 0), 0, 0);
-	    newScene = newScene.add(img, img.getWidth()/2, img.getHeight()/2);
 	    // make an image containing the line
 	    var line = makeLineImage(jsnums.toFixnum(x2-x1),
-                               jsnums.toFixnum(y2-y1),
+				     jsnums.toFixnum(y2-y1),
-                               c,
+				     c,
-                               false),
+				     false);
-          leftMost = Math.min(x1,x2),
-          topMost = Math.min(y1,y2);
 	    // add the line to scene, offset by the original amount
-	    return newScene.add(line, line.getWidth()/2+leftMost, line.getHeight()/2+topMost);
+	    return newScene.add(line, jsnums.toFixnum(x1), jsnums.toFixnum(y1));
         });
 
 
@@ -1019,26 +832,8 @@ EXPORTS['rectangle'] =
 				      s.toString(), 
                                       c);
         });
-/*
 
- need to port over checks for isListofPosns and isListOfLength
 
-EXPORTS['polygon'] =
-    makePrimitiveProcedure(
-        'polygon',
-        3,
-        function(MACHINE) {
-      function isPosnList(lst){ return isListOf(lst, types.isPosn); }
-	    var points = checkListOfLength(MACHINE, "polygon", 0);
-	    var points = checkListOfPosns(MACHINE, "polygon", 0);
-	    var s = checkMode(MACHINE, "polygon", 2);
-      var c = checkColor(MACHINE, "polygon", 3);
-	    return makePosnImage(points,
-				    s.toString(),
-				    c);            
-        });
-
-*/
 EXPORTS['regular-polygon'] = 
     makePrimitiveProcedure(
         'regular-polygon',
@@ -1082,217 +877,12 @@ EXPORTS['triangle'] =
 	    var m = checkMode(MACHINE, "triangle", 1);
 	    var c = checkColor(MACHINE, "triangle", 2);
 	    return makeTriangleImage(jsnums.toFixnum(s), 
-                                        jsnums.toFixnum(360-60),
+				     60, 
-                                        jsnums.toFixnum(s),
+				     m.toString(),
-                                        m.toString(),
+				     c);
-                                        c);
         });
 
 
-EXPORTS['triangle/sas'] =
-    makePrimitiveProcedure(
-        'triangle/sas',
-        5,
-        function(MACHINE) {
-	    var sideA = checkNonNegativeReal(MACHINE, "triangle/sas", 0);
-	    var angleB = checkAngle(MACHINE, "triangle/sas", 1);
-      var sideC = checkNonNegativeReal(MACHINE, "triangle/sas", 2);
-	    var style = checkMode(MACHINE, "triangle/sas", 3);
-	    var color = checkColor(MACHINE, "triangle/sas", 4);
-       // cast to fixnums
-       sideA = jsnums.toFixnum(sideA); angleB = jsnums.toFixnum(angleB); sideC = jsnums.toFixnum(sideC);
-       var sideB2 = cosRel(sideA, sideC, angleB);
-       var sideB  = Math.sqrt(sideB2);
-              
-       if (sideB2 <= 0) {
-         raise( types.incompleteExn(types.exnFailContract, "The given side, angle and side will not form a triangle: "
-                                    + sideA + ", " + angleB + ", " + sideC, []) );
-       } else {
-        if (less(sideA + sideC, sideB) ||
-            less(sideB + sideC, sideA) ||
-            less(sideA + sideB, sideC)) {
-         raise( types.incompleteExn(types.exnFailContract, "The given side, angle and side will not form a triangle: "
-                                    + sideA + ", " + angleB + ", " + sideC, []) );
-        }
-       }
-
-       var angleA = Math.acos(excess(sideB, sideC, sideA) / (2 * sideB * sideC)) * (180 / Math.PI);
-
-	    return makeTriangleImage(jsnums.toFixnum(sideC),
-                                         jsnums.toFixnum(angleA),
-                                         jsnums.toFixnum(sideB),
-                                         style.toString(),
-                                         color);
-        });
-
-EXPORTS['triangle/sss'] =
-    makePrimitiveProcedure(
-        'triangle/sss',
-        5,
-        function(MACHINE) {
-	    var sideA = checkNonNegativeReal(MACHINE, "triangle/sss", 0);
-      var sideB = checkNonNegativeReal(MACHINE, "triangle/sss", 1);
-      var sideC = checkNonNegativeReal(MACHINE, "triangle/sss", 2);
-	    var style = checkMode(MACHINE, "triangle/sss", 3);
-	    var color = checkColor(MACHINE, "triangle/sss", 4);
-      // cast to fixnums
-      sideA = jsnums.toFixnum(sideA); sideB = jsnums.toFixnum(sideB); sideC = jsnums.toFixnum(sideC);
-      if (less(sideA + sideB, sideC) ||
-            less(sideC + sideB, sideA) ||
-            less(sideA + sideC, sideB)) {
-        raise( types.incompleteExn(types.exnFailContract, "The given sides will not form a triangle: "
-                                    + sideA+", "+sideB+", "+sideC, []) );
-      }
-
-      var angleA = Math.acos(excess(sideB, sideC, sideA) / (2 * sideB * sideC)) * (180 / Math.PI);
-	    return makeTriangleImage(jsnums.toFixnum(sideC),
-                                         jsnums.toFixnum(angleA),
-                                         jsnums.toFixnum(sideB),
-                                         style.toString(),
-                                         color);
-        });
-
-EXPORTS['triangle/ass'] =
-    makePrimitiveProcedure(
-        'triangle/ass',
-        5,
-        function(MACHINE) {
-	    var angleA = checkAngle(MACHINE, "triangle/ass", 0);
-	    var sideB = checkNonNegativeReal(MACHINE, "triangle/ass", 1);
-      var sideC = checkNonNegativeReal(MACHINE, "triangle/ass", 2);
-	    var style = checkMode(MACHINE, "triangle/ass", 3);
-	    var color = checkColor(MACHINE, "triangle/ass", 4);
-       // cast to fixnums
-       angleA = jsnums.toFixnum(angleA); sideB = jsnums.toFixnum(sideB); sideC = jsnums.toFixnum(sideC);
-       if (colorDb.get(color)) { color = colorDb.get(color); }
-       if (less(180, angleA)) {
-         raise( types.incompleteExn(types.exnFailContract, "The given angle, side and side will not form a triangle: "
-                                    + angleA + ", " + sideB + ", " + sideC, []) );
-       }
-	    return makeTriangleImage(jsnums.toFixnum(sideC),
-                                        jsnums.toFixnum(angleA),
-                                        jsnums.toFixnum(sideB),
-                                        style.toString(),
-                                        color);
-        });
-
-EXPORTS['triangle/ssa'] =
-    makePrimitiveProcedure(
-        'triangle/ssa',
-        5,
-        function(MACHINE) {
-	    var sideA = checkNonNegativeReal(MACHINE, "triangle/ssa", 0);
-      var sideB = checkNonNegativeReal(MACHINE, "triangle/ssa", 1);
-	    var angleC = checkAngle(MACHINE, "triangle/ssa", 2);
-	    var style = checkMode(MACHINE, "triangle/ssa", 3);
-	    var color = checkColor(MACHINE, "triangle/ssa", 4);
-         // cast to fixnums
-         sideA = jsnums.toFixnum(sideA); sideB = jsnums.toFixnum(sideB); angleC = jsnums.toFixnum(angleC);
-         if (less(180, angleC)) {
-           raise( types.incompleteExn(types.exnFailContract, "The given side, side and angle will not form a triangle: "
-                                      + sideA + ", " + sideB + ", " + angleC, []) );
-         }
-         var sideC2 = cosRel(sideA, sideB, angleC);
-         var sideC  = Math.sqrt(sideC2);
-        
-         if (sideC2 <= 0) {
-           raise( types.incompleteExn(types.exnFailContract, "The given side, side and angle will not form a triangle: "
-                                      + sideA + ", " + sideB + ", " + angleC, []) );
-         } else {
-           if (less(sideA + sideB, sideC) ||
-               less(sideC + sideB, sideA) ||
-               less(sideA + sideC, sideB)) {
-           raise( types.incompleteExn(types.exnFailContract, "The given side, side and angle will not form a triangle: "
-                                      + sideA + ", " + sideB + ", " + angleC, []) );
-           }
-         }
-
-         var angleA = Math.acos(excess(sideB, sideC, sideA) / (2 * sideB * sideC)) * (180 / Math.PI);
-	    return makeTriangleImage(jsnums.toFixnum(sideC),
-                                          jsnums.toFixnum(angleA),
-                                          jsnums.toFixnum(sideB),
-                                          style.toString(),
-                                          color);
-        });
-
-EXPORTS['triangle/aas'] =
-    makePrimitiveProcedure(
-        'triangle/aas',
-        5,
-        function(MACHINE) {
-	    var angleA = checkAngle(MACHINE, "triangle/aas", 0);
-	    var angleB = checkAngle(MACHINE, "triangle/aas", 1);
-      var sideC = checkNonNegativeReal(MACHINE, "triangle/aas", 2);
-	    var style = checkMode(MACHINE, "triangle/aas", 3);
-	    var color = checkColor(MACHINE, "triangle/aas", 4);
-      // cast to fixnums
-      var angleA = jsnums.toFixnum(angleA); angleB = jsnums.toFixnum(angleB); sideC = jsnums.toFixnum(sideC);
-      var angleC = (180 - angleA - angleB);
-      if (less(angleC, 0)) {
-         raise( types.incompleteExn(types.exnFailContract, "The given angle, angle and side will not form a triangle: "
-                                    + angleA + ", " + angleB + ", " + sideC, []) );
-      }
-      var hypotenuse = sideC / (Math.sin(angleC*Math.PI/180))
-      var sideB = hypotenuse * Math.sin(angleB*Math.PI/180);
-	    return makeTriangleImage(jsnums.toFixnum(sideC),
-                                          jsnums.toFixnum(angleA),
-                                          jsnums.toFixnum(sideB),
-                                          style.toString(),
-                                          color);
-        });
-
-
-EXPORTS['triangle/asa'] =
-    makePrimitiveProcedure(
-        'triangle/asa',
-        5,
-        function(MACHINE) {
-	    var angleA = checkAngle(MACHINE, "triangle/asa", 0);
-      var sideB = checkNonNegativeReal(MACHINE, "triangle/asa", 1);
-	    var angleC = checkAngle(MACHINE, "triangle/asa", 2);
-	    var style = checkMode(MACHINE, "triangle/asa", 3);
-	    var color = checkColor(MACHINE, "triangle/asa", 4);
-      // cast to fixnums
-      var angleA = jsnums.toFixnum(angleA); sideB = jsnums.toFixnum(sideB); angleC = jsnums.toFixnum(angleC);
-      var angleB = (180 - angleA - angleC);
-      if (less(angleB, 0)) {
-        raise( types.incompleteExn(types.exnFailContract, "The given angle, side and angle will not form a triangle: "
-                                   + angleA + ", " + sideB + ", " + angleC, []) );
-      }
-      var base = (sideB * Math.sin(angleA*Math.PI/180)) / (Math.sin(angleB*Math.PI/180));
-      var sideC = (sideB * Math.sin(angleC*Math.PI/180)) / (Math.sin(angleB*Math.PI/180));
-	    return makeTriangleImage(jsnums.toFixnum(sideC),
-                                             jsnums.toFixnum(angleA),
-                                             jsnums.toFixnum(sideB),
-                                             style.toString(),
-                                             color);
-        });
-
-EXPORTS['triangle/saa'] =
-    makePrimitiveProcedure(
-        'triangle/saa',
-        5,
-        function(MACHINE) {
-	    var sideA = checkNonNegativeReal(MACHINE, "triangle/saa", 0);
-      var angleB = checkAngle(MACHINE, "triangle/saa", 1);
-	    var angleC = checkAngle(MACHINE, "triangle/saa", 2);
-	    var style = checkMode(MACHINE, "triangle/saa", 3);
-	    var color = checkColor(MACHINE, "triangle/saa", 4);
-       // cast to fixnums
-       var sideA = jsnums.toFixnum(sideA); angleB = jsnums.toFixnum(angleB); angleC = jsnums.toFixnum(angleC);
-       var angleA = (180 - angleC - angleB);
-       var hypotenuse = sideA / (Math.sin(angleA*Math.PI/180));
-       var sideC = hypotenuse * Math.sin(angleC*Math.PI/180);
-       var sideB = hypotenuse * Math.sin(angleB*Math.PI/180);
-	    return makeTriangleImage(jsnums.toFixnum(sideC),
-                                               jsnums.toFixnum(angleA),
-                                               jsnums.toFixnum(sideB),
-                                               style.toString(),
-                                               color);
-        });
-
-
-
 EXPORTS['right-triangle'] = 
     makePrimitiveProcedure(
         'right-triangle',
@@ -1302,11 +892,10 @@ EXPORTS['right-triangle'] =
 	    var side2 = checkNonNegativeReal(MACHINE, "right-triangle", 1);
 	    var s = checkMode(MACHINE, "right-triangle", 2);
 	    var c = checkColor(MACHINE, "right-triangle", 3);
-	    return makeTriangleImage(jsnums.toFixnum(side1),
+	    return makeRightTriangleImage(jsnums.toFixnum(side1), 
-                               jsnums.toFixnum(360-90),
+                                          jsnums.toFixnum(side2),
-                               jsnums.toFixnum(side2),
+                                          s.toString(),
-                               s.toString(),
+                                          c);
-                               c);
         });
 
 
@@ -1316,18 +905,13 @@ EXPORTS['isosceles-triangle'] =
         4,
         function(MACHINE) {
 	    var side = checkNonNegativeReal(MACHINE, "isosceles-triangle", 0);
-	    var angleC = checkAngle(MACHINE, "isosceles-triangle", 1);
+	    var angle = checkAngle(MACHINE, "isosceles-triangle", 1);
 	    var s = checkMode(MACHINE, "isosceles-triangle", 2);
 	    var c = checkColor(MACHINE, "isosceles-triangle", 3);
-      // cast to fixnums
+	    return makeTriangleImage(jsnums.toFixnum(side), 
-      side = jsnums.toFixnum(side); angleC = jsnums.toFixnum(angleC);
+                                     jsnums.toFixnum(angle), 
-      var angleAB = (180-angleC)/2;
+                                     s.toString(),
-      var base = 2*side*Math.sin((angleC*Math.PI/180)/2);
+                                     c);
-	    return makeTriangleImage(jsnums.toFixnum(base),
-                                         jsnums.toFixnum(360-angleAB),// add 180 to make the triangle point up
-                                         jsnums.toFixnum(side),
-                                         s.toString(),
-                                         c);
         });
 
 
@@ -1336,7 +920,7 @@ EXPORTS['star'] =
         'star',
         plt.baselib.lists.makeList(3, 5),
         function(MACHINE) {
-            if (MACHINE.a === 3) {
+            if (MACHINE.argcount === 3) {
                 var sideLength = checkNonNegativeReal(MACHINE, "star", 0);
 		var mode = checkMode(MACHINE, "star", 1);
 		var color = checkColor(MACHINE, "star", 2);
@@ -1345,7 +929,7 @@ EXPORTS['star'] =
 					jsnums.toFixnum(2), 
 					mode.toString(), 
 					color);
-            } else if (MACHINE.a === 5) {
+            } else if (MACHINE.argcount === 5) {
 		var n = checkSideCount(MACHINE, "star", 0);
 		var outer = checkNonNegativeReal(MACHINE, "star", 1);
 		var inner = checkNonNegativeReal(MACHINE, "star", 2);
@@ -1442,20 +1026,6 @@ EXPORTS['color-list->image'] =
                                     pinholeY);
         });
 
-EXPORTS['color-list->bitmap'] = 
-    makePrimitiveProcedure(
-        'color-list->image',
-        3,
-        function(MACHINE) {
-            var listOfColors = checkListofColor(MACHINE, 'color-list->image', 0);
-	    var width = checkNatural(MACHINE, 'color-list->image', 1);
-	    var height = checkNatural(MACHINE, 'color-list->image', 2);
-            return colorListToImage(listOfColors,
-                                    width,
-                                    height,
-                                    0,
-                                    0);
-        });
 
 
 EXPORTS['image-width'] = 
@@ -1486,12 +1056,7 @@ EXPORTS['image-baseline'] =
         });
 
 
-EXPORTS['name->color'] = 
+
-    makePrimitiveProcedure(
+
-        'name->color',
+
-        1,
+
-        function(MACHINE) {
-            var name = checkSymbolOrString(MACHINE, 'name->color', 0);
-            var result = colorDb.get('' + name) || false;
-            return result;
-        });

image/private/main.rkt

@@ -12,18 +12,12 @@
                "js-impl.js")
  #:provided-values (text
                     text/font
-                    
+                    image-url
-                    bitmap/url
+                    open-image-url
-                    image-url      ;; older name for bitmap/url
-                    open-image-url ;; older name for bitmap/url
-                    video/url
-                    play-sound
                     overlay
-                    overlay/offset
                     overlay/xy
                     overlay/align
                     underlay
-                    underlay/offset
                     underlay/xy
                     underlay/align
                     beside
@@ -31,7 +25,6 @@
                     above
                     above/align
                     empty-scene
-                    put-image
                     place-image
                     place-image/align
                     rotate
@@ -47,17 +40,9 @@
                     circle
                     square
                     rectangle
-                    polygon
                     regular-polygon
                     ellipse
                     triangle
-                    triangle/sas
-                    triangle/sss
-                    triangle/ass
-                    triangle/ssa
-                    triangle/aas
-                    triangle/asa
-                    triangle/saa
                     right-triangle
                     isosceles-triangle
                     star
@@ -66,7 +51,6 @@
                     rhombus
                     image->color-list
                     color-list->image
-                    color-list->bitmap
                     image-width
                     image-height
                     image-baseline
@@ -77,7 +61,9 @@
                     angle?
                     side-count?
                     step-count?
+
                     image?
-                    image=?
+                    
-                    name->color
                     ))
+
+

image/private/racket-impl.rkt

@@ -0,0 +1,89 @@
+#lang s-exp "../../lang/base.rkt"
+
+(require 2htdp/image
+         (for-syntax racket/base))
+
+(provide text
+         text/font
+         image-url
+         open-image-url
+         overlay
+         overlay/xy
+         overlay/align
+         underlay
+         underlay/xy
+         underlay/align
+         beside
+         beside/align
+         above
+         above/align
+         empty-scene
+         place-image
+         place-image/align
+         rotate
+         scale
+         scale/xy
+         flip-horizontal
+         flip-vertical
+         frame
+         crop
+         line
+         add-line
+         scene+line
+         circle
+         square
+         rectangle
+         regular-polygon
+         ellipse
+         triangle
+         right-triangle
+         isosceles-triangle
+         star
+         radial-star
+         star-polygon
+         rhombus
+         image->color-list
+         color-list->image
+         image-width
+         image-height
+         image-baseline
+         image-color?
+         mode?
+         x-place?
+         y-place?
+         angle?
+         side-count?
+         image-color?
+
+
+         image?
+
+         ;; Something funky is happening on the Racket side of things with regards
+         ;; to step-count?  See:  http://bugs.racket-lang.org/query/?cmd=view&pr=12031
+         ;; step-count?
+         )
+
+
+
+(define-syntax (define-stubs stx)
+  (syntax-case stx ()
+    [(_ f ...)
+     (syntax/loc stx
+       (begin
+         (define f (lambda args (error 'f))) ...))]))
+
+
+
+(define-stubs
+  image-url
+  open-image-url
+  color-list->image
+           )
+
+
+
+(define (my-step-count? x)
+  (and (integer? x)
+       (>= x 1)))
+
+(provide (rename-out [my-step-count? step-count?]))

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.02")
+(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 "RUNTIME.makeSymbol(~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)
+      "RUNTIME.NEGATIVE_ZERO"]
+     [(eqv? a-num +inf.0)
+      "RUNTIME.INF"]
+     [(eqv? a-num -inf.0)
+      "RUNTIME.NEGATIVE_INF"]
+     [(eqv? a-num +nan.0)
+      "RUNTIME.NAN"]
+     [else
+      (string-append "RUNTIME.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 "RUNTIME.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 "RUNTIME.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 "RUNTIME.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.makeArityAtLeast(~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.makeArityAtLeast(~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

@@ -4,35 +4,18 @@
          "../compiler/il-structs.rkt"
          "../compiler/lexical-structs.rkt"
          "../compiler/kernel-primitives.rkt"
-         "assemble-structs.rkt"
          racket/string
          racket/list
          typed/rackunit)
 
 (provide open-code-kernel-primitive-procedure)
 
-;; Conservative estimate: JavaScript evaluators don't like to eat
-;; more than some number of arguments at once.
-(define MAX-JAVASCRIPT-ARGS-AT-ONCE 100)
 
 
-;; Workaround for a regression in Racket 5.3.1: 
+(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
-(define-syntax-rule (mycase op ((x ...) b ...) ...)
+(define (open-code-kernel-primitive-procedure op)
-  (let ([v op])
-    (cond
-      [(or (eqv? v 'x) ...) b ...] ...)))
-
-
-(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure Blockht -> String))
-(define (open-code-kernel-primitive-procedure op blockht)
   (let*: ([operator : KernelPrimitiveName/Inline (CallKernelPrimitiveProcedure-operator op)]
-          [operands : (Listof String) (map (lambda: ([op : (U OpArg ModuleVariable)])
+          [operands : (Listof String) (map assemble-oparg (CallKernelPrimitiveProcedure-operands op))]
-                                                    (cond
-                                                     [(OpArg? op)
-                                                      (assemble-oparg op blockht)]
-                                                     [(ModuleVariable? op)
-                                                      (assemble-module-variable-ref op)]))
-                                           (CallKernelPrimitiveProcedure-operands op))]
           [checked-operands : (Listof String)
                             (map (lambda: ([dom : OperandDomain]
 					   [pos : Natural]
@@ -43,42 +26,33 @@
                                  (build-list (length operands) (lambda: ([i : Natural]) i))
                                  operands
                                  (CallKernelPrimitiveProcedure-typechecks? op))])
-        (mycase operator
+        (case operator
           [(+)
            (cond [(empty? checked-operands)
                   (assemble-numeric-constant 0)]
-                 [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
-                  (format "RT.checkedAdd(M, ~a)" (string-join operands ","))]
                  [else
-                  (format "RT.checkedAddSlowPath(M, [~a])" (string-join operands ","))])]
+                  (assemble-binop-chain "plt.baselib.numbers.add" checked-operands)])]
           
           [(-)
            (cond [(empty? (rest checked-operands))
-                  (format "RT.checkedNegate(M, ~a)" (first operands))]
+                  (assemble-binop-chain "plt.baselib.numbers.subtract" (cons "0" checked-operands))]
-                 [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
-                  (format "RT.checkedSub(M, ~a)" (string-join operands ","))]
                  [else
-                  (format "RT.checkedSubSlowPath(M, [~a])" (string-join operands ","))])]
+                  (assemble-binop-chain "plt.baselib.numbers.subtract" checked-operands)])]
           
           [(*)
            (cond [(empty? checked-operands)
                   (assemble-numeric-constant 1)]
-                 [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
-                  (format "RT.checkedMul(M, ~a)" (string-join operands ","))]
                  [else
-                  (format "RT.checkedMulSlowPath(M, [~a])" (string-join operands ","))])]
+                  (assemble-binop-chain "plt.baselib.numbers.multiply" checked-operands)])]
 
           [(/)
            (assemble-binop-chain "plt.baselib.numbers.divide" checked-operands)]
 
-          [(zero?)
-           (format "RT.checkedIsZero(M, ~a)" (first operands))]
-
           [(add1)
-           (format "RT.checkedAdd1(M, ~a)" (first operands))]
+           (assemble-binop-chain "plt.baselib.numbers.add" (cons "1" checked-operands))]
           
           [(sub1)
-           (format "RT.checkedSub1(M, ~a)" (first operands))]
+           (assemble-binop-chain "plt.baselib.numbers.subtract" (append checked-operands (list "1")))]
 
           [(<)
            (assemble-boolean-chain "plt.baselib.numbers.lessThan" checked-operands)]
@@ -87,64 +61,37 @@
            (assemble-boolean-chain "plt.baselib.numbers.lessThanOrEqual" checked-operands)]
           
           [(=)
-           (cond
+           (assemble-boolean-chain "plt.baselib.numbers.equals" checked-operands)]
-            [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
-             (format "RT.checkedNumEquals(M, ~a)" (string-join operands ","))]
-            [else
-             (format "RT.checkedNumEqualsSlowPath(M, [~a])" (string-join operands ","))])]
           
           [(>)
-           (cond
+           (assemble-boolean-chain "plt.baselib.numbers.greaterThan" checked-operands)]
-            [(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
-             (format "RT.checkedGreaterThan(M, ~a)" (string-join operands ","))]
-            [else
-             (format "RT.checkedGreaterThanSlowPath(M, [~a])" (string-join operands ","))])]
           
           [(>=)
            (assemble-boolean-chain "plt.baselib.numbers.greaterThanOrEqual" checked-operands)]
           
           [(cons)
-           (format "RT.makePair(~a,~a)"
+           (format "RUNTIME.makePair(~a, ~a)"
                    (first checked-operands)
                    (second checked-operands))]
 
           [(car)
-           (format "RT.checkedCar(M, ~a)" (first operands))]
+           (format "(~a).first" (first checked-operands))]
-
-          [(caar)
-           (format "(~a).first.first" (first checked-operands))]
           
           [(cdr)
-           (format "RT.checkedCdr(M, ~a)" (first operands))]
+           (format "(~a).rest" (first checked-operands))]
           
           [(list)
            (let loop ([checked-operands checked-operands])
              (assemble-listof-assembled-values checked-operands))]
           
-          [(list?)
-           (format "RT.isList(~a)"
-                   (first checked-operands))]
-
-          [(vector-ref)
-           (format "RT.checkedVectorRef(M, ~a)"
-                   (string-join operands ","))]
-
-          [(vector-set!)
-           (format "RT.checkedVectorSet(M, ~a)"
-                   (string-join operands ","))]
-          
-          [(pair?)
-           (format "RT.isPair(~a)"
-                   (first checked-operands))]
-          
           [(null?)
-           (format "(~a===RT.NULL)" (first checked-operands))]
+           (format "(~a === RUNTIME.NULL)" (first checked-operands))]
 
           [(not)
-           (format "(~a===false)" (first checked-operands))]
+           (format "(~a === false)" (first checked-operands))]
           
           [(eq?)
-           (format "(~a===~a)" (first checked-operands) (second checked-operands))])))
+           (format "(~a === ~a)" (first checked-operands) (second checked-operands))])))
 
 
 
@@ -169,6 +116,8 @@
 
 
 
+
+
 (: assemble-boolean-chain (String (Listof String) -> String))
 (define (assemble-boolean-chain rator rands)
   (string-append "("
@@ -194,28 +143,28 @@
     [(eq? domain 'any)
      operand-string]
     [else
-     (let: ([predicate : String
+     (let: ([test-string : String
                          (case domain
                            [(number)
-                            (format "RT.isNumber")]
+                            (format "RUNTIME.isNumber(~a)"
+                                    operand-string)]             
                            [(string)
-                            (format "RT.isString")]
+                            (format "(typeof(~a) === 'string')"
+                                    operand-string)]
                            [(list)
-                            (format "RT.isList")]
+                            (format "RUNTIME.isList(~a)" operand-string)]
                            [(pair)
-                            (format "RT.isPair")]
+                            (format "RUNTIME.isPair(~a)" operand-string)]
-                           [(caarpair)
-                            (format "RT.isCaarPair")]
                            [(box)
-                            (format "RT.isBox")]
+                            (format "(typeof(~a) === 'object' && (~a).length === 1)"
-                           [(vector)
+                                    operand-string operand-string)])])
-                            (format "RT.isVector")])])
+           (format "((~a) ? (~a) : RUNTIME.raiseArgumentTypeError(MACHINE, ~s, ~s, ~s, ~a))"
-           (format "RT.testArgument(M,~s,~a,~a,~a,~s)"
+                   test-string
-                   (symbol->string domain)
-                   predicate
                    operand-string
+		   (symbol->string caller)
+                   (symbol->string domain)
                    pos
-                   (symbol->string caller)))]))
+                   operand-string))]))
 
 
 (: maybe-typecheck-operand (Symbol OperandDomain Natural String Boolean -> 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

@@ -0,0 +1,35 @@
+#lang typed/racket/base
+
+(provide (all-defined-out))
+
+
+(require "../compiler/il-structs.rkt")
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Assembly
+
+(define-struct: BasicBlock ([name : Symbol] 
+                            [stmts : (Listof StraightLineStatement)]
+                            [jump : Jump]) 
+  #:transparent)
+
+
+
+
+(define-struct: ComputedJump ([label : (U Reg
+                                          ModuleEntry
+                                          CompiledProcedureEntry)])
+  #:transparent)
+(define-struct: DirectJump ([label : Symbol])
+  #:transparent)
+(define-struct: ConditionalJump ([op : PrimitiveTest]
+                                 [true-label : Symbol]
+                                 [false-label : Symbol])
+  #:transparent)
+
+(define-type Jump (U ComputedJump
+                     DirectJump
+                     ConditionalJump
+                     False))

js-assembler/assemble.rkt

@@ -0,0 +1,265 @@
+#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"
+         "optimize-basic-blocks.rkt"
+         "fracture.rkt"
+         racket/string
+         racket/list)
+
+(provide assemble/write-invoke
+         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)
+                       (optimize-basic-blocks (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)))))))
+
+
+
+
+
+
+(: 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)]
+             [(TestAndJumpStatement? 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){
+    if(--MACHINE.callsBeforeTrampoline < 0) {
+        throw ~a;
+    }
+    ~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))]
+     
+     [(TestAndJumpStatement? stmt)
+      (let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)]
+              [jump : String (assemble-jump 
+                       (make-Label (TestAndJumpStatement-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))]
+   [(TestAndJumpStatement? stmt)
+    (list (TestAndJumpStatement-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/fracture.rkt

@@ -0,0 +1,126 @@
+#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)
+
+;; Takes a sequence of statements, and breaks them down into basic
+;; blocks.
+;;
+;; A basic block consists of a name, a sequence of straight-line statements,
+;; followed by a Jump (conditional, direct, or end-of-program).
+
+(provide fracture)
+
+
+
+
+;; Make sure:
+;;
+;; The statements are non-empty, by adding a leading label if necessary
+;; Filter out statements that are unreachable by jumps.
+;; Eliminate redundant GOTOs.
+(: cleanup-statements ((Listof Statement) -> (Listof Statement)))
+(define (cleanup-statements 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))])
+    stmts))
+         
+
+
+
+
+
+
+;; ;; 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])
+;;                (cond
+;;                  [(null? stmts)
+;;                   (reverse (cons (make-BasicBlock name (reverse acc) #f)
+;;                                  basic-blocks))]
+;;                  [else
+
+;;                   (: do-on-label (Symbol -> (Listof BasicBlock)))
+;;                   (define (do-on-label label-name)
+;;                     (loop label-name
+;;                           '()
+;;                           (cons (make-BasicBlock 
+;;                                  name  
+;;                                  (reverse acc)
+;;                                  (make-DirectJump label-name))
+;;                                 basic-blocks)
+;;                           (cdr stmts))
+;;                     )
+
+;;                   (let: ([first-stmt : Statement (car stmts)])
+;;                     (cond
+;;                      [(symbol? first-stmt)
+;;                       (do-on-label first-stmt)]
+
+;;                      [(LinkedLabel? first-stmt)
+;;                       (do-on-label (LinkedLabel-label first-stmt))]
+
+;;                      [(GotoStatement? first-stmt)
+;;                       (let ([target (GotoStatement-target first-stmt)])
+;;                         (cond
+;;                          [(Label? target)
+;;                           (loop ...?
+;;                                 '()
+;;                                 (cons (make-BasicBlock 
+;;                                        name  
+;;                                        (reverse acc)
+;;                                        (make-DirectJump label-name))
+;;                                       basic-blocks)
+;;                                 (cdr stmts))]
+;;                          [else
+;;                           (loop ...?
+;;                                 '()
+;;                                 (cons (make-BasicBlock 
+;;                                        name  
+;;                                        (reverse acc)
+;;                                        (make-ComputedJump target))
+;;                                       basic-blocks)
+;;                                 (cdr stmts))]))]
+
+;;                      [(TestAndJumpStatement? first-stmt)
+;;                       ...]
+
+;;                      [else
+;;                       (loop name
+;;                             (cons first-stmt acc)
+;;                             basic-blocks
+;;                             (cdr stmts))]))]))))
+

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)
+;; primitive-names: (listof symbol)
-;; (define js-vm-primitive-names
+(define js-vm-primitive-names
-;;   (map string->symbol
+  (map string->symbol
-;;        (sort&unique
+       (sort&unique
-;;         (map (lambda (a-str)
+        (map (lambda (a-str)
-;;                (substring a-str
+               (substring a-str
-;;                           (string-length "PRIMITIVES['")
+                          (string-length "PRIMITIVES['")
-;;                           (- (string-length a-str) (string-length "']"))))
+                          (- (string-length a-str) (string-length "']"))))
-;;              (let ([contents (file->string js-vm-primitives.js)])
+             (let ([contents (file->string js-vm-primitives.js)])
-;;                (regexp-match* #px"PRIMITIVES\\[('|\")[^\\]]*('|\")\\]" contents))))))
+               (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

@@ -30,22 +30,18 @@
 ;; the other modules below have some circular dependencies that are resolved
 ;; by link.
 (define files '(
-                top.js
-                
                 ;; jquery is special: we need to make sure it's resilient against
                 ;; multiple invokation and inclusion.
                 jquery-protect-header.js
                 jquery.js
                 jquery-protect-footer.js
                 
+                jshashtable-2.1_src.js
                 js-numbers.js
-                base64.js
                 
                 baselib.js
-                baselib-dict.js
-                baselib-frames.js
 
-                baselib-loadscript.js
+                baselib-frames.js
                 
                 baselib-unionfind.js
                 baselib-equality.js
@@ -57,28 +53,18 @@
                 baselib-vectors.js
                 baselib-chars.js
                 baselib-symbols.js
-                baselib-paramz.js
                 baselib-strings.js
                 baselib-bytes.js                    
-
-                hashes-header.js
-                jshashtable-2.1_src.js
-                llrbtree.js
                 baselib-hashes.js
-                hashes-footer.js
-
-                
                 baselib-regexps.js
                 baselib-paths.js
                 baselib-boxes.js
                 baselib-placeholders.js
                 baselib-keywords.js
                 baselib-structs.js
-                baselib-srclocs.js
                 baselib-ports.js
                 baselib-functions.js
                 baselib-modules.js
-                baselib-contmarks.js
                 
                 baselib-arity.js
                 baselib-inspectors.js
@@ -89,7 +75,6 @@
                 ;; since it uses the type predicates immediately on init time.
                 baselib-check.js
                 
-                baselib-primitives.js
                 runtime.js))
 
 

js-assembler/optimize-basic-blocks.rkt

@@ -0,0 +1,53 @@
+#lang typed/racket/base
+
+(require "assemble-structs.rkt"
+         "../compiler/il-structs.rkt"
+         racket/list)
+
+(require/typed "../logger.rkt" [log-debug (String -> Void)])
+
+
+(provide optimize-basic-blocks)
+
+
+(define-type Blockht (HashTable Symbol BasicBlock))
+
+
+(: optimize-basic-blocks ((Listof BasicBlock) -> (Listof BasicBlock)))
+(define (optimize-basic-blocks blocks)
+  (let: ([blockht : Blockht (make-hasheq)])
+    (for-each (lambda: ([b : BasicBlock])
+                       (hash-set! blockht (BasicBlock-name b) b))
+              blocks)
+
+    (map (lambda: ([b : BasicBlock])
+           (optimize-block b blockht))
+         blocks)))
+
+
+
+
+(: optimize-block (BasicBlock Blockht -> BasicBlock))
+;; Simple optimization: optimize away single-statement goto blocks with their
+;; immediate contents.
+(define (optimize-block b blocks)
+  (let ([stmts (BasicBlock-stmts b)])
+    (cond
+     [(= (length stmts) 1)
+      (let ([first-stmt (first stmts)])
+        (cond
+         [(GotoStatement? first-stmt)
+          (let ([target (GotoStatement-target first-stmt)])
+            (cond
+             [(Label? target)
+              (log-debug (format "inlining basic block ~a" (BasicBlock-name b)))
+              (optimize-block (make-BasicBlock (BasicBlock-name b)
+                                                (BasicBlock-stmts
+                                                 (hash-ref blocks (Label-name target))))
+                               blocks)]
+             [else
+              b]))]
+         [else
+          b]))]
+     [else
+      b])))

js-assembler/package.rkt

@@ -0,0 +1,406 @@
+#lang racket/base
+
+(require "assemble.rkt"
+         "quote-cdata.rkt"
+         "../logger.rkt"
+         "../make/make.rkt"
+         "../make/make-structs.rkt"
+         "../parameters.rkt"
+         "../compiler/expression-structs.rkt"
+         "../parser/path-rewriter.rkt"
+         "../parser/parse-bytecode.rkt"
+         racket/match
+         racket/list
+         racket/promise
+         (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))))]
+          [module-requires (query:lookup-module-requires (ModuleSource-path src))]
+          [bytecode (parse-bytecode (ModuleSource-path src))])
+      (log-debug "~a requires ~a"
+                 (ModuleSource-path src)
+                 module-requires)
+      (let ([module-body-text
+            (format "
+             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);
+             ~a
+             modrec.privateExports = exports;
+             return MACHINE.control.pop().label(MACHINE);"
+                    (symbol->string name)
+                    text
+                    (get-provided-name-code bytecode))])
+
+      (make-UninterpretedSource
+       (format "
+MACHINE.modules[~s] =
+    new plt.runtime.ModuleRecord(~s,
+        function(MACHINE) {
+            ~a
+        });
+"
+               (symbol->string name)
+               (symbol->string name)
+               (assemble-modinvokes+body module-requires module-body-text))
+
+       (map make-ModuleSource module-requires))))]
+
+
+   [(SexpSource? src)
+    (error 'get-javascript-implementation)]
+   [(UninterpretedSource? src)
+    (error 'get-javascript-implementation)]))
+
+
+(define (assemble-modinvokes+body paths after)
+  (cond
+   [(empty? paths)
+    after]
+   [(empty? (rest paths))
+    (assemble-modinvoke (first paths) after)]
+   [else
+    (assemble-modinvoke (first paths)
+                        (assemble-modinvokes+body (rest paths) after))]))
+
+
+(define (assemble-modinvoke path after)
+  (let ([name (rewrite-path (path->string path))]
+        [afterName (gensym 'afterName)])
+    (format "var ~a = function() { ~a };
+             if (! MACHINE.modules[~s].isInvoked) {
+                 MACHINE.modules[~s].internalInvoke(MACHINE,
+                                            ~a,
+                                            MACHINE.params.currentErrorHandler);
+             } else {
+                 ~a();
+             }"
+            afterName
+            after
+            (symbol->string name)
+            (symbol->string name)
+            afterName
+            afterName)))
+
+
+
+
+;; 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)
+    (log-debug "Checking if the source has a JavaScript implementation")
+    (cond
+     [(source-is-javascript-module? src)
+      (log-debug "Replacing implementation with JavaScript one.")
+      (get-javascript-implementation src)]
+     [else
+      src]))
+
+  
+  (define (on-visit-src src ast stmts)
+    (cond
+     [(UninterpretedSource? src)
+      (fprintf op "~a" (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 "plt.runtime.setReadyTrue();")
+    (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() {")
+    (fprintf op "plt.runtime.setReadyFalse();")
+    (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)
+  (log-debug "writing the runtime")
+  (display (quote-cdata (get-runtime)) op)
+  (log-debug "writing the source code")
+  (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)
+  (cond [(current-compress-javascript?)
+         (log-debug "compressing javascript...")
+         (closure-compile x)]
+        [else
+         (log-debug "not compressing javascript...")
+         x]))
+
+
+
+(define *the-runtime*
+  (delay (let ([buffer (open-output-string)])
+           (write-runtime buffer)
+           (compress
+            (get-output-string buffer)))))
+
+  
+;; get-runtime: -> string
+(define (get-runtime)
+  (force *the-runtime*))
+
+
+
+
+
+;; *header* : string
+(define *header*
+  #<<EOF
+<!DOCTYPE html>
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
+  <head>
+    <meta name="viewport" content="initial-scale=1.0, width=device-width, height=device-height, minimum-scale=1.0, maximum-scale=1.0, user-scalable=no" />
+    <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.baselib.format.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-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.baselib.lists.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,9 @@
     //////////////////////////////////////////////////////////////////////
 
     exports.ArityAtLeast = ArityAtLeast;
-    exports.makeArityAtLeast = function() { 
+    exports.makeArityAtLeast = ArityAtLeast.constructor;
-        var args = [].slice.call(arguments);
-        return ArityAtLeast.constructor(args);
-    };
     exports.isArityAtLeast = isArityAtLeast;
     exports.isArityMatching = isArityMatching;
     exports.arityAtLeastValue = arityAtLeastValue;
 
-}(this.plt.baselib));
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-boxes.js

@@ -1,10 +1,6 @@
-/*jslint browser: true, unparam: true, vars: true, white: true, plusplus: true, maxerr: 50, indent: 4 */
-
-
 // Exceptions
 
-(function(baselib, $) {
+(function(baselib) {
-    'use strict';
     var exports = {};
     baselib.boxes = exports;
 
@@ -29,48 +25,32 @@
 
     Box.prototype.toString = function(cache) {
         cache.put(this, true);
-        return "#&" + baselib.format.toWrittenString(this.val, cache);
+        return "#&" + plt.baselib.format.toWrittenString(this.val, cache);
     };
 
     Box.prototype.toWrittenString = function(cache) {
         cache.put(this, true);
-        return "#&" + baselib.format.toWrittenString(this.val, cache);
+        return "#&" + plt.baselib.format.toWrittenString(this.val, cache);
     };
 
     Box.prototype.toDisplayedString = function(cache) {
         cache.put(this, true);
-        return "#&" + baselib.format.toDisplayedString(this.val, cache);
+        return "#&" + plt.baselib.format.toDisplayedString(this.val, cache);
     };
 
-    Box.prototype.toDomNode = function(params) {
+    Box.prototype.toDomNode = function(cache) {
-        var node = $('<span/>');
+        cache.put(this, true);
-        if (params.getMode() === 'constructor') {
+        var parent = document.createElement("span");
-            node.append($('<span/>').text('(').addClass('lParen'));
+        parent.appendChild(document.createTextNode('#&'));
-            node.append($('<span/>').text('box'));
+        parent.appendChild(plt.baselib.format.toDomNode(this.val, cache));
-            node.append(" ");
+        return parent;
-            node.append(params.recur(this.val));
-            node.append($('<span/>').text(')').addClass('rParen'));
-        } else {
-            node.append($('<span/>').text('#&'));
-            node.append(params.recur(this.val));
-        }
-        return node.get(0);
     };
 
     Box.prototype.equals = function(other, aUnionFind) {
         return ((other instanceof Box) &&
-	        baselib.equality.equals(this.val, other.val, aUnionFind));
+	        plt.baselib.equality.equals(this.val, other.val, aUnionFind));
     };
     
-    Box.prototype.hashCode = function(depth) {
-        var k = baselib.hashes.getEqualHashCode("Box");
-        k = baselib.hashes.hashMix(k);
-        k += baselib.hashes.getEqualHashCode(this.val, depth);
-        k = baselib.hashes.hashMix(k);
-        return k;
-    };
-
-    
     var makeBox = function(x) { 
         return new Box(x, true); 
     };
@@ -103,4 +83,4 @@
     exports.makeImmutableBox = makeImmutableBox;
 
 
-}(this.plt.baselib, jQuery));
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-bytes.js

@@ -1,9 +1,5 @@
-/*jslint unparam: true, vars: true, white: true, plusplus: true, maxerr: 50, indent: 4 */
+// Arity structure
-
-
-
 (function(baselib) {
-    'use strict';
     var exports = {};
     baselib.bytes = exports;
 
@@ -12,7 +8,7 @@
     var Bytes = function(bts, mutable) {
         // bytes: arrayof [0-255]
         this.bytes = bts;
-        this.mutable = (mutable === void(0)) ? false : mutable;
+        this.mutable = (mutable === undefined) ? false : mutable;
     };
 
     Bytes.prototype.get = function(i) {
@@ -34,9 +30,10 @@
     };
 
     Bytes.prototype.subbytes = function(start, end) {
-	if (end === null || end === void(0)) {
+	if (end == null || end == undefined) {
 	    end = this.bytes.length;
 	}
+	
 	return new Bytes( this.bytes.slice(start, end), true );
     };
 
@@ -45,43 +42,40 @@
         if (! (other instanceof Bytes)) {
 	    return false;
         }
-        if (this.bytes.length !== other.bytes.length) {
+        if (this.bytes.length != other.bytes.length) {
 	    return false;
         }
         var A = this.bytes;
         var B = other.bytes;
         var n = this.bytes.length;
-        var i;
+        for (var i = 0; i < n; i++) {
-        for (i = 0; i < n; i++) {
+	    if (A[i] !== B[i])
-	    if (A[i] !== B[i]) {
 	        return false;
-            }
         }
         return true;
     };
 
-    Bytes.prototype.hashCode = function(depth) {
-        var i;
-        var k = baselib.hashes.getEqualHashCode('Bytes');
-        for (i = 0; i < this.bytes.length; i++) {
-            k += this.bytes[i];
-            k = baselib.hashes.hashMix(k);
-        }
-        return k;
-    };
-
 
     Bytes.prototype.toString = function(cache) {
-	var ret = [], i;
+	var ret = '';
-	for (i = 0; i < this.bytes.length; i++) {
+	for (var i = 0; i < this.bytes.length; i++) {
-	    ret.push(String.fromCharCode(this.bytes[i]));
+	    ret += String.fromCharCode(this.bytes[i]);
 	}
 
-	return ret.join('');
+	return ret;
     };
 
     Bytes.prototype.toDisplayedString = Bytes.prototype.toString;
 
+    Bytes.prototype.toWrittenString = function() {
+	var ret = ['#"'];
+	for (var i = 0; i < this.bytes.length; i++) {
+	    ret.push( escapeByte(this.bytes[i]) );
+	}
+	ret.push('"');
+	return ret.join('');
+    };
+
     var escapeByte = function(aByte) {
 	var ret = [];
 	var returnVal;
@@ -106,31 +100,8 @@
 	return returnVal;
     };
 
-    Bytes.prototype.toWrittenString = function() {
-	var ret = ['#"'], i;
-	for (i = 0; i < this.bytes.length; i++) {
-	    ret.push(escapeByte(this.bytes[i]));
-	}
-	ret.push('"');
-	return ret.join('');
-    };
-
-    var makeBytes = function(chars) {
-        return new Bytes(chars);
-    };
-
-    var makeBytesFromBase64 = function(byteString) {
-        return new Bytes(Base64.decode(byteString));
-    };
-
-
-    var isBytes = baselib.makeClassPredicate(Bytes);
 
 
     exports.Bytes = Bytes;
-    exports.makeBytes = makeBytes;
-    exports.makeBytesFromBase64 = makeBytesFromBase64;
-    exports.isBytes = isBytes;
 
-
+})(this['plt'].baselib);
-}(this.plt.baselib));

js-assembler/runtime-src/baselib-chars.js

@@ -1,12 +1,12 @@
 // Single characters
-(function(baselib, $) {
+(function(baselib) {
     var exports = {};
     baselib.chars = exports;
 
 
     // Chars
     // Char: string -> Char
-    var Char = function(val){
+    Char = function(val){
         this.val = val;
     };
     // The characters less than 256 must be eq?, according to the
@@ -59,13 +59,6 @@
         return this.val;
     };
 
-    Char.prototype.toDomNode = function(params) {
-        return $('<span/>')
-            .text(this.toString())
-            .addClass('wescheme-character')
-            .get(0);
-    };
-
     Char.prototype.getValue = function() {
         return this.val;
     };
@@ -74,17 +67,9 @@
         return other instanceof Char && this.val == other.val;
     };
 
-    Char.prototype.hashCode = function(depth) {
+
-        var k = baselib.hashes.getEqualHashCode('Char');
-        k += this.val.charCodeAt(0);
-        k = baselib.hashes.hashMix(k);
-        return k;
-    };
 
 
     exports.Char = Char;
-    exports.makeChar = Char.makeInstance;
-    exports.isChar = plt.baselib.makeClassPredicate(Char);
 
-
+})(this['plt'].baselib);
-})(this['plt'].baselib, jQuery);

js-assembler/runtime-src/baselib-check.js

@@ -0,0 +1,248 @@
+// Helper functions for argument checking.
+
+(function(baselib) {
+    var exports = {};
+    baselib.check = exports;
+
+    var EMPTY = plt.baselib.lists.EMPTY;
+    var isPair = plt.baselib.lists.isPair;
+    var makeLowLevelEqHash = plt.baselib.hashes.makeLowLevelEqHash;
+
+
+    //////////////////////////////////////////////////////////////////////
+
+    var makeCheckArgumentType = function(predicate, predicateName) {
+	return function(MACHINE, callerName, position) {
+	    testArgument(
+		MACHINE,
+		predicateName,
+		predicate,
+		MACHINE.env[MACHINE.env.length - 1 - position],
+		position,
+		callerName);
+	    return MACHINE.env[MACHINE.env.length - 1 - position];
+	}
+    };
+
+    var makeCheckParameterizedArgumentType = function(parameterizedPredicate, 
+                                                      parameterizedPredicateName) {
+	return function(MACHINE, callerName, position) {
+            var args = [];
+            for (var i = 3; i < arguments.length; i++) {
+                args.push(arguments[i]);
+            }
+	    testArgument(
+		MACHINE,
+		parameterizedPredicateName.apply(null, args),
+		function(x) {
+                    return parameterizedPredicate.apply(null, [x].concat(args));
+                },
+		MACHINE.env[MACHINE.env.length - 1 - position],
+		position,
+		callerName);
+	    return MACHINE.env[MACHINE.env.length - 1 - position];
+	}
+    };
+
+
+
+
+
+    var makeCheckListofArgumentType = function(predicate, predicateName) {
+        var listPredicate = function(x) {
+            var seen = makeLowLevelEqHash();
+            while (true) {
+                if (x === EMPTY){
+                    return true;
+                }
+
+                if (!isPair(x)) {
+                    return false;
+                }
+
+                if(seen.containsKey(x)) {
+                    // raise an error? we've got a cycle!
+                    return false
+                }
+
+                if (! predicate(x.first)) {
+                    return false;
+                }
+                
+                seen.put(x, true);
+                x = x.rest;
+            }
+        };
+	return function(MACHINE, callerName, position) {
+	    testArgument(
+		MACHINE,
+		'list of ' + predicateName,
+		listPredicate,
+		MACHINE.env[MACHINE.env.length - 1 - position],
+		position,
+		callerName);
+	    return MACHINE.env[MACHINE.env.length - 1 - position];
+	}
+    };
+
+
+
+
+
+
+    // testArgument: (X -> boolean) X number string string -> boolean
+    // Produces true if val is true, and otherwise raises an error.
+    var testArgument = function(MACHINE,
+				expectedTypeName,
+				predicate, 			    
+				val, 
+				index, 
+				callerName) {
+	if (predicate(val)) {
+	    return true;
+	} else {
+	    plt.baselib.exceptions.raiseArgumentTypeError(MACHINE, 
+                                                          callerName,
+                                                          expectedTypeName,
+				                          index,
+				                          val);
+	}
+    };
+
+    var testArity = function(callerName, observed, minimum, maximum) {
+	if (observed < minimum || observed > maximum) {
+	    plt.baselib.exceptions.raise(
+                MACHINE, new Error(callerName + ": expected at least " + minimum
+				   + " arguments "
+				   + " but received " + observed));
+
+	}
+    };
+
+
+
+
+    var checkOutputPort = makeCheckArgumentType(
+        plt.baselib.ports.isOutputPort,
+        'output port');
+
+    var checkSymbol = makeCheckArgumentType(
+	plt.baselib.symbols.isSymbol,
+	'symbol');
+
+    var checkString = makeCheckArgumentType(
+        plt.baselib.strings.isString,
+        'string');
+    
+    var checkProcedure = makeCheckArgumentType(
+        plt.baselib.functions.isProcedure,
+        'procedure');
+
+    var checkNumber = makeCheckArgumentType(
+        plt.baselib.numbers.isNumber,
+        'number');
+
+    var checkReal = makeCheckArgumentType(
+        plt.baselib.numbers.isReal,
+        'real');
+
+    var checkNatural = makeCheckArgumentType(
+        plt.baselib.numbers.isNatural,
+        'natural');
+
+    var checkByte = makeCheckArgumentType(
+        function(x) { return (typeof(x) === 'number' && 0 <= x && x < 256) },
+        'byte');
+
+    var checkNaturalInRange = makeCheckParameterizedArgumentType(
+        function(x, a, b) {
+            if (! plt.baselib.numbers.isNatural(x)) { return false; }
+            return (plt.baselib.numbers.lessThanOrEqual(a, x) &&
+                    plt.baselib.numbers.lessThan(x, b));
+        },
+        function(a, b) {
+            return plt.baselib.format.format('natural between ~a and ~a', [a, b]);
+        });
+
+    var checkInteger = makeCheckArgumentType(
+        plt.baselib.numbers.isInteger,
+        'integer');
+
+    var checkRational = makeCheckArgumentType(
+        plt.baselib.numbers.isRational,
+        'rational');
+
+    var checkNonNegativeReal = makeCheckArgumentType(
+        plt.baselib.numbers.isNonNegativeReal,
+        'non-negative real');
+
+    var checkPair = makeCheckArgumentType(
+        plt.baselib.lists.isPair,
+        'pair');
+
+    var checkList = makeCheckArgumentType(
+        plt.baselib.lists.isList,
+        'list');
+
+    var checkVector = makeCheckArgumentType(
+        plt.baselib.vectors.isVector,
+        'vector');
+
+    var checkBoolean = makeCheckArgumentType(
+        function(x) { return x === true || x === false; },
+        'boolean');
+
+    var checkBox = makeCheckArgumentType(
+        plt.baselib.boxes.isBox,
+        'box');
+
+    var checkMutableBox = makeCheckArgumentType(
+        plt.baselib.boxes.isMutableBox,
+        'mutable box');
+
+    var checkInspector = makeCheckArgumentType(
+        plt.baselib.inspectors.isInspector,
+        'inspector');
+
+
+    var checkByte = makeCheckArgumentType(
+        plt.baselib.numbers.isByte,
+        'byte');
+
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+
+    exports.testArgument = testArgument;
+    exports.testArity = testArity;
+    exports.makeCheckArgumentType = makeCheckArgumentType;
+    exports.makeCheckParameterizedArgumentType = makeCheckParameterizedArgumentType;
+    exports.makeCheckListofArgumentType = makeCheckListofArgumentType;
+
+    exports.checkOutputPort = checkOutputPort;
+    exports.checkString = checkString;
+    exports.checkSymbol = checkSymbol;
+    exports.checkProcedure = checkProcedure;
+    exports.checkNumber = checkNumber;
+    exports.checkReal = checkReal;
+    exports.checkNonNegativeReal = checkNonNegativeReal;
+    exports.checkNatural = checkNatural;
+    exports.checkNaturalInRange = checkNaturalInRange;
+    exports.checkByte = checkByte;
+    exports.checkInteger = checkInteger;
+    exports.checkRational = checkRational;
+    exports.checkPair = checkPair;
+    exports.checkList = checkList;
+    exports.checkVector = checkVector;
+    exports.checkBox = checkBox;
+    exports.checkMutableBox = checkMutableBox;
+    exports.checkInspector = checkInspector;
+    exports.checkByte = checkByte;
+    exports.checkBoolean = checkBoolean;
+
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-constants.js

@@ -0,0 +1,25 @@
+// Other miscellaneous constants
+(function(baselib) {
+    var exports = {};
+    baselib.constants = exports;
+
+
+    var VoidValue = function() {};
+    VoidValue.prototype.toString = function() {
+	return "#<void>";
+    };
+
+    var VOID_VALUE = new VoidValue();
+
+
+    var EofValue = function() {};
+    EofValue.prototype.toString = function() {
+	return "#<eof>";
+    }
+
+    var EOF_VALUE = new EofValue();
+
+
+    exports.VOID_VALUE = VOID_VALUE;
+    exports.EOF_VALUE = EOF_VALUE;
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-contmarks.js

@@ -0,0 +1,35 @@
+// Continuation marks
+(function(baselib) {
+    var exports = {};
+    baselib.contmarks = exports;
+
+
+    var ContinuationMarkSet = function(dict) {
+        this.dict = dict;
+    }
+
+    ContinuationMarkSet.prototype.toDomNode = function(cache) {
+        var dom = document.createElement("span");
+        dom.appendChild(document.createTextNode('#<continuation-mark-set>'));
+        return dom;
+    };
+
+    ContinuationMarkSet.prototype.toWrittenString = function(cache) {
+        return '#<continuation-mark-set>';
+    };
+
+    ContinuationMarkSet.prototype.toDisplayedString = function(cache) {
+        return '#<continuation-mark-set>';
+    };
+
+    ContinuationMarkSet.prototype.ref = function(key) {
+        if ( this.dict.containsKey(key) ) {
+	    return this.dict.get(key);
+        }
+        return [];
+    };
+
+    exports.ContinuationMarkSet = ContinuationMarkSet;
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-equality.js

@@ -0,0 +1,47 @@
+// Equality function
+(function(baselib) {
+    var exports = {};
+    baselib.equality = exports;
+
+
+    // equals: X Y -> boolean
+    // Returns true if the objects are equivalent; otherwise, returns false.
+    var equals = function(x, y, aUnionFind) {
+        if (x === y) { return true; }
+
+        if (plt.baselib.numbers.isNumber(x) && plt.baselib.numbers.isNumber(y)) {
+	    return plt.baselib.numbers.eqv(x, y);
+        }
+
+        if (baselib.strings.isString(x) && baselib.strings.isString(y)) {
+	    return x.toString() === y.toString();
+        }
+
+        if (x == undefined || x == null) {
+	    return (y == undefined || y == null);
+        }
+
+        if ( typeof(x) == 'object' &&
+	     typeof(y) == 'object' &&
+	     x.equals &&
+	     y.equals) {
+
+	    if (typeof (aUnionFind) === 'undefined') {
+	        aUnionFind = new plt.baselib.UnionFind();
+	    }
+
+	    if (aUnionFind.find(x) === aUnionFind.find(y)) {
+	        return true;
+	    }
+	    else {
+	        aUnionFind.merge(x, y); 
+	        return x.equals(y, aUnionFind);
+	    }
+        }
+        return false;
+    };
+
+
+    exports.equals = equals;
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-exceptions.js

@@ -0,0 +1,238 @@
+// 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;
+    };
+
+
+    // (define-struct exn (message continuation-mark-set))
+    var Exn = plt.baselib.structs.makeStructureType(
+        'exn', false, 2, 0, false, false);
+
+
+    // (define-struct (exn:break exn) (continuation))
+    var ExnBreak = plt.baselib.structs.makeStructureType(
+        'exn:break', Exn, 1, 0, false, false);
+
+
+    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);
+
+
+
+
+
+    var exceptionHandlerKey = new plt.baselib.symbols.Symbol("exnh");
+
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+    // Raise error to the toplevel.
+
+    // If the error is of an exception type, make sure e.message holds the string
+    // value to allow integration with systems that don't recognize Racket error 
+    // structures.
+    var raise = function(MACHINE, e) { 
+        if (Exn.predicate(e)) {
+            e.message = Exn.accessor(e, 0);
+        }
+
+	if (typeof(window['console']) !== 'undefined' &&
+	    typeof(console['log']) === 'function') {
+	    console.log(MACHINE);
+	    if (e['stack']) { console.log(e['stack']); }
+	    else { console.log(e); }
+	} 
+	throw e; 
+    };
+
+
+
+
+    var raiseUnboundToplevelError = function(MACHINE, name) {
+        raise(MACHINE, 
+	      new Error(
+		  plt.baselib.format.format(
+		      "Not bound: ~a",
+		      [name]))); 
+    };
+
+
+    var raiseArgumentTypeError = function(MACHINE, 
+                                          callerName,
+                                          expectedTypeName,
+                                          argumentOffset,
+                                          actualValue) {
+	raise(MACHINE,
+              new Error(
+		  plt.baselib.format.format(
+		      "~a: expected ~a as argument ~e but received ~e",
+		      [callerName,
+		       expectedTypeName,
+		       (argumentOffset + 1),
+		       actualValue])));
+    };
+
+    var raiseContextExpectedValuesError = function(MACHINE, expected) {
+	raise(MACHINE, 
+	      new Error(plt.baselib.format.format(
+		  "expected ~e values, received ~e values"
+		  [expected,
+		   MACHINE.argcount])));
+    };
+
+    var raiseArityMismatchError = function(MACHINE, proc, expected, received) {
+	raise(MACHINE, 
+	      new Error(plt.baselib.format.format(
+		  "~a: expected ~e value(s), received ~e value(s)",
+		  [proc.displayName,
+		   expected ,
+		   received])))
+    };
+
+    var raiseOperatorApplicationError = function(MACHINE, operator) {
+	raise(MACHINE, 
+	      new Error(
+		  plt.baselib.format.format(
+		      "not a procedure: ~e",
+		      [operator])));
+    };
+
+    var raiseOperatorIsNotClosure = function(MACHINE, operator) {
+        raise(MACHINE,
+              new Error(
+		  plt.baselib.format.format(
+		      "not a closure: ~e",
+		      [operator])));
+    };
+
+    var raiseOperatorIsNotPrimitiveProcedure = function(MACHINE, operator) {
+        raise(MACHINE,
+              new Error(
+		  plt.baselib.format.format(
+		      "not a primitive procedure: ~e",
+		      [operator])));
+    };
+
+
+    var raiseUnimplementedPrimitiveError = function(MACHINE, name) {
+	raise(MACHINE, 
+	      new Error("unimplemented kernel procedure: " + name))
+    };
+
+
+
+
+
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+    // 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.makeIncompleteExn = function(constructor, msg, args) { return new IncompleteExn(constructor, msg, args); };
+    exceptions.isIncompleteExn = function(x) { return x instanceof IncompleteExn; };
+
+
+    exceptions.Exn = Exn;
+    exceptions.makeExn = 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.makeExnBreak = ExnBreak.constructor;
+    exceptions.isExnBreak = ExnBreak.predicate;
+    exceptions.exnBreakContinuation = 
+        function(exn) { return ExnBreak.accessor(exn, 0); };
+
+    exceptions.ExnFail = ExnFail;
+    exceptions.makeExnFail = ExnFail.constructor;
+    exceptions.isExnFail = ExnFail.predicate;
+
+    exceptions.ExnFailContract = ExnFailContract;
+    exceptions.makeExnFailContract = ExnFailContract.constructor;
+    exceptions.isExnFailContract = ExnFailContract.predicate;
+
+    exceptions.ExnFailContractArity = ExnFailContractArity;
+    exceptions.makeExnFailContractArity = ExnFailContractArity.constructor;
+    exceptions.isExnFailContractArity = ExnFailContractArity.predicate;
+
+    exceptions.ExnFailContractVariable = ExnFailContractVariable;
+    exceptions.makeExnFailContractVariable = ExnFailContractVariable.constructor;
+    exceptions.isExnFailContractVariable = ExnFailContractVariable.predicate;
+    exceptions.exnFailContractVariableId = 
+        function(exn) { return ExnFailContractVariable.accessor(exn, 0); };
+
+
+    exceptions.ExnFailContractDivisionByZero = ExnFailContractDivisionByZero;
+    exceptions.makeExnFailContractDivisionByZero = 
+        ExnFailContractDivisionByZero.constructor;
+    exceptions.isExnFailContractDivisionByZero = ExnFailContractDivisionByZero.predicate;
+
+
+    exceptions.exceptionHandlerKey = exceptionHandlerKey;
+
+
+
+
+    exceptions.raise = raise;
+    exceptions.raiseUnboundToplevelError = raiseUnboundToplevelError;
+    exceptions.raiseArgumentTypeError = raiseArgumentTypeError;
+    exceptions.raiseContextExpectedValuesError = raiseContextExpectedValuesError;
+    exceptions.raiseArityMismatchError = raiseArityMismatchError;
+    exceptions.raiseOperatorApplicationError = raiseOperatorApplicationError;
+    exceptions.raiseOperatorIsNotClosure = raiseOperatorIsNotClosure;
+    exceptions.raiseOperatorIsNotPrimitiveProcedure = raiseOperatorIsNotPrimitiveProcedure;
+    exceptions.raiseUnimplementedPrimitiveError = raiseUnimplementedPrimitiveError;
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-format.js

@@ -0,0 +1,423 @@
+// Formatting library.
+// Produces string and DOM representations of values.
+//
+(function(baselib) {
+    var exports = {};
+    baselib.format = exports;
+
+
+    
+    // format: string [X ...] string -> string
+    // String formatting.  If an exception occurs, throws
+    // a plain Error whose message describes the formatting error.
+    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;
+    };
+
+
+    // toWrittenString: Any Hashtable -> String
+    var toWrittenString = function(x, cache) {
+        if (! cache) { 
+     	    cache = plt.baselib.hashes.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.hashes.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.hashes.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 (plt.baselib.numbers.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 (plt.baselib.numbers.isExact(n)) {
+	    if (plt.baselib.numbers.isInteger(n)) {
+	        node = document.createElement("span");
+	        node.appendChild(document.createTextNode(n.toString()));
+	        return node;
+	    } else if (plt.baselib.numbers.isRational(n)) {
+	        return rationalToDomNode(n);
+	    } else if (plt.baselib.numbers.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 = plt.baselib.numbers.toRepeatingDecimal(plt.baselib.numbers.numerator(n),
+                                               plt.baselib.numbers.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(plt.baselib.numbers.numerator(n))));
+        var denominatorNode = document.createElement("sub");
+        denominatorNode.appendChild(document.createTextNode(String(plt.baselib.numbers.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('');
+    };
+
+
+
+
+
+
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+
+    exports.ToDomNodeParameters = ToDomNodeParameters;
+
+    exports.format = format;
+    exports.toWrittenString = toWrittenString;
+    exports.toDisplayedString = toDisplayedString;
+    exports.toDomNode = toDomNode;
+
+    exports.escapeString = escapeString;
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-frames.js

@@ -1,8 +1,5 @@
-/*jslint unparam: true, sub: true, vars: true, white: true, plusplus: true, maxerr: 50, indent: 4 */
-
 // Frame structures.
 (function(baselib) {
-    'use strict';
     var exports = {};
     baselib.frames = exports;
 
@@ -11,17 +8,14 @@
     // A generic frame just holds marks.
     var Frame = function() {
 	// The set of continuation marks.
-	// this.marks = [];
+	this.marks = [];
+
 	// When we're in the middle of computing with-cont-mark, we
 	// stash the key in here temporarily.
-	// this.pendingContinuationMarkKey = undefined;
+	this.pendingContinuationMarkKey = undefined;
-	// this.pendingApplyValuesProc = undefined;
+	this.pendingApplyValuesProc = undefined;
-	// this.pendingBegin0Count = undefined;
+	this.pendingBegin0Count = undefined;
-	// this.pendingBegin0Values = undefined;
+	this.pendingBegin0Values = undefined;
-    };
-    Frame.prototype.getMarks = function() {
-        if (this.marks === void(0)) { this.marks = []; }
-        return this.marks;
     };
 
 
@@ -34,33 +28,37 @@
     // as well as the function being called.
     var CallFrame = function(label, proc) {
 	this.label = label;
-	this.p = proc;
+	this.proc = proc;
+
+	// The set of continuation marks.
+	this.marks = [];
+
+	// When we're in the middle of computing with-cont-mark, we
+	// stash the key in here temporarily.
+	this.pendingContinuationMarkKey = undefined;
     };
     CallFrame.prototype = baselib.heir(Frame.prototype);
 
 
 
-    // A prompt frame includes a return address, as well as a prompt
+    // A prompt frame includes a return address, as well as a prompt tag
-    // tag for supporting delimited continuations.  To support abort,
+    // for supporting delimited continuations.
-    // we also keep the size of the environment, and the handler
+    var PromptFrame = function(label, tag) {
-    // to call if an abort happens.
-    //
-    // If handler is null, handler will be a default closure that
-    // accepts any number of values and returns.
-    var PromptFrame = function(label, tag, envLength, handler) {
 	this.label = label;
 	this.tag = tag; // ContinuationPromptTag
-        this.envLength = envLength;
+
-        this.handler = handler;
+	// The set of continuation marks.
+	this.marks = [];
+
+	// When we're in the middle of computing with-cont-mark, we
+	// stash the key in here temporarily.
+	this.pendingContinuationMarkKey = undefined;	
     };
     PromptFrame.prototype = baselib.heir(Frame.prototype);
 
 
 
 
-
-
-
     //////////////////////////////////////////////////////////////////////
     exports.Frame = Frame;
     exports.CallFrame = CallFrame;
@@ -68,4 +66,4 @@
 
 
 
-}(this.plt.baselib));
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-functions.js

@@ -0,0 +1,354 @@
+// Procedures
+
+// For historical reasons, this module is called 'functions' instead of 'procedures'.
+// This may change soon.
+
+(function(baselib) {
+    var exports = {};
+    baselib.functions = exports;
+    
+    // Procedure types: a procedure is either a Primitive or a Closure.
+
+    // A Primitive is a function that's expected to return.  It is not
+    // allowed to call into Closures.  Its caller is expected to pop off
+    // its argument stack space.
+    //
+
+
+
+
+    
+    // coerseToJavaScript: racket function -> JavaScript function
+    // Given a closure or primitive, produces an
+    // asynchronous JavaScript function.
+    // The function will run on the provided MACHINE.
+    //
+    // It assumes that it must begin its own trampoline.
+    var asJavaScriptFunction = function(v, MACHINE) {
+        MACHINE = MACHINE || plt.runtime.currentMachine;
+        if (isPrimitiveProcedure(v)) {
+            return coersePrimitiveToJavaScript(v, MACHINE);
+        } else if (isClosure(v)) {
+            return coerseClosureToJavaScript(v, MACHINE);
+        } else {
+            plt.baselib.exceptions.raise(MACHINE,
+                                         plt.baselib.exceptions.makeExnFail(
+                                             plt.baselib.format.format(
+                                                 "Not a procedure: ~e",
+                                                 v)));
+        }
+    };
+
+    var coersePrimitiveToJavaScript = function(v, MACHINE) {
+        return function(succ, fail) {
+            try {
+                succ = succ || function(){};
+                fail = fail || function(){};
+
+                var oldArgcount = MACHINE.argcount;
+                MACHINE.argcount = arguments.length - 2;
+                for (var i = 0; i < arguments.length - 2; i++) {
+                    MACHINE.env.push(arguments[arguments.length - 1 - i]);
+                }
+
+		if (! plt.baselib.arity.isArityMatching(v.arity, MACHINE.argcount)) {
+		    fail(new Error(plt.baselib.format.format(
+                        "arity mismatch: expected ~s arguments, but received ~s",
+                        [v.arity, MACHINE.argcount])));
+                    return;
+		}
+
+                var result = v.call(null, MACHINE);
+                MACHINE.argcount = oldArgcount;
+                for (var i = 0; i < arguments.length - 2; i++) { 
+                    MACHINE.env.pop();
+                }
+                succ(result);
+            } catch (e) {
+                fail(e);
+            }
+        }
+    };
+
+
+    var coerseClosureToJavaScript = function(v, MACHINE) {
+        var f = function(succ, fail) {
+            succ = succ || function(){};
+            fail = fail || function(){};
+
+	    if (! plt.baselib.arity.isArityMatching(v.arity, arguments.length - 2)) {
+                fail(new Error(
+                    plt.baselib.format.format(
+                        "arity mismatch: expected ~s argument(s) but received ~s",
+                        [v.arity, arguments.length - 2])));
+                return;
+	    }
+
+            var oldVal = MACHINE.val;
+            var oldArgcount = MACHINE.argcount;
+            var oldProc = MACHINE.proc;
+
+            var oldErrorHandler = MACHINE.params['currentErrorHandler'];
+            var afterGoodInvoke = function(MACHINE) { 
+		plt.runtime.PAUSE(
+		    function(restart) {
+			MACHINE.params['currentErrorHandler'] = oldErrorHandler;
+			var returnValue = MACHINE.val;
+			MACHINE.val = oldVal;
+			MACHINE.argcount = oldArgcount;
+			MACHINE.proc = oldProc;
+			succ(returnValue);
+		    });
+            };
+            afterGoodInvoke.multipleValueReturn = function(MACHINE) {
+		plt.runtime.PAUSE(
+		    function(restart) {
+			MACHINE.params['currentErrorHandler'] = oldErrorHandler;
+			var returnValues = [MACHINE.val];
+			for (var i = 0; i < MACHINE.argcount - 1; i++) {
+			    returnValues.push(MACHINE.env.pop());
+			}
+			MACHINE.val = oldVal;
+			MACHINE.argcount = oldArgcount;
+			MACHINE.proc = oldProc;
+			succ.apply(null, returnValues);
+		    });
+            };
+
+            MACHINE.control.push(
+                new plt.baselib.frames.CallFrame(afterGoodInvoke, null));
+            MACHINE.argcount = arguments.length - 2;
+            for (var i = 0; i < arguments.length - 2; i++) {
+                MACHINE.env.push(arguments[arguments.length - 1 - i]);
+            }
+            MACHINE.proc = v;
+            MACHINE.params['currentErrorHandler'] = function(MACHINE, e) {
+                MACHINE.params['currentErrorHandler'] = oldErrorHandler;
+                MACHINE.val = oldVal;
+                MACHINE.argcount = oldArgcount;
+                MACHINE.proc = oldProc;
+                fail(e);
+            };
+            plt.runtime.trampoline(MACHINE, v.label);
+        };
+        return f;
+    };
+
+
+
+    // internallCallDuringPause: call a Racket procedure and get its results.
+    // The use assumes the machine is in a running-but-paused state.
+    var internalCallDuringPause = function(MACHINE, proc, success, fail) {
+	if (! plt.baselib.arity.isArityMatching(proc.arity, arguments.length - 4)) {
+	    return fail(plt.baselib.exceptions.makeExnFailContractArity("arity mismatch"));
+	}
+
+        if (isPrimitiveProcedure(proc)) {
+            var oldArgcount = MACHINE.argcount;
+            MACHINE.argcount = arguments.length - 4;
+            for (var i = 0; i < arguments.length - 4; i++) {
+                MACHINE.env.push(arguments[arguments.length - 1 - i]);
+            }
+            var result = proc.call(null, MACHINE);
+            for (var i = 0; i < arguments.length - 4; i++) {
+                MACHINE.env.pop();
+            }
+            success(result);
+        } else if (isClosure(proc)) {
+            var oldVal = MACHINE.val;
+            var oldArgcount = MACHINE.argcount;
+            var oldProc = MACHINE.proc;
+
+            var oldErrorHandler = MACHINE.params['currentErrorHandler'];
+            var afterGoodInvoke = function(MACHINE) { 
+		plt.runtime.PAUSE(function(restart) {
+                    MACHINE.params['currentErrorHandler'] = oldErrorHandler;
+                    var returnValue = MACHINE.val;
+                    MACHINE.val = oldVal;
+                    MACHINE.argcount = oldArgcount;
+                    MACHINE.proc = oldProc;
+                    success(returnValue);
+		});
+            };
+            afterGoodInvoke.multipleValueReturn = function(MACHINE) {
+		plt.runtime.PAUSE(function(restart) {
+		    MACHINE.params['currentErrorHandler'] = oldErrorHandler;
+                    var returnValues = [MACHINE.val];
+                    for (var i = 0; i < MACHINE.argcount - 1; i++) {
+			returnValues.push(MACHINE.env.pop());
+                    }
+                    MACHINE.val = oldVal;
+                    MACHINE.argcount = oldArgcount;
+                    MACHINE.proc = oldProc;
+                    success.apply(null, returnValues);
+		});
+            };
+
+            MACHINE.control.push(
+                new plt.baselib.frames.CallFrame(afterGoodInvoke, null));
+            MACHINE.argcount = arguments.length - 4;
+            for (var i = 0; i < arguments.length - 4; i++) {
+                MACHINE.env.push(arguments[arguments.length - 1 - i]);
+            }
+            MACHINE.proc = proc;
+            MACHINE.params['currentErrorHandler'] = function(MACHINE, e) {
+                MACHINE.params['currentErrorHandler'] = oldErrorHandler;
+                MACHINE.val = oldVal;
+                MACHINE.argcount = oldArgcount;
+                MACHINE.proc = oldProc;
+                fail(e);
+            };
+            plt.runtime.trampoline(MACHINE, proc.label);
+        } else {
+            fail(plt.baselib.exceptions.makeExnFail(
+                plt.baselib.format.format(
+                    "Not a procedure: ~e",
+                    proc)));
+        }
+    };
+
+
+
+
+
+
+
+    // A Closure is a function that takes on more responsibilities: it is
+    // responsible for popping off stack space before it finishes, and it
+    // is also explicitly responsible for continuing the computation by 
+    // popping off the control stack and doing the jump.  Because of this,
+    // closures can do pretty much anything to the machine.
+
+    // A closure consists of its free variables as well as a label
+    // into its text segment.
+    var Closure = function(label, arity, closedVals, displayName) {
+	this.label = label;              // (MACHINE -> void)
+	this.arity = arity;              // number
+	this.closedVals = closedVals;    // arrayof number
+	this.displayName = displayName;  // string
+    };
+
+
+
+    // Finalize the return from a closure.  This is a helper function
+    // for those who implement Closures by hand.
+    //
+    // If used in the body of a Closure, it must be in tail
+    // position.  This finishes the closure call, and does the following:
+    //
+    //     * Clears out the existing arguments off the stack frame
+    //     * Sets up the return value
+    //     * Jumps either to the single-value return point, or the multiple-value
+    //       return point.
+    //
+    // I'd personally love for this to be a macro and avoid the
+    // extra function call here.
+    var finalizeClosureCall = function(MACHINE) {
+        MACHINE.callsBeforeTrampoline--;
+        var frame, i, returnArgs = [].slice.call(arguments, 1);
+
+        // clear out stack space
+        // TODO: replace with a splice.
+        for(i = 0; i < MACHINE.argcount; i++) {
+            MACHINE.env.pop();
+        }
+
+        if (returnArgs.length === 1) {
+            MACHINE.val = returnArgs[0];
+	    frame = MACHINE.control.pop();
+	    return frame.label(MACHINE);
+        } else if (returnArgs.length === 0) {
+            MACHINE.argcount = 0;
+	    frame = MACHINE.control.pop();
+	    return frame.label.multipleValueReturn(MACHINE);
+        } else {
+            MACHINE.argcount = returnArgs.length;
+            MACHINE.val = returnArgs.shift();
+            // TODO: replace with a splice.
+            for(i = 0; i < MACHINE.argcount - 1; i++) {
+                MACHINE.env.push(returnArgs.pop());
+            }
+	    frame = MACHINE.control.pop();
+	    return frame.label.multipleValueReturn(MACHINE);
+        }
+    };
+
+
+
+
+
+
+    var makePrimitiveProcedure = function(name, arity, f) {
+        f.arity = arity;
+        f.displayName = name;
+        return f;
+    };
+
+    var makeClosure = function(name, arity, f, closureArgs) {
+        if (! closureArgs) { closureArgs = []; }
+        return new Closure(f,
+                           arity,
+                           closureArgs,
+                           name);
+    };
+
+
+
+
+    var isPrimitiveProcedure = function(x) {
+        return typeof(x) === 'function';
+    };
+
+    var isClosure = function(x) {
+        return x instanceof Closure;
+    };
+
+
+    var isProcedure = function(x) {
+        return (typeof(x) === 'function' ||
+                x instanceof Closure);
+    };
+
+
+
+    var renameProcedure = function(f, name) {
+        if (isPrimitiveProcedure(f)) {
+            return makePrimitiveProcedure(
+                name,
+                f.arity,
+                function() {
+                    return f.apply(null, arguments);
+                });
+        } else {
+            return new Closure(
+                f.label,
+                f.arity,
+                f.closedVals,
+                name);
+        }
+    };
+
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+    exports.Closure = Closure;
+    exports.internalCallDuringPause = internalCallDuringPause;
+    exports.finalizeClosureCall = finalizeClosureCall;
+
+    exports.makePrimitiveProcedure = makePrimitiveProcedure;
+    exports.makeClosure = makeClosure;
+
+    exports.isPrimitiveProcedure = isPrimitiveProcedure;
+    exports.isClosure = isClosure;
+
+    exports.isProcedure = isProcedure;
+
+
+    exports.renameProcedure = renameProcedure;
+
+
+    exports.asJavaScriptFunction = asJavaScriptFunction;
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-hashes.js

@@ -0,0 +1,197 @@
+
+(function(baselib) {
+    var exports = {};
+
+    baselib.hashes = exports;
+
+
+    
+    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; });
+    };
+
+
+
+
+
+
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+    // Eq Hashtables
+    var EqHashTable = function(inputHash) {
+        this.hash = makeLowLevelEqHash();
+        this.mutable = true;
+
+    };
+
+    EqHashTable.prototype.toWrittenString = function(cache) {
+        var keys = this.hash.keys();
+        var ret = [];
+        for (var i = 0; i < keys.length; i++) {
+	    var keyStr = toWrittenString(keys[i], cache);
+	    var valStr = toWrittenString(this.hash.get(keys[i]), cache);
+	    ret.push('(' + keyStr + ' . ' + valStr + ')');
+        }
+        return ('#hasheq(' + ret.join(' ') + ')');
+    };
+    
+    EqHashTable.prototype.toDisplayedString = function(cache) {
+        var keys = this.hash.keys();
+        var ret = [];
+        for (var i = 0; i < keys.length; i++) {
+	    var keyStr = toDisplayedString(keys[i], cache);
+	    var valStr = toDisplayedString(this.hash.get(keys[i]), cache);
+	    ret.push('(' + keyStr + ' . ' + valStr + ')');
+        }
+        return ('#hasheq(' + ret.join(' ') + ')');
+    };
+
+    EqHashTable.prototype.equals = function(other, aUnionFind) {
+        if ( !(other instanceof EqHashTable) ) {
+	    return false; 
+        }
+
+        if (this.hash.keys().length != other.hash.keys().length) { 
+	    return false;
+        }
+
+        var keys = this.hash.keys();
+        for (var i = 0; i < keys.length; i++){
+	    if ( !(other.hash.containsKey(keys[i]) &&
+	           plt.baselib.equality.equals(this.hash.get(keys[i]),
+		                               other.hash.get(keys[i]),
+		                               aUnionFind)) ) {
+		return false;
+	    }
+        }
+        return true;
+    };
+
+
+
+    //////////////////////////////////////////////////////////////////////
+    // Equal hash tables
+    var EqualHashTable = function(inputHash) {
+	this.hash = new _Hashtable(
+            function(x) {
+	        return plt.baselib.format.toWrittenString(x); 
+	    },
+	    function(x, y) {
+		return plt.baselib.equality.equals(x, y, new plt.baselib.UnionFind()); 
+	    });
+	this.mutable = true;
+    };
+
+    EqualHashTable.prototype.toWrittenString = function(cache) {
+        var keys = this.hash.keys();
+        var ret = [];
+        for (var i = 0; i < keys.length; i++) {
+	    var keyStr = plt.baselib.format.toWrittenString(keys[i], cache);
+	    var valStr = plt.baselib.format.toWrittenString(this.hash.get(keys[i]), cache);
+	    ret.push('(' + keyStr + ' . ' + valStr + ')');
+        }
+        return ('#hash(' + ret.join(' ') + ')');
+    };
+    EqualHashTable.prototype.toDisplayedString = function(cache) {
+        var keys = this.hash.keys();
+        var ret = [];
+        for (var i = 0; i < keys.length; i++) {
+	    var keyStr = plt.baselib.format.toDisplayedString(keys[i], cache);
+	    var valStr = plt.baselib.format.toDisplayedString(this.hash.get(keys[i]), cache);
+	    ret.push('(' + keyStr + ' . ' + valStr + ')');
+        }
+        return ('#hash(' + ret.join(' ') + ')');
+    };
+
+    EqualHashTable.prototype.equals = function(other, aUnionFind) {
+        if ( !(other instanceof EqualHashTable) ) {
+	    return false; 
+        }
+
+        if (this.hash.keys().length != other.hash.keys().length) { 
+	    return false;
+        }
+
+        var keys = this.hash.keys();
+        for (var i = 0; i < keys.length; i++){
+	    if (! (other.hash.containsKey(keys[i]) &&
+	           plt.baselib.equality.equals(this.hash.get(keys[i]),
+		                               other.hash.get(keys[i]),
+		                               aUnionFind))) {
+	        return false;
+	    }
+        }
+        return true;
+    };
+
+
+
+
+    var isHash = function(x) { 
+        return (x instanceof EqHashTable ||
+		x instanceof EqualHashTable); 
+    };
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+    exports.getEqHashCode = getEqHashCode;
+    exports.makeEqHashCode = makeEqHashCode;
+    exports.makeLowLevelEqHash = makeLowLevelEqHash;
+
+
+    exports.EqualHashTable = EqualHashTable;
+    exports.EqHashTable = EqHashTable;
+    exports.isHash = isHash;
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-inspectors.js

@@ -1,18 +1,15 @@
-/*jslint vars: true, maxerr: 50, indent: 4 */
-
 // Structure types
 
-(function (baselib) {
+(function(baselib) {
-    'use strict';
     var exports = {};
     baselib.inspectors = exports;
 
 
-    var Inspector = function () {
+    var Inspector = function() {
     };
     var DEFAULT_INSPECTOR = new Inspector();
 
-    Inspector.prototype.toString = function () {
+    Inspector.prototype.toString = function() {
         return "#<inspector>";
     };
 
@@ -26,4 +23,4 @@
     exports.isInspector = isInspector;
 
 
-}(this.plt.baselib));
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-keywords.js

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

js-assembler/runtime-src/baselib-lists.js

@@ -0,0 +1,228 @@
+// list structures (pairs, empty)
+(function(baselib) {
+    var exports = {};
+    baselib.lists = exports;
+
+    
+
+
+    
+    Empty = function() {
+    };
+    Empty.EMPTY = new Empty();
+    var EMPTY = Empty.EMPTY;
+
+
+
+    Empty.prototype.equals = function(other, aUnionFind) {
+        return other instanceof Empty;
+    };
+
+    Empty.prototype.reverse = function() {
+        return this;
+    };
+
+    Empty.prototype.toWrittenString = function(cache) { return "empty"; };
+    Empty.prototype.toDisplayedString = function(cache) { return "empty"; };
+    Empty.prototype.toString = function(cache) { return "()"; };
+
+    
+    // Empty.append: (listof X) -> (listof X)
+    Empty.prototype.append = function(b){
+        return b;
+    };
+    
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+    // Cons Pairs
+
+    var Cons = function(first, rest) {
+        this.first = first;
+        this.rest = rest;
+    };
+
+    Cons.prototype.reverse = function() {
+        var lst = this;
+        var ret = EMPTY;
+        while (lst !== EMPTY) {
+	    ret = Cons.makeInstance(lst.first, ret);
+	    lst = lst.rest;
+        }
+        return ret;
+    };
+    
+    Cons.makeInstance = function(first, rest) {
+        return new Cons(first, rest);
+    };
+
+    // FIXME: can we reduce the recursion on this?
+    Cons.prototype.equals = function(other, aUnionFind) {
+        if (! (other instanceof Cons)) {
+	    return false;
+        }
+        return (plt.baselib.equality.equals(this.first, other.first, aUnionFind) &&
+	        plt.baselib.equality.equals(this.rest, other.rest, aUnionFind));
+    };
+    
+
+    
+
+    // Cons.append: (listof X) -> (listof X)
+    Cons.prototype.append = function(b){
+        if (b === EMPTY)
+	    return this;
+        var ret = b;
+        var lst = this.reverse();
+        while (lst !== EMPTY) {
+	    ret = Cons.makeInstance(lst.first, ret);
+	    lst = lst.rest;
+        }
+	
+        return ret;
+    };
+    
+
+    Cons.prototype.toWrittenString = function(cache) {
+        cache.put(this, true);
+        var texts = [];
+        var p = this;
+        while ( p instanceof Cons ) {
+	    texts.push(plt.baselib.format.toWrittenString(p.first, cache));
+	    p = p.rest;
+	    if (typeof(p) === 'object' && cache.containsKey(p)) {
+	        break;
+	    }
+        }
+        if ( p !== EMPTY ) {
+	    texts.push('.');
+	    texts.push(plt.baselib.format.toWrittenString(p, cache));
+        }
+        return "(" + texts.join(" ") + ")";
+    };
+
+    Cons.prototype.toString = Cons.prototype.toWrittenString;
+
+    Cons.prototype.toDisplayedString = function(cache) {
+        cache.put(this, true);
+        var texts = [];
+        var p = this;
+        while ( p instanceof Cons ) {
+	    texts.push(plt.baselib.format.toDisplayedString(p.first, cache));
+	    p = p.rest;
+	    if (typeof(p) === 'object' && cache.containsKey(p)) {
+	        break;
+	    }
+        }
+        if ( p !== Empty.EMPTY ) {
+	    texts.push('.');
+	    texts.push(plt.baselib.format.toDisplayedString(p, cache));
+        }
+        return "(" + texts.join(" ") + ")";
+    };
+
+
+
+    Cons.prototype.toDomNode = function(cache) {
+        cache.put(this, true);
+        var node = document.createElement("span");
+        node.appendChild(document.createTextNode("("));
+        var p = this;
+        while ( p instanceof Cons ) {
+	    node.appendChild(plt.baselib.format.toDomNode(p.first, cache));
+	    p = p.rest;
+	    if ( p !== Empty.EMPTY ) {
+	        node.appendChild(document.createTextNode(" "));
+	    }
+	    if (typeof(p) === 'object' && cache.containsKey(p)) {
+	        break;
+	    }
+        }
+        if ( p !== Empty.EMPTY ) {
+	    node.appendChild(document.createTextNode("."));
+	    node.appendChild(document.createTextNode(" "));
+	    node.appendChild(plt.baselib.format.toDomNode(p, cache));
+        }
+
+        node.appendChild(document.createTextNode(")"));
+        return node;
+    };
+
+
+    var isPair = function(x) { return x instanceof Cons; };
+    var isEmpty = function(x) { return x === Empty.EMPTY; };
+
+
+    var makePair = Cons.makeInstance;
+
+    var makeList = function() {
+        var result = Empty.EMPTY;
+        for(var i = arguments.length-1; i >= 0; i--) {
+	    result = Cons.makeInstance(arguments[i], result);
+        }
+        return result;
+    };
+
+
+    // isList: Any -> Boolean
+    // Returns true if x is a list (a chain of pairs terminated by EMPTY).
+    var isList = function(x) { 
+	while (x !== Empty.EMPTY) {
+	    if (x instanceof Cons) {
+		x = x.rest;
+	    } else {
+		return false;
+	    }
+	}
+	return true;
+    };
+
+
+
+    var reverse = function(lst) {
+	var rev = EMPTY;
+	while(lst !== EMPTY) {
+	    rev = makePair(lst.first, rev);
+	    lst = lst.rest;
+	}
+	return rev;
+    };
+
+
+    var length = function(lst) {
+        var len = 0;
+        while (lst !== EMPTY) {
+            len++;
+            lst = lst.rest;
+        }
+        return len;
+    };
+
+
+    var listRef = function(lst, n) {
+        for (var i = 0; i < n; i++) {
+            lst = lst.rest;
+        }
+        return lst.first;
+    }
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+    exports.EMPTY = EMPTY;
+    exports.Empty = Empty;
+    exports.Cons = Cons;
+    exports.isPair = isPair;
+    exports.isList = isList;
+    exports.isEmpty = isEmpty;
+    exports.makePair = makePair;
+    exports.makeList = makeList;
+    exports.reverse = reverse;
+    exports.length = length;
+    exports.listRef = listRef;
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-modules.js

@@ -0,0 +1,80 @@
+(function(baselib) {
+    var exports = {};
+    baselib.modules = exports;
+
+
+    var ModuleRecord = function(name, label) {
+	this.name = name;
+	this.label = label;
+	this.isInvoked = false;
+        this.prefix = false;
+	this.namespace = {};
+
+        // JavaScript-implemented code will assign privateExports
+        // with all of the exported identifiers.
+        this.privateExports = {};
+    };
+
+    // Returns access to the names defined in the module.
+    ModuleRecord.prototype.getNamespace = function() {
+	return this.namespace;
+    };
+
+    ModuleRecord.prototype.finalizeModuleInvokation = function() {
+	var i, len = this.prefix.names.length;
+	for (i=0; i < len; i++) {
+	    this.namespace[this.prefix.names[i]] = this.prefix[i];
+	}
+    };
+    
+
+    // External invokation of a module.
+    ModuleRecord.prototype.invoke = function(MACHINE, succ, fail) {
+        this._invoke(false, MACHINE, succ, fail);
+    };
+
+    // Internal invokation of a module.
+    ModuleRecord.prototype.internalInvoke = function(MACHINE, succ, fail) {
+        this._invoke(true, MACHINE, succ, fail);
+    };
+
+    // Private: general invokation of a module
+    ModuleRecord.prototype._invoke = function(isInternal, MACHINE, succ, fail) {
+        var that = this;
+        MACHINE = MACHINE || plt.runtime.currentMachine;
+        succ = succ || function(){};
+        fail = fail || function(){};
+
+        var oldErrorHandler = MACHINE.params['currentErrorHandler'];
+        var afterGoodInvoke = function(MACHINE) { 
+            MACHINE.params['currentErrorHandler'] = oldErrorHandler;
+            succ();
+        };
+
+        if (this.isInvoked) {
+            succ();
+        } else {
+            MACHINE.params['currentErrorHandler'] = function(MACHINE, anError) {
+                MACHINE.params['currentErrorHandler'] = oldErrorHandler;
+		fail(MACHINE, anError)
+            };
+            MACHINE.control.push(new plt.baselib.frames.CallFrame(afterGoodInvoke, null));
+            if (isInternal) {
+                throw that.label;
+            } else {
+                plt.runtime.trampoline(MACHINE, that.label);
+            }
+        }
+    };
+
+
+
+
+
+
+
+
+    exports.ModuleRecord = ModuleRecord;
+
+
+})(this['plt'].baselib);

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

@@ -0,0 +1,77 @@
+// Numbers.
+(function(baselib) {
+    var exports = {};
+    baselib.numbers = exports;
+
+
+
+    var isNumber = jsnums.isSchemeNumber;
+    var isReal = jsnums.isReal;
+    var isRational = jsnums.isRational;
+    var isComplex = isNumber;
+    var isInteger = jsnums.isInteger;
+
+
+    var isNatural = function(x) {
+        return (jsnums.isExact(x) && isInteger(x) 
+	        && jsnums.greaterThanOrEqual(x, 0));
+    };
+
+    var isNonNegativeReal = function(x) {
+	return isReal(x) && jsnums.greaterThanOrEqual(x, 0);
+    };
+
+    var isByte = function(x) {
+	return (isNatural(x) && 
+		jsnums.lessThan(x, 256));
+    };
+
+
+    // sign: number -> number
+    var sign = function(x) {
+        if (jsnums.isInexact(x)) {
+	    if (jsnums.greaterThan(x, 0) ) {
+		return jsnums.makeFloat(1);
+	    } else if (jsnums.lessThan(x, 0) ) {
+		return jsnums.makeFloat(-1);
+	    } else {
+		return jsnums.makeFloat(0);
+	    }
+	} else {
+	    if (jsnums.greaterThan(x, 0)) {
+		return 1;
+	    } else if (jsnums.lessThan(x, 0)) {
+		return -1;
+	    } else {
+		return 0;
+	    }
+	}
+    };
+
+
+
+
+    //////////////////////////////////////////////////////////////////////
+    // Exports
+
+
+    // We first re-export everything in jsnums.
+    for (var prop in jsnums) {
+        if (jsnums.hasOwnProperty(prop)) {
+            exports[prop] = jsnums[prop];
+        }
+    }
+
+    exports.isNumber = jsnums.isSchemeNumber;
+    exports.isReal = isReal;
+    exports.isRational = isRational;
+    exports.isComplex = isComplex;
+    exports.isInteger = isInteger;
+    exports.isNatural = isNatural;
+    exports.isByte = isByte;
+    exports.isNonNegativeReal = isNonNegativeReal;
+
+    exports.sign = sign;
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-paths.js

@@ -0,0 +1,19 @@
+(function(baselib) {
+    var exports = {};
+    baselib.paths = exports;
+
+    // Paths
+
+    var Path = function(p) {
+        this.path = p;
+    };
+
+    Path.prototype.toString = function() {
+        return String(this.path);
+    };
+
+    //////////////////////////////////////////////////////////////////////
+
+    exports.Path = Path;
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-placeholders.js

@@ -0,0 +1,58 @@
+// Placeholders
+
+(function(baselib) {
+    var exports = {};
+    baselib.placeholders = exports;
+
+
+    // Placeholders: same thing as boxes.  Distinct type just to support make-reader-graph.
+
+    var Placeholder = function(x, mutable) {
+        this.val = x;
+    };
+
+    Placeholder.prototype.ref = function() {
+        return this.val;
+    };
+
+    Placeholder.prototype.set = function(newVal) {
+	this.val = newVal;
+    };
+
+    Placeholder.prototype.toString = function(cache) {
+        return "#<placeholder>";
+    };
+
+    Placeholder.prototype.toWrittenString = function(cache) {
+        return "#<placeholder>";
+    };
+
+    Placeholder.prototype.toDisplayedString = function(cache) {
+        return "#<placeholder>";
+    };
+
+    Placeholder.prototype.toDomNode = function(cache) {
+        var parent = document.createElement("span");
+        parent.appendChild(document.createTextNode('#<placeholder>'));
+        return parent;
+    };
+
+    Placeholder.prototype.equals = function(other, aUnionFind) {
+        return ((other instanceof Placeholder) &&
+	        plt.baselib.equality.equals(this.val, other.val, aUnionFind));
+    };
+
+
+    var isPlaceholder = function(x) { 
+        return x instanceof Placeholder; 
+    };
+    
+
+
+    //////////////////////////////////////////////////////////////////////
+    exports.Placeholder = Placeholder;
+    exports.isPlaceholder = isPlaceholder;
+
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-ports.js

@@ -0,0 +1,59 @@
+// Arity structure
+(function(baselib) {
+    var exports = {};
+    baselib.ports = exports;
+
+
+    // Output Ports
+
+    var OutputPort = function() {};
+    var isOutputPort = baselib.makeClassPredicate(OutputPort);
+
+
+    var StandardOutputPort = function() {
+        OutputPort.call(this);
+    };
+    StandardOutputPort.prototype = baselib.heir(OutputPort.prototype);
+    StandardOutputPort.prototype.writeDomNode = function(MACHINE, domNode) {
+	MACHINE.params['currentDisplayer'](MACHINE, domNode);
+        jQuery('*', domNode).trigger({type : 'afterAttach'});
+    };
+
+    var StandardErrorPort = function() {
+        OutputPort.call(this);
+    };
+    StandardErrorPort.prototype = baselib.heir(OutputPort.prototype);
+    StandardErrorPort.prototype.writeDomNode = function(MACHINE, domNode) {
+	MACHINE.params['currentErrorDisplayer'](MACHINE, domNode);
+        jQuery('*', domNode).trigger({type : 'afterAttach'});
+    };
+
+
+
+
+
+
+    var OutputStringPort = function() {
+	this.buf = [];
+    };
+    OutputStringPort.prototype = baselib.heir(OutputPort.prototype);
+    OutputStringPort.prototype.writeDomNode = function(MACHINE, v) {
+	this.buf.push($(v).text());
+    };
+    OutputStringPort.prototype.getOutputString = function() {
+	return this.buf.join('');
+    };
+    var isOutputStringPort = baselib.makeClassPredicate(OutputStringPort);
+
+
+
+
+    exports.OutputPort = OutputPort;
+    exports.isOutputPort = isOutputPort;
+    exports.StandardOutputPort = StandardOutputPort;
+    exports.StandardErrorPort = StandardErrorPort;
+    exports.OutputStringPort = OutputStringPort;
+    exports.isOutputStringPort = isOutputStringPort;
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-readergraph.js

@@ -0,0 +1,59 @@
+// Arity structure
+(function(baselib) {
+    var exports = {};
+    baselib.readergraph = exports;
+
+
+    var readerGraph = function(x, objectHash, n) {
+        if (typeof(x) === 'object' && objectHash.containsKey(x)) {
+	    return objectHash.get(x);
+        }
+
+        if (plt.baselib.lists.isPair(x)) {
+	    var consPair = plt.baselib.lists.makePair(x.first, x.rest);
+	    objectHash.put(x, consPair);
+	    consPair.first = readerGraph(x.first, objectHash, n+1);
+	    consPair.rest = readerGraph(x.rest, objectHash, n+1);
+	    return consPair;
+        }
+
+        if (plt.baselib.vectors.isVector(x)) {
+	    var len = x.length();
+	    var aVector = plt.baselib.vectors.makeVector(len, x.elts);
+	    objectHash.put(x, aVector);	
+	    for (var i = 0; i < len; i++) {
+	        aVector.elts[i] = readerGraph(aVector.elts[i], objectHash, n+1);
+	    }
+	    return aVector;
+        }
+
+        if (plt.baselib.boxes.isBox(x)) {
+	    var aBox = plt.baselib.boxes.makeBox(x.ref());
+	    objectHash.put(x, aBox);
+	    aBox.val = readerGraph(x.ref(), objectHash, n+1);
+	    return aBox;
+        }
+
+        if (plt.baselib.hashes.isHash(x)) {
+	    throw new Error("make-reader-graph of hash not implemented yet");
+        }
+
+        if (plt.baselib.structs.isStruct(x)) {
+	    var aStruct = baselib.clone(x);
+	    objectHash.put(x, aStruct);
+	    for(var i = 0 ;i < x._fields.length; i++) {
+	        x._fields[i] = readerGraph(x._fields[i], objectHash, n+1);
+	    }
+	    return aStruct;
+        }
+
+        if (plt.baselib.placeholders.isPlaceholder(x)) {
+	    return readerGraph(x.ref(), objectHash, n+1);
+        }
+
+        return x;
+    };
+
+    exports.readerGraph = readerGraph;
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-regexps.js

@@ -1,19 +1,16 @@
-/*jslint vars: true, maxerr: 50, indent: 4 */
+(function(baselib) {
-
-(function (baselib) {
-    'use strict';
     var exports = {};
     baselib.regexps = exports;
 
 
     // Regular expressions.
 
-    var RegularExpression = function (pattern) {
+    var RegularExpression = function(pattern) {
         this.pattern = pattern;
     };
 
 
-    var ByteRegularExpression = function (pattern) {
+    var ByteRegularExpression = function(pattern) {
         this.pattern = pattern;
     };
 
@@ -22,4 +19,4 @@
     exports.RegularExpression = RegularExpression;
     exports.ByteRegularExpression = ByteRegularExpression;
 
-}(this.plt.baselib));
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-strings.js

@@ -0,0 +1,172 @@
+// Strings
+
+// Strings are either mutable or immutable.  immutable strings are represented
+// as regular JavaScript strings.  Mutable ones are represented as instances
+// of the Str class.
+
+(function(baselib) {
+    var exports = {};
+
+    baselib.strings = exports;
+
+
+
+    var isString = function(s) {
+	return (typeof s === 'string' || 
+                s instanceof Str);
+    };
+
+
+
+
+
+    // Now using mutable strings
+    var Str = function(chars) {
+	this.chars = chars;
+	this.length = chars.length;
+	this.mutable = true;
+    }
+
+    Str.makeInstance = function(chars) {
+	return new Str(chars);
+    }
+
+    Str.fromString = function(s) {
+	return Str.makeInstance(s.split(""));
+    }
+
+    Str.prototype.toString = function() {
+	return this.chars.join("");
+    }
+
+    Str.prototype.toWrittenString = function(cache) {
+        return escapeString(this.toString());
+    }
+
+    Str.prototype.toDisplayedString = Str.prototype.toString;
+
+    Str.prototype.copy = function() {
+	return Str.makeInstance(this.chars.slice(0));
+    }
+
+    Str.prototype.substring = function(start, end) {
+	if (end == null || end == undefined) {
+	    end = this.length;
+	}
+	
+	return Str.makeInstance( this.chars.slice(start, end) );
+    }
+
+    Str.prototype.charAt = function(index) {
+	return this.chars[index];
+    }
+
+    Str.prototype.charCodeAt = function(index) {
+	return this.chars[index].charCodeAt(0);
+    }
+
+    Str.prototype.replace = function(expr, newStr) {
+	return Str.fromString( this.toString().replace(expr, newStr) );
+    }
+
+
+    Str.prototype.equals = function(other, aUnionFind) {
+	if ( !(other instanceof Str || typeof(other) == 'string') ) {
+	    return false;
+	}
+	return this.toString() === other.toString();
+    }
+
+
+    Str.prototype.set = function(i, c) {
+	this.chars[i] = c;
+    }
+
+    Str.prototype.toUpperCase = function() {
+	return Str.fromString( this.chars.join("").toUpperCase() );
+    }
+
+    Str.prototype.toLowerCase = function() {
+	return Str.fromString( this.chars.join("").toLowerCase() );
+    }
+
+    Str.prototype.match = function(regexpr) {
+	return this.toString().match(regexpr);
+    }
+
+
+    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('');
+    };
+
+
+    /*
+// Strings
+// For the moment, we just reuse Javascript strings.
+String = String;
+String.makeInstance = function(s) {
+    return s.valueOf();
+};
+    
+    
+// WARNING
+// WARNING: we are extending the built-in Javascript string class here!
+// WARNING
+String.prototype.equals = function(other, aUnionFind){
+    return this == other;
+};
+    
+var _quoteReplacingRegexp = new RegExp("[\"\\\\]", "g");
+String.prototype.toWrittenString = function(cache) {
+    return '"' + this.replace(_quoteReplacingRegexp,
+			      function(match, submatch, index) {
+				  return "\\" + match;
+			      }) + '"';
+};
+
+String.prototype.toDisplayedString = function(cache) {
+    return this;
+};
+*/
+
+
+    //////////////////////////////////////////////////////////////////////
+
+
+
+    exports.Str = Str;
+    exports.escapeString = escapeString;
+    exports.isString = isString;
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-structs.js

@@ -0,0 +1,286 @@
+// Structure types
+
+(function(baselib) {
+    var exports = {};
+    baselib.structs = exports;
+
+
+
+
+
+
+    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) {
+        // Defaults
+        autoFieldCnt = autoFieldCnt || 0;
+        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.symbols.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.baselib.format.toWrittenString(this._fields[i], cache));
+	}
+	buffer.push(")");
+	return buffer.join("");
+    };
+
+    Struct.prototype.toDisplayedString = function(cache) {
+	return plt.baselib.format.toWrittenString(this, cache); 
+    };
+
+    Struct.prototype.toDomNode = function(params) {
+	params.put(this, true);
+	var node = document.createElement("span");
+	$(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.baselib.format.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 };
+
+
+
+    var isStruct = function(x) { return x instanceof Struct; };
+    var isStructType = function(x) { return x instanceof StructType; };
+
+
+    //////////////////////////////////////////////////////////////////////
+
+
+    exports.StructType = StructType;
+    exports.Struct = Struct;
+    exports.makeStructureType = makeStructureType;
+    exports.isStruct = isStruct;
+    exports.isStructType = isStructType;
+
+//     exports.StructProc = StructProc;
+//     exports.StructConstructorProc = StructConstructorProc;
+//     exports.StructPredicateProc = StructPredicateProc;
+//     exports.StructAccessorProc = StructAccessorProc;
+//     exports.StructMutatorProc = StructMutatorProc;
+
+
+
+
+    
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib-symbols.js

@@ -0,0 +1,61 @@
+// Structure types
+
+(function(baselib) {
+    
+    var exports = {};
+    baselib.symbols = exports;
+
+
+    //////////////////////////////////////////////////////////////////////
+    
+    // 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;
+    };
+
+
+    var isSymbol = function(x) { return x instanceof Symbol; };
+
+    var makeSymbol = function(s) { return Symbol.makeInstance(s); };
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+    exports.Symbol = Symbol;
+    exports.makeSymbol = makeSymbol;
+    exports.isSymbol = isSymbol;
+
+})(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.hashes.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/baselib-vectors.js

@@ -0,0 +1,117 @@
+// vectors
+(function(baselib) {
+    var exports = {};
+    baselib.vectors = exports;
+
+
+
+    Vector = function(n, initialElements) {
+        this.elts = new Array(n);
+        if (initialElements) {
+	    for (var i = 0; i < n; i++) {
+	        this.elts[i] = initialElements[i];
+	    }
+        } else {
+	    for (var i = 0; i < n; i++) {
+	        this.elts[i] = undefined;
+	    }
+        }
+        this.mutable = true;
+    };
+
+    Vector.makeInstance = function(n, elts) {
+        return new Vector(n, elts);
+    }
+
+    Vector.prototype.length = function() {
+	return this.elts.length;
+    };
+
+    Vector.prototype.ref = function(k) {
+        return this.elts[k];
+    };
+
+    Vector.prototype.set = function(k, v) {
+        this.elts[k] = v;
+    };
+
+    Vector.prototype.equals = function(other, aUnionFind) {
+        if (other != null && other != undefined && other instanceof Vector) {
+	    if (other.length() != this.length()) {
+	        return false
+	    }
+	    for (var i = 0; i <  this.length(); i++) {
+	        if (! plt.baselib.equality.equals(this.elts[i], other.elts[i], aUnionFind)) {
+		    return false;
+	        }
+	    }
+	    return true;
+        } else {
+	    return false;
+        }
+    };
+
+    Vector.prototype.toList = function() {
+        var ret = plt.baselib.lists.EMPTY;
+        for (var i = this.length() - 1; i >= 0; i--) {
+	    ret = plt.baselib.lists.Cons.makeInstance(this.elts[i], ret);	    
+        }	
+        return ret;
+    };
+
+    Vector.prototype.toWrittenString = function(cache) {
+        cache.put(this, true);
+        var texts = [];
+        for (var i = 0; i < this.length(); i++) {
+	    texts.push(plt.baselib.format.toWrittenString(this.ref(i), cache));
+        }
+        return "#(" + texts.join(" ") + ")";
+    };
+
+    Vector.prototype.toDisplayedString = function(cache) {
+        cache.put(this, true);
+        var texts = [];
+        for (var i = 0; i < this.length(); i++) {
+	    texts.push(plt.baselib.format.toDisplayedString(this.ref(i), cache));
+        }
+        return "#(" + texts.join(" ") + ")";
+    };
+
+    Vector.prototype.toDomNode = function(cache) {
+        cache.put(this, true);
+        var node = document.createElement("span");
+        node.appendChild(document.createTextNode("#("));
+        for (var i = 0; i < this.length(); i++) {
+	    node.appendChild(plt.baselib.format.toDomNode(this.ref(i), cache));
+	    if (i !== this.length()-1) {
+	        node.appendChild(document.createTextNode(" "));
+	    }
+        }
+        node.appendChild(document.createTextNode(")"));
+        return node;
+    };
+
+
+    var isVector = function(x) { return x instanceof Vector; };
+
+    var makeVector = function() {
+        return Vector.makeInstance(arguments.length, arguments);
+    };
+
+    var makeVectorImmutable = function() {
+        var v = Vector.makeInstance(arguments.length, arguments);
+        v.mutable = false;
+        return v;
+    };
+
+
+
+    //////////////////////////////////////////////////////////////////////
+
+    exports.Vector = Vector;
+    exports.isVector = isVector;
+    exports.makeVector = makeVector;
+    exports.makeVectorImmutable = makeVectorImmutable;
+
+
+})(this['plt'].baselib);

js-assembler/runtime-src/baselib.js

@@ -1,64 +1,61 @@
-/*jslint vars: true, plusplus: true, maxerr: 50, indent: 4 */
-
 // Basic library functions.  This will include a few simple functions,
 // but be augmented with several namespaces for the other libraries in
 // the base library.
-if (!(this.plt)) { this.plt = {}; }
+if (! this['plt']) { this['plt'] = {}; }
 (function (plt) {
-    'use strict';
     var baselib = {};
-    plt.baselib = baselib;
+    plt['baselib'] = baselib;
 
 
 
     // Simple object inheritance.
-    var heir = function (parentPrototype) {
+    var heir = function(parentPrototype) {
-        var F = function () {};
+	var f = function() {}
-        F.prototype = parentPrototype;
+	f.prototype = parentPrototype;
-        return new F();
+	return new f();
     };
 
 
 
-    var hasOwnProperty = {}.hasOwnProperty;
-
     // 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 clone = function(obj) {
-        var property;
+        var C = function() {}
-        var C = function () {};
         C.prototype = obj;
         var c = new C();
         for (property in obj) {
-            if (hasOwnProperty.call(obj, property)) {
+	    if (obj.hasOwnProperty(property)) {
-                c[property] = obj[property];
+	        c[property] = obj[property];
-            }
+	    }
         }
         return c;
     };
 
 
     // Consumes a class and creates a predicate that recognizes subclasses.
-    var makeClassPredicate = function (aClass) {
+    var makeClassPredicate = function(aClass) {
-        return function (x) { return x instanceof aClass; };
+	return function(x) { return x instanceof aClass; };
     };
 
 
 
     // Helper to deal with the argument-passing of primitives.  Call f
-    // with arguments bound from MACHINE.e, assuming
+    // with arguments bound from MACHINE.env, assuming
-    // MACHINE.a has been initialized with the number of
+    // MACHINE.argcount has been initialized with the number of
     // arguments on the stack.  vs provides optional values for the
     // arguments that go beyond those of the mandatoryArgCount.
-    var withArguments = function (MACHINE, mandatoryArgCount, vs, f) {
+    var withArguments = function(MACHINE,
-        var args = [], i;
+                                 mandatoryArgCount,
-        for (i = 0; i < MACHINE.a; i++) {
+                                 vs,
+                                 f) {
+        var args = [];
+        for (var i = 0; i < MACHINE.argcount; i++) {
             if (i < mandatoryArgCount) {
-                args.push(MACHINE.e[MACHINE.e.length - 1 - i]);
+                args.push(MACHINE.env[MACHINE.env.length - 1 - i]);
             } else {
-                if (i < MACHINE.a) {
+                if (i < MACHINE.argcount) {
-                    args.push(MACHINE.e[MACHINE.e.length - 1 - i]);
+                    args.push(MACHINE.env[MACHINE.env.length - 1 - i]);
                 } else {
                     args.push(vs[mandatoryArgCount - i]);
                 }
@@ -75,4 +72,4 @@ if (!(this.plt)) { this.plt = {}; }
     baselib.withArguments = withArguments;
 
 
-}(this.plt));
+})(this['plt']);

js-assembler/runtime-src/helpers.js

@@ -0,0 +1,513 @@
+// 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'];
+                     });
+
+
+
+
+
+
+    // 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();
+    };
+
+
+
+ 
+
+
+
+
+
+    // 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.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.heir = heir;
+
+
+
+    helpers.clone = clone;
+
+
+    scope.link.announceReady('helpers');
+})(this['plt']);
+
+/////////////////////////////////////////////////////////////////

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

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