suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

comments

Browse Source
This commit is contained in:
Danny Yoo 2011-09-12 10:50:00 -04:00
commit 43bff9fefe
28 changed files with 1119 additions and 9894 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
compiler/compiler.rkt
View File

@ -1417,13 +1417,13 @@
linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
(make-TestAndJumpStatement (make-TestPrimitiveProcedure ;; (make-TestAndJumpStatement (make-TestPrimitiveProcedure
(make-Reg 'proc)) ;; (make-Reg 'proc))
primitive-branch) ;; primitive-branch)
;; Compiled branch ;; Compiled branch
(make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))) (make-PerformStatement (make-CheckClosureAndArity! (make-Reg 'argcount)))
(compile-compiled-procedure-application cenv (compile-compiled-procedure-application cenv
number-of-arguments number-of-arguments
'dynamic 'dynamic
@ -1431,24 +1431,24 @@
compiled-linkage) compiled-linkage)
;; Primitive branch ;; Primitive branch
primitive-branch ;; primitive-branch
(make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount))) ;; (make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount)))
(compile-primitive-application cenv target primitive-linkage) ;; (compile-primitive-application cenv target primitive-linkage)
after-call))))) after-call)))))
(: compile-primitive-application (CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; (: compile-primitive-application (CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-primitive-application cenv target linkage) ;; (define (compile-primitive-application cenv target linkage)
(let ([singular-context-check (emit-singular-context linkage)]) ;; (let ([singular-context-check (emit-singular-context linkage)])
(append-instruction-sequences ;; (append-instruction-sequences
(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) ;; (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
(make-PopEnvironment (make-Reg 'argcount) ;; (make-PopEnvironment (make-Reg 'argcount)
(make-Const 0)) ;; (make-Const 0))
(if (eq? target 'val) ;; (if (eq? target 'val)
empty-instruction-sequence ;; empty-instruction-sequence
(make-AssignImmediateStatement target (make-Reg 'val))) ;; (make-AssignImmediateStatement target (make-Reg 'val)))
singular-context-check))) ;; singular-context-check)))

24
compiler/il-structs.rkt
View File

@ -280,7 +280,6 @@
(define-type PrimitiveOperator (U GetCompiledProcedureEntry (define-type PrimitiveOperator (U GetCompiledProcedureEntry
MakeCompiledProcedure MakeCompiledProcedure
MakeCompiledProcedureShell MakeCompiledProcedureShell
ApplyPrimitiveProcedure
MakeBoxedEnvironmentValue MakeBoxedEnvironmentValue
@ -312,15 +311,6 @@
#:transparent) #: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)
@ -356,14 +346,12 @@
TestTrue TestTrue
TestOne TestOne
TestZero TestZero
TestPrimitiveProcedure
TestClosureArityMismatch TestClosureArityMismatch
)) ))
(define-struct: TestFalse ([operand : OpArg]) #:transparent) (define-struct: TestFalse ([operand : OpArg]) #:transparent)
(define-struct: TestTrue ([operand : OpArg]) #:transparent) (define-struct: TestTrue ([operand : OpArg]) #:transparent)
(define-struct: TestOne ([operand : OpArg]) #:transparent) (define-struct: TestOne ([operand : OpArg]) #:transparent)
(define-struct: TestZero ([operand : OpArg]) #:transparent) (define-struct: TestZero ([operand : OpArg]) #:transparent)
(define-struct: TestPrimitiveProcedure ([operand : OpArg]) #:transparent)
(define-struct: TestClosureArityMismatch ([closure : OpArg] (define-struct: TestClosureArityMismatch ([closure : OpArg]
[n : OpArg]) #:transparent) [n : OpArg]) #:transparent)
@ -375,13 +363,10 @@
[pos : Natural]) [pos : Natural])
#:transparent) #:transparent)
;; Check the closure procedure value in 'proc and make sure it can accept the ;; Check the closure procedure value in 'proc and make sure it's a closure
;; # of arguments (stored as a number in the argcount register.). ;; that can accept the right arguments (stored as a number in the argcount register.).
(define-struct: CheckClosureArity! ([num-args : OpArg]) (define-struct: CheckClosureAndArity! ([num-args : OpArg])
#:transparent) #:transparent)
(define-struct: CheckPrimitiveArity! ([num-args : OpArg])
#:transparent)
;; Extends the environment with a prefix that holds ;; Extends the environment with a prefix that holds
@ -481,8 +466,7 @@
(define-type PrimitiveCommand (U (define-type PrimitiveCommand (U
CheckToplevelBound! CheckToplevelBound!
CheckClosureArity! CheckClosureAndArity!
CheckPrimitiveArity!
ExtendEnvironment/Prefix! ExtendEnvironment/Prefix!
InstallClosureValues! InstallClosureValues!

2
compiler/optimize-il.rkt
View File

@ -128,8 +128,6 @@
(MakeCompiledProcedureShell-arity op) (MakeCompiledProcedureShell-arity op)
(MakeCompiledProcedureShell-display-name op))] (MakeCompiledProcedureShell-display-name op))]
[(ApplyPrimitiveProcedure? op)
op]
[(MakeBoxedEnvironmentValue? op) [(MakeBoxedEnvironmentValue? op)
op] op]

8
examples/fact.rkt Normal file
View File

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

15
js-assembler/assemble-expression.rkt
View File

@ -14,10 +14,10 @@
(define (assemble-op-expression op) (define (assemble-op-expression op)
(cond (cond
[(GetCompiledProcedureEntry? op) [(GetCompiledProcedureEntry? op)
"MACHINE.proc.label"] "M.proc.label"]
[(MakeCompiledProcedure? op) [(MakeCompiledProcedure? op)
(format "new RUNTIME.Closure(~a, ~a, [~a], ~a)" (format "new RT.Closure(~a, ~a, [~a], ~a)"
(assemble-label (make-Label (MakeCompiledProcedure-label op))) (assemble-label (make-Label (MakeCompiledProcedure-label op)))
(assemble-arity (MakeCompiledProcedure-arity op)) (assemble-arity (MakeCompiledProcedure-arity op))
(string-join (map (string-join (map
@ -31,20 +31,17 @@
(assemble-display-name (MakeCompiledProcedure-display-name op)))] (assemble-display-name (MakeCompiledProcedure-display-name op)))]
[(MakeCompiledProcedureShell? op) [(MakeCompiledProcedureShell? op)
(format "new RUNTIME.Closure(~a, ~a, undefined, ~a)" (format "new RT.Closure(~a, ~a, undefined, ~a)"
(assemble-label (make-Label (MakeCompiledProcedureShell-label op))) (assemble-label (make-Label (MakeCompiledProcedureShell-label op)))
(assemble-arity (MakeCompiledProcedureShell-arity op)) (assemble-arity (MakeCompiledProcedureShell-arity op))
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))] (assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(format "MACHINE.proc(MACHINE)")]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
(format "MACHINE.env.slice(0, MACHINE.env.length - ~a)" (format "M.env.slice(0, M.env.length - ~a)"
(CaptureEnvironment-skip op))] (CaptureEnvironment-skip op))]
[(CaptureControl? op) [(CaptureControl? op)
(format "MACHINE.captureControl(~a, ~a)" (format "M.captureControl(~a, ~a)"
(CaptureControl-skip op) (CaptureControl-skip op)
(let: ([tag : (U DefaultContinuationPromptTag OpArg) (let: ([tag : (U DefaultContinuationPromptTag OpArg)
(CaptureControl-tag op)]) (CaptureControl-tag op)])
@ -55,7 +52,7 @@
[(MakeBoxedEnvironmentValue? op) [(MakeBoxedEnvironmentValue? op)
(format "[MACHINE.env[MACHINE.env.length - 1 - ~a]]" (format "[M.env[M.env.length - 1 - ~a]]"
(MakeBoxedEnvironmentValue-depth op))] (MakeBoxedEnvironmentValue-depth op))]
[(CallKernelPrimitiveProcedure? op) [(CallKernelPrimitiveProcedure? op)

84
js-assembler/assemble-helpers.rkt
View File

@ -74,7 +74,7 @@
(cond (cond
[(PrimitivesReference? target) [(PrimitivesReference? target)
(lambda: ([rhs : String]) (lambda: ([rhs : String])
(format "RUNTIME.Primitives[~s]=RUNTIME.Primitives[~s]||~a;" (format "RT.Primitives[~s]=RT.Primitives[~s]||~a;"
(symbol->string (PrimitivesReference-name target)) (symbol->string (PrimitivesReference-name target))
(symbol->string (PrimitivesReference-name target)) (symbol->string (PrimitivesReference-name target))
rhs))] rhs))]
@ -83,11 +83,11 @@
(format "~a=~a;" (format "~a=~a;"
(cond (cond
[(eq? target 'proc) [(eq? target 'proc)
"MACHINE.proc"] "M.proc"]
[(eq? target 'val) [(eq? target 'val)
"MACHINE.val"] "M.val"]
[(eq? target 'argcount) [(eq? target 'argcount)
"MACHINE.argcount"] "M.argcount"]
[(EnvLexicalReference? target) [(EnvLexicalReference? target)
(assemble-lexical-reference target)] (assemble-lexical-reference target)]
[(EnvPrefixReference? target) [(EnvPrefixReference? target)
@ -95,7 +95,7 @@
[(ControlFrameTemporary? target) [(ControlFrameTemporary? target)
(assemble-control-frame-temporary target)] (assemble-control-frame-temporary target)]
[(ModulePrefixTarget? target) [(ModulePrefixTarget? target)
(format "MACHINE.modules[~s].prefix" (format "M.modules[~s].prefix"
(symbol->string (ModuleLocator-name (ModulePrefixTarget-path target))))]) (symbol->string (ModuleLocator-name (ModulePrefixTarget-path target))))])
rhs))])) rhs))]))
@ -103,7 +103,7 @@
(: assemble-control-frame-temporary (ControlFrameTemporary -> String)) (: assemble-control-frame-temporary (ControlFrameTemporary -> String))
(define (assemble-control-frame-temporary t) (define (assemble-control-frame-temporary t)
(format "MACHINE.control[MACHINE.control.length-1].~a" (format "M.control[M.control.length-1].~a"
(ControlFrameTemporary-name t))) (ControlFrameTemporary-name t)))
;; fixme: use js->string ;; fixme: use js->string
@ -111,38 +111,38 @@
(define (assemble-const stmt) (define (assemble-const stmt)
(let: loop : String ([val : const-value (Const-const stmt)]) (let: loop : String ([val : const-value (Const-const stmt)])
(cond [(symbol? val) (cond [(symbol? val)
(format "RUNTIME.makeSymbol(~s)" (symbol->string val))] (format "RT.makeSymbol(~s)" (symbol->string val))]
[(pair? val) [(pair? val)
(format "RUNTIME.makePair(~a,~a)" (format "RT.makePair(~a,~a)"
(loop (car val)) (loop (car val))
(loop (cdr val)))] (loop (cdr val)))]
[(boolean? val) [(boolean? val)
(if val "true" "false")] (if val "true" "false")]
[(void? val) [(void? val)
"RUNTIME.VOID"] "RT.VOID"]
[(empty? val) [(empty? val)
(format "RUNTIME.NULL")] (format "RT.NULL")]
[(number? val) [(number? val)
(assemble-numeric-constant val)] (assemble-numeric-constant val)]
[(string? val) [(string? val)
(format "~s" val)] (format "~s" val)]
[(char? val) [(char? val)
(format "RUNTIME.makeChar(~s)" (string val))] (format "RT.makeChar(~s)" (string val))]
[(bytes? val) [(bytes? val)
(format "RUNTIME.makeBytes(~a)" (format "RT.makeBytes(~a)"
(string-join (for/list ([a-byte val]) (string-join (for/list ([a-byte val])
(number->string a-byte)) (number->string a-byte))
","))] ","))]
[(path? val) [(path? val)
(format "RUNTIME.makePath(~s)" (format "RT.makePath(~s)"
(path->string val))] (path->string val))]
[(vector? val) [(vector? val)
(format "RUNTIME.makeVector(~a)" (format "RT.makeVector(~a)"
(string-join (for/list ([elt (vector->list val)]) (string-join (for/list ([elt (vector->list val)])
(loop elt)) (loop elt))
","))] ","))]
[(box? val) [(box? val)
(format "RUNTIME.makeBox(~s)" (format "RT.makeBox(~s)"
(loop (unbox val)))]))) (loop (unbox val)))])))
@ -152,9 +152,9 @@
(let loop ([vals vals]) (let loop ([vals vals])
(cond (cond
[(empty? vals) [(empty? vals)
"RUNTIME.NULL"] "RT.NULL"]
[else [else
(format "RUNTIME.makePair(~a,~a)" (first vals) (loop (rest vals)))]))) (format "RT.makePair(~a,~a)" (first vals) (loop (rest vals)))])))
@ -171,15 +171,15 @@
(define (floating-number->js a-num) (define (floating-number->js a-num)
(cond (cond
[(eqv? a-num -0.0) [(eqv? a-num -0.0)
"RUNTIME.NEGATIVE_ZERO"] "RT.NEGATIVE_ZERO"]
[(eqv? a-num +inf.0) [(eqv? a-num +inf.0)
"RUNTIME.INF"] "RT.INF"]
[(eqv? a-num -inf.0) [(eqv? a-num -inf.0)
"RUNTIME.NEGATIVE_INF"] "RT.NEGATIVE_INF"]
[(eqv? a-num +nan.0) [(eqv? a-num +nan.0)
"RUNTIME.NAN"] "RT.NAN"]
[else [else
(string-append "RUNTIME.makeFloat(" (number->string a-num) ")")])) (string-append "RT.makeFloat(" (number->string a-num) ")")]))
;; FIXME: fix the type signature when typed-racket isn't breaking on ;; FIXME: fix the type signature when typed-racket isn't breaking on
;; (define-predicate ExactRational? (U Exact-Rational)) ;; (define-predicate ExactRational? (U Exact-Rational))
@ -188,7 +188,7 @@
(cond [(= (denominator a-num) 1) (cond [(= (denominator a-num) 1)
(string-append (integer->js (ensure-integer (numerator a-num))))] (string-append (integer->js (ensure-integer (numerator a-num))))]
[else [else
(string-append "RUNTIME.makeRational(" (string-append "RT.makeRational("
(integer->js (ensure-integer (numerator a-num))) (integer->js (ensure-integer (numerator a-num)))
"," ","
(integer->js (ensure-integer (denominator a-num))) (integer->js (ensure-integer (denominator a-num)))
@ -211,7 +211,7 @@
(number->string an-int)] (number->string an-int)]
;; overflow case ;; overflow case
[else [else
(string-append "RUNTIME.makeBignum(" (string-append "RT.makeBignum("
(format "~s" (number->string an-int)) (format "~s" (number->string an-int))
")")])) ")")]))
@ -223,7 +223,7 @@
(floating-number->js a-num)] (floating-number->js a-num)]
[(complex? a-num) [(complex? a-num)
(string-append "RUNTIME.makeComplex(" (string-append "RT.makeComplex("
(assemble-numeric-constant (real-part a-num)) (assemble-numeric-constant (real-part a-num))
"," ","
(assemble-numeric-constant (imag-part a-num)) (assemble-numeric-constant (imag-part a-num))
@ -253,26 +253,26 @@
(: assemble-lexical-reference (EnvLexicalReference -> String)) (: assemble-lexical-reference (EnvLexicalReference -> String))
(define (assemble-lexical-reference a-lex-ref) (define (assemble-lexical-reference a-lex-ref)
(if (EnvLexicalReference-unbox? a-lex-ref) (if (EnvLexicalReference-unbox? a-lex-ref)
(format "MACHINE.env[MACHINE.env.length-~a][0]" (format "M.env[M.env.length-~a][0]"
(add1 (EnvLexicalReference-depth a-lex-ref))) (add1 (EnvLexicalReference-depth a-lex-ref)))
(format "MACHINE.env[MACHINE.env.length-~a]" (format "M.env[M.env.length-~a]"
(add1 (EnvLexicalReference-depth a-lex-ref))))) (add1 (EnvLexicalReference-depth a-lex-ref)))))
(: assemble-prefix-reference (EnvPrefixReference -> String)) (: assemble-prefix-reference (EnvPrefixReference -> String))
(define (assemble-prefix-reference a-ref) (define (assemble-prefix-reference a-ref)
(format "MACHINE.env[MACHINE.env.length-~a][~a]" (format "M.env[M.env.length-~a][~a]"
(add1 (EnvPrefixReference-depth a-ref)) (add1 (EnvPrefixReference-depth a-ref))
(EnvPrefixReference-pos a-ref))) (EnvPrefixReference-pos a-ref)))
(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String)) (: assemble-whole-prefix-reference (EnvWholePrefixReference -> String))
(define (assemble-whole-prefix-reference a-prefix-ref) (define (assemble-whole-prefix-reference a-prefix-ref)
(format "MACHINE.env[MACHINE.env.length-~a]" (format "M.env[M.env.length-~a]"
(add1 (EnvWholePrefixReference-depth a-prefix-ref)))) (add1 (EnvWholePrefixReference-depth a-prefix-ref))))
(: assemble-reg (Reg -> String)) (: assemble-reg (Reg -> String))
(define (assemble-reg a-reg) (define (assemble-reg a-reg)
(string-append "MACHINE." (symbol->string (Reg-name a-reg)))) (string-append "M." (symbol->string (Reg-name a-reg))))
@ -302,12 +302,12 @@
(: assemble-control-stack-label (ControlStackLabel -> String)) (: assemble-control-stack-label (ControlStackLabel -> String))
(define (assemble-control-stack-label a-csl) (define (assemble-control-stack-label a-csl)
"MACHINE.control[MACHINE.control.length-1].label") "M.control[M.control.length-1].label")
(: assemble-control-stack-label/multiple-value-return (ControlStackLabel/MultipleValueReturn -> String)) (: assemble-control-stack-label/multiple-value-return (ControlStackLabel/MultipleValueReturn -> String))
(define (assemble-control-stack-label/multiple-value-return a-csl) (define (assemble-control-stack-label/multiple-value-return a-csl)
"MACHINE.control[MACHINE.control.length-1].label.multipleValueReturn") "M.control[M.control.length-1].label.multipleValueReturn")
@ -328,7 +328,7 @@
(: assemble-default-continuation-prompt-tag (-> String)) (: assemble-default-continuation-prompt-tag (-> String))
(define (assemble-default-continuation-prompt-tag) (define (assemble-default-continuation-prompt-tag)
"RUNTIME.DEFAULT_CONTINUATION_PROMPT_TAG") "RT.DEFAULT_CONTINUATION_PROMPT_TAG")
@ -337,7 +337,7 @@
;; lexical references: they must remain boxes. So all we need is ;; lexical references: they must remain boxes. So all we need is
;; the depth into the environment. ;; the depth into the environment.
(define (assemble-env-reference/closure-capture depth) (define (assemble-env-reference/closure-capture depth)
(format "MACHINE.env[MACHINE.env.length - ~a]" (format "M.env[M.env.length - ~a]"
(add1 depth))) (add1 depth)))
@ -350,7 +350,7 @@
[(natural? an-arity) [(natural? an-arity)
(number->string an-arity)] (number->string an-arity)]
[(ArityAtLeast? an-arity) [(ArityAtLeast? an-arity)
(format "(RUNTIME.makeArityAtLeast(~a))" (format "(RT.makeArityAtLeast(~a))"
(ArityAtLeast-value an-arity))] (ArityAtLeast-value an-arity))]
[(listof-atomic-arity? an-arity) [(listof-atomic-arity? an-arity)
(assemble-listof-assembled-values (assemble-listof-assembled-values
@ -360,7 +360,7 @@
[(natural? atomic-arity) [(natural? atomic-arity)
(number->string atomic-arity)] (number->string atomic-arity)]
[(ArityAtLeast? atomic-arity) [(ArityAtLeast? atomic-arity)
(format "(RUNTIME.makeArityAtLeast(~a))" (format "(RT.makeArityAtLeast(~a))"
(ArityAtLeast-value atomic-arity))])) (ArityAtLeast-value atomic-arity))]))
an-arity))])) an-arity))]))
@ -370,7 +370,7 @@
(: assemble-jump (OpArg -> String)) (: assemble-jump (OpArg -> String))
(define (assemble-jump target) (define (assemble-jump target)
(format "return(~a)(MACHINE);" (assemble-oparg target))) (format "return(~a)(M);" (assemble-oparg target)))
@ -399,25 +399,25 @@
(: assemble-primitive-kernel-value (PrimitiveKernelValue -> String)) (: assemble-primitive-kernel-value (PrimitiveKernelValue -> String))
(define (assemble-primitive-kernel-value a-prim) (define (assemble-primitive-kernel-value a-prim)
(format "MACHINE.primitives[~s]" (symbol->string (PrimitiveKernelValue-id a-prim)))) (format "M.primitives[~s]" (symbol->string (PrimitiveKernelValue-id a-prim))))
(: assemble-module-entry (ModuleEntry -> String)) (: assemble-module-entry (ModuleEntry -> String))
(define (assemble-module-entry entry) (define (assemble-module-entry entry)
(format "MACHINE.modules[~s].label" (format "M.modules[~s].label"
(symbol->string (ModuleLocator-name (ModuleEntry-name entry))))) (symbol->string (ModuleLocator-name (ModuleEntry-name entry)))))
(: assemble-is-module-invoked (IsModuleInvoked -> String)) (: assemble-is-module-invoked (IsModuleInvoked -> String))
(define (assemble-is-module-invoked entry) (define (assemble-is-module-invoked entry)
(format "MACHINE.modules[~s].isInvoked" (format "M.modules[~s].isInvoked"
(symbol->string (ModuleLocator-name (IsModuleInvoked-name entry))))) (symbol->string (ModuleLocator-name (IsModuleInvoked-name entry)))))
(: assemble-is-module-linked (IsModuleLinked -> String)) (: assemble-is-module-linked (IsModuleLinked -> String))
(define (assemble-is-module-linked entry) (define (assemble-is-module-linked entry)
(format "(MACHINE.modules[~s]!==undefined)" (format "(M.modules[~s]!==undefined)"
(symbol->string (ModuleLocator-name (IsModuleLinked-name entry))))) (symbol->string (ModuleLocator-name (IsModuleLinked-name entry)))))
@ -425,6 +425,6 @@
(: assemble-variable-reference (VariableReference -> String)) (: assemble-variable-reference (VariableReference -> String))
(define (assemble-variable-reference varref) (define (assemble-variable-reference varref)
(let ([t (VariableReference-toplevel varref)]) (let ([t (VariableReference-toplevel varref)])
(format "(new RUNTIME.VariableReference(MACHINE.env[MACHINE.env.length-~a],~a))" (format "(new RT.VariableReference(M.env[M.env.length-~a],~a))"
(add1 (ToplevelRef-depth t)) (add1 (ToplevelRef-depth t))
(ToplevelRef-pos t)))) (ToplevelRef-pos t))))

24
js-assembler/assemble-open-coded.rkt
View File

@ -70,7 +70,7 @@
(assemble-boolean-chain "plt.baselib.numbers.greaterThanOrEqual" checked-operands)] (assemble-boolean-chain "plt.baselib.numbers.greaterThanOrEqual" checked-operands)]
[(cons) [(cons)
(format "RUNTIME.makePair(~a, ~a)" (format "RT.makePair(~a,~a)"
(first checked-operands) (first checked-operands)
(second checked-operands))] (second checked-operands))]
@ -85,21 +85,21 @@
(assemble-listof-assembled-values checked-operands))] (assemble-listof-assembled-values checked-operands))]
[(list?) [(list?)
(format "RUNTIME.isList(~a)" (format "RT.isList(~a)"
(first checked-operands))] (first checked-operands))]
[(pair?) [(pair?)
(format "RUNTIME.isPair(~a)" (format "RT.isPair(~a)"
(first checked-operands))] (first checked-operands))]
[(null?) [(null?)
(format "(~a === RUNTIME.NULL)" (first checked-operands))] (format "(~a===RT.NULL)" (first checked-operands))]
[(not) [(not)
(format "(~a === false)" (first checked-operands))] (format "(~a===false)" (first checked-operands))]
[(eq?) [(eq?)
(format "(~a === ~a)" (first checked-operands) (second checked-operands))]))) (format "(~a===~a)" (first checked-operands) (second checked-operands))])))
@ -154,16 +154,16 @@
(let: ([predicate : String (let: ([predicate : String
(case domain (case domain
[(number) [(number)
(format "RUNTIME.isNumber")] (format "RT.isNumber")]
[(string) [(string)
(format "RUNTIME.isString")] (format "RT.isString")]
[(list) [(list)
(format "RUNTIME.isList")] (format "RT.isList")]
[(pair) [(pair)
(format "RUNTIME.isPair")] (format "RT.isPair")]
[(box) [(box)
(format "RUNTIME.isBox")])]) (format "RT.isBox")])])
(format "RUNTIME.testArgument(MACHINE, ~s, ~a, ~a, ~a, ~s)" (format "RT.testArgument(M,~s,~a,~a,~a,~s)"
(symbol->string domain) (symbol->string domain)
predicate predicate
operand-string operand-string

62
js-assembler/assemble-perform-statement.rkt
View File

@ -14,39 +14,31 @@
(cond (cond
[(CheckToplevelBound!? op) [(CheckToplevelBound!? op)
(format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { RUNTIME.raiseUnboundToplevelError(MACHINE.env[MACHINE.env.length - 1 - ~a].names[~a]); }" (format "if (M.env[M.env.length - 1 - ~a][~a] === undefined) { RT.raiseUnboundToplevelError(M.env[M.env.length - 1 - ~a].names[~a]); }"
(CheckToplevelBound!-depth op) (CheckToplevelBound!-depth op)
(CheckToplevelBound!-pos op) (CheckToplevelBound!-pos op)
(CheckToplevelBound!-depth op) (CheckToplevelBound!-depth op)
(CheckToplevelBound!-pos op))] (CheckToplevelBound!-pos op))]
[(CheckClosureArity!? op) [(CheckClosureAndArity!? op)
(format "if(!(MACHINE.proc instanceof RUNTIME.Closure)){RUNTIME.raiseOperatorIsNotClosure(MACHINE,MACHINE.proc);}if(!RUNTIME.isArityMatching(MACHINE.proc.racketArity,~a)){RUNTIME.raiseArityMismatchError(MACHINE, MACHINE.proc,~a);}" (format "RT.checkClosureAndArity(M, ~a);"
(assemble-oparg (CheckClosureArity!-num-args op)) (assemble-oparg (CheckClosureAndArity!-num-args op)))]
(assemble-oparg (CheckClosureArity!-num-args op)))]
[(CheckPrimitiveArity!? op)
(format "if(!RUNTIME.isArityMatching(MACHINE.proc.racketArity,~a)){RUNTIME.raiseArityMismatchError(MACHINE,MACHINE.proc,~a);}"
(assemble-oparg (CheckPrimitiveArity!-num-args op))
(assemble-oparg (CheckPrimitiveArity!-num-args op)))]
[(ExtendEnvironment/Prefix!? op) [(ExtendEnvironment/Prefix!? op)
(let: ([names : (Listof (U Symbol False GlobalBucket ModuleVariable)) (ExtendEnvironment/Prefix!-names 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];" (format "M.env.push([~a]);M.env[M.env.length-1].names=[~a];"
(string-join (map (string-join (map
(lambda: ([n : (U Symbol False GlobalBucket ModuleVariable)]) (lambda: ([n : (U Symbol False GlobalBucket ModuleVariable)])
(cond [(symbol? n) (cond [(symbol? n)
(format "MACHINE.params.currentNamespace[~s] || MACHINE.primitives[~s]" (format "M.params.currentNamespace[~s] || M.primitives[~s]"
(symbol->string n) (symbol->string n)
(symbol->string n))] (symbol->string n))]
[(eq? n #f) [(eq? n #f)
"false"] "false"]
[(GlobalBucket? n) [(GlobalBucket? n)
;; FIXME: maybe we should keep a set of global variables here? ;; FIXME: maybe we should keep a set of global variables here?
(format "MACHINE.primitives[~s]" (format "M.primitives[~s]"
(symbol->string (GlobalBucket-name n)))] (symbol->string (GlobalBucket-name n)))]
;; FIXME: this should be looking at the module path and getting ;; FIXME: this should be looking at the module path and getting
;; the value here! It shouldn't be looking into Primitives... ;; the value here! It shouldn't be looking into Primitives...
@ -54,10 +46,10 @@
(cond (cond
[((current-kernel-module-locator?) [((current-kernel-module-locator?)
(ModuleVariable-module-name n)) (ModuleVariable-module-name n))
(format "MACHINE.primitives[~s]" (format "M.primitives[~s]"
(symbol->string (ModuleVariable-name n)))] (symbol->string (ModuleVariable-name n)))]
[else [else
(format "MACHINE.modules[~s].namespace[~s]" (format "M.modules[~s].namespace[~s]"
(symbol->string (symbol->string
(ModuleLocator-name (ModuleLocator-name
(ModuleVariable-module-name n))) (ModuleVariable-module-name n)))
@ -79,13 +71,13 @@
",")))] ",")))]
[(InstallClosureValues!? op) [(InstallClosureValues!? op)
"MACHINE.env.splice.apply(MACHINE.env,[MACHINE.env.length, 0].concat(MACHINE.proc.closedVals));"] "M.env.push.apply(M.env,M.proc.closedVals);"]
[(RestoreEnvironment!? op) [(RestoreEnvironment!? op)
"MACHINE.env=MACHINE.env[MACHINE.env.length-2].slice(0);"] "M.env=M.env[M.env.length-2].slice(0);"]
[(RestoreControl!? op) [(RestoreControl!? op)
(format "MACHINE.restoreControl(~a);" (format "M.restoreControl(~a);"
(let: ([tag : (U DefaultContinuationPromptTag OpArg) (let: ([tag : (U DefaultContinuationPromptTag OpArg)
(RestoreControl!-tag op)]) (RestoreControl!-tag op)])
(cond (cond
@ -95,7 +87,7 @@
(assemble-oparg tag)])))] (assemble-oparg tag)])))]
[(FixClosureShellMap!? op) [(FixClosureShellMap!? op)
(format "MACHINE.env[MACHINE.env.length-~a].closedVals=[~a];" (format "M.env[M.env.length-~a].closedVals=[~a];"
(add1 (FixClosureShellMap!-depth op)) (add1 (FixClosureShellMap!-depth op))
(string-join (map (string-join (map
assemble-env-reference/closure-capture assemble-env-reference/closure-capture
@ -107,60 +99,60 @@
","))] ","))]
[(SetFrameCallee!? op) [(SetFrameCallee!? op)
(format "MACHINE.control[MACHINE.control.length-1].proc = ~a;" (format "M.control[M.control.length-1].proc = ~a;"
(assemble-oparg (SetFrameCallee!-proc op)))] (assemble-oparg (SetFrameCallee!-proc op)))]
[(SpliceListIntoStack!? op) [(SpliceListIntoStack!? op)
(format "MACHINE.spliceListIntoStack(~a);" (format "M.spliceListIntoStack(~a);"
(assemble-oparg (SpliceListIntoStack!-depth op)))] (assemble-oparg (SpliceListIntoStack!-depth op)))]
[(UnspliceRestFromStack!? op) [(UnspliceRestFromStack!? op)
(format "MACHINE.unspliceRestFromStack(~a,~a);" (format "M.unspliceRestFromStack(~a,~a);"
(assemble-oparg (UnspliceRestFromStack!-depth op)) (assemble-oparg (UnspliceRestFromStack!-depth op))
(assemble-oparg (UnspliceRestFromStack!-length op)))] (assemble-oparg (UnspliceRestFromStack!-length op)))]
[(InstallContinuationMarkEntry!? op) [(InstallContinuationMarkEntry!? op)
(string-append "MACHINE.installContinuationMarkEntry(" (string-append "M.installContinuationMarkEntry("
"MACHINE.control[MACHINE.control.length-1].pendingContinuationMarkKey," "M.control[M.control.length-1].pendingContinuationMarkKey,"
"MACHINE.val);")] "M.val);")]
[(RaiseContextExpectedValuesError!? op) [(RaiseContextExpectedValuesError!? op)
(format "RUNTIME.raiseContextExpectedValuesError(MACHINE,~a);" (format "RT.raiseContextExpectedValuesError(M,~a);"
(RaiseContextExpectedValuesError!-expected op))] (RaiseContextExpectedValuesError!-expected op))]
[(RaiseArityMismatchError!? op) [(RaiseArityMismatchError!? op)
(format "RUNTIME.raiseArityMismatchError(MACHINE,~a,~a);" (format "RT.raiseArityMismatchError(M,~a,~a);"
(assemble-oparg (RaiseArityMismatchError!-proc op)) (assemble-oparg (RaiseArityMismatchError!-proc op))
(assemble-oparg (RaiseArityMismatchError!-received op)))] (assemble-oparg (RaiseArityMismatchError!-received op)))]
[(RaiseOperatorApplicationError!? op) [(RaiseOperatorApplicationError!? op)
(format "RUNTIME.raiseOperatorApplicationError(MACHINE,~a);" (format "RT.raiseOperatorApplicationError(M,~a);"
(assemble-oparg (RaiseOperatorApplicationError!-operator op)))] (assemble-oparg (RaiseOperatorApplicationError!-operator op)))]
[(RaiseUnimplementedPrimitiveError!? op) [(RaiseUnimplementedPrimitiveError!? op)
(format "RUNTIME.raiseUnimplementedPrimitiveError(MACHINE,~s);" (format "RT.raiseUnimplementedPrimitiveError(M,~s);"
(symbol->string (RaiseUnimplementedPrimitiveError!-name op)))] (symbol->string (RaiseUnimplementedPrimitiveError!-name op)))]
[(InstallModuleEntry!? op) [(InstallModuleEntry!? op)
(format "MACHINE.modules[~s]=new RUNTIME.ModuleRecord(~s,~a);" (format "M.modules[~s]=new RT.ModuleRecord(~s,~a);"
(symbol->string (ModuleLocator-name (InstallModuleEntry!-path op))) (symbol->string (ModuleLocator-name (InstallModuleEntry!-path op)))
(symbol->string (InstallModuleEntry!-name op)) (symbol->string (InstallModuleEntry!-name op))
(assemble-label (make-Label (InstallModuleEntry!-entry-point op))))] (assemble-label (make-Label (InstallModuleEntry!-entry-point op))))]
[(MarkModuleInvoked!? op) [(MarkModuleInvoked!? op)
(format "MACHINE.modules[~s].isInvoked=true;" (format "M.modules[~s].isInvoked=true;"
(symbol->string (ModuleLocator-name (MarkModuleInvoked!-path op))))] (symbol->string (ModuleLocator-name (MarkModuleInvoked!-path op))))]
[(AliasModuleAsMain!? op) [(AliasModuleAsMain!? op)
(format "MACHINE.mainModules.push(MACHINE.modules[~s]);" (format "M.mainModules.push(M.modules[~s]);"
(symbol->string (ModuleLocator-name (AliasModuleAsMain!-from op))))] (symbol->string (ModuleLocator-name (AliasModuleAsMain!-from op))))]
[(FinalizeModuleInvokation!? op) [(FinalizeModuleInvokation!? op)
(format "MACHINE.modules[~s].finalizeModuleInvokation();" (format "M.modules[~s].finalizeModuleInvokation();"
(symbol->string (symbol->string
(ModuleLocator-name (FinalizeModuleInvokation!-path op))))])) (ModuleLocator-name (FinalizeModuleInvokation!-path op))))]))

120
js-assembler/assemble.rkt
View File

@ -14,7 +14,8 @@
"../sets.rkt" "../sets.rkt"
"../helpers.rkt" "../helpers.rkt"
racket/string racket/string
racket/list) racket/list
racket/match)
(require/typed "../logger.rkt" (require/typed "../logger.rkt"
[log-debug (String -> Void)]) [log-debug (String -> Void)])
@ -39,34 +40,40 @@
;; What's emitted is a function expression that, when invoked, runs the ;; What's emitted is a function expression that, when invoked, runs the
;; statements. ;; statements.
(define (assemble/write-invoke stmts op) (define (assemble/write-invoke stmts op)
(display "(function(MACHINE, success, fail, params) {\n" op) (display "(function(M, success, fail, params) {\n" op)
(display "var param;\n" op) (display "var param;\n" op)
(display "var RUNTIME = plt.runtime;\n" op) (display "var RT = plt.runtime;\n" op)
(define-values (basic-blocks entry-points) (fracture stmts)) (define-values (basic-blocks entry-points) (fracture stmts))
(write-blocks basic-blocks (list->set entry-points) op) (define function-entry-and-exit-names
(list->set (get-function-entry-and-exit-names stmts)))
(write-blocks basic-blocks
(list->set entry-points)
function-entry-and-exit-names
op)
(write-linked-label-attributes stmts op) (write-linked-label-attributes stmts op)
(display "MACHINE.params.currentErrorHandler = fail;\n" op) (display "M.params.currentErrorHandler = fail;\n" op)
(display "MACHINE.params.currentSuccessHandler = success;\n" op) (display "M.params.currentSuccessHandler = success;\n" op)
(display #<<EOF (display #<<EOF
for (param in params) { for (param in params) {
if (params.hasOwnProperty(param)) { if (params.hasOwnProperty(param)) {
MACHINE.params[param] = params[param]; M.params[param] = params[param];
} }
} }
EOF EOF
op) op)
(fprintf op "MACHINE.trampoline(~a); })" (fprintf op "M.trampoline(~a); })"
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))))) (assemble-label (make-Label (BasicBlock-name (first basic-blocks))))))
(: write-blocks ((Listof BasicBlock) (Setof Symbol) Output-Port -> Void)) (: write-blocks ((Listof BasicBlock) (Setof Symbol) (Setof Symbol) Output-Port -> Void))
;; Write out all the basic blocks associated to an entry point. ;; Write out all the basic blocks associated to an entry point.
(define (write-blocks blocks entry-points op) (define (write-blocks blocks entry-points function-entry-and-exit-names op)
(: blockht : Blockht) (: blockht : Blockht)
(define blockht (make-hash)) (define blockht (make-hash))
@ -82,6 +89,7 @@ EOF
(assemble-basic-block (hash-ref blockht s) (assemble-basic-block (hash-ref blockht s)
blockht blockht
entry-points entry-points
function-entry-and-exit-names
op) op)
(newline op)) (newline op))
entry-points)) entry-points))
@ -169,11 +177,30 @@ EOF
(: assemble-basic-block (BasicBlock Blockht (Setof Symbol) Output-Port -> 'ok)) (: assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok))
(define (assemble-basic-block a-basic-block blockht entry-points op) (define (assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)
(fprintf op "var ~a = function(MACHINE) { if(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n" (match (BasicBlock-stmts a-basic-block)
(assemble-label (make-Label (BasicBlock-name a-basic-block))) [(list (struct PerformStatement ((struct RaiseContextExpectedValuesError! (expected))))
(assemble-label (make-Label (BasicBlock-name a-basic-block)))) stmts ...)
(fprintf op "~a=RT.si_context_expected(~a);\n"
(assemble-label (make-Label (BasicBlock-name a-basic-block)))
expected)
'ok]
[else
(default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
(: default-assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok))
(define (default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)
(cond
[(set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
(fprintf op "var ~a=function(M){if(--M.cbt<0){throw ~a;}\n"
(assemble-label (make-Label (BasicBlock-name a-basic-block)))
(assemble-label (make-Label (BasicBlock-name a-basic-block))))]
[else
(fprintf op "var ~a=function(M){--M.cbt<0;\n"
(assemble-label (make-Label (BasicBlock-name a-basic-block))))])
(assemble-block-statements (BasicBlock-name a-basic-block) (assemble-block-statements (BasicBlock-name a-basic-block)
(BasicBlock-stmts a-basic-block) (BasicBlock-stmts a-basic-block)
blockht blockht
@ -184,6 +211,7 @@ EOF
(: assemble-block-statements (Symbol (Listof UnlabeledStatement) Blockht (Setof Symbol) Output-Port -> 'ok)) (: assemble-block-statements (Symbol (Listof UnlabeledStatement) Blockht (Setof Symbol) Output-Port -> 'ok))
(define (assemble-block-statements name stmts blockht entry-points op) (define (assemble-block-statements name stmts blockht entry-points op)
@ -236,12 +264,12 @@ EOF
(format "if(~a===0)" (format "if(~a===0)"
(assemble-oparg (TestZero-operand test)))] (assemble-oparg (TestZero-operand test)))]
[(TestPrimitiveProcedure? test) ;; [(TestPrimitiveProcedure? test)
(format "if(typeof(~a)==='function')" ;; (format "if(typeof(~a)==='function')"
(assemble-oparg (TestPrimitiveProcedure-operand test)))] ;; (assemble-oparg (TestPrimitiveProcedure-operand test)))]
[(TestClosureArityMismatch? test) [(TestClosureArityMismatch? test)
(format "if(!RUNTIME.isArityMatching((~a).racketArity,~a))" (format "if(!RT.isArityMatching((~a).racketArity,~a))"
(assemble-oparg (TestClosureArityMismatch-closure test)) (assemble-oparg (TestClosureArityMismatch-closure test))
(assemble-oparg (TestClosureArityMismatch-n test)))])) (assemble-oparg (TestClosureArityMismatch-n test)))]))
(display test-code op) (display test-code op)
@ -399,7 +427,7 @@ EOF
(define assembled (define assembled
(cond (cond
[(DebugPrint? stmt) [(DebugPrint? stmt)
(format "MACHINE.params.currentOutputPort.writeDomNode(MACHINE, $('<span/>').text(~a));" (format "M.params.currentOutputPort.writeDomNode(M, $('<span/>').text(~a));"
(assemble-oparg (DebugPrint-value stmt)))] (assemble-oparg (DebugPrint-value stmt)))]
[(AssignImmediateStatement? stmt) [(AssignImmediateStatement? stmt)
(let: ([t : (String -> String) (assemble-target (AssignImmediateStatement-target stmt))] (let: ([t : (String -> String) (assemble-target (AssignImmediateStatement-target stmt))]
@ -435,12 +463,8 @@ EOF
(format "if(~a===0){~a}" (format "if(~a===0){~a}"
(assemble-oparg (TestZero-operand test)) (assemble-oparg (TestZero-operand test))
jump)] jump)]
[(TestPrimitiveProcedure? test)
(format "if(typeof(~a)==='function'){~a}"
(assemble-oparg (TestPrimitiveProcedure-operand test))
jump)]
[(TestClosureArityMismatch? test) [(TestClosureArityMismatch? test)
(format "if(!RUNTIME.isArityMatching((~a).racketArity,~a)){~a}" (format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
(assemble-oparg (TestClosureArityMismatch-closure test)) (assemble-oparg (TestClosureArityMismatch-closure test))
(assemble-oparg (TestClosureArityMismatch-n test)) (assemble-oparg (TestClosureArityMismatch-n test))
jump)]) jump)])
@ -450,10 +474,10 @@ EOF
(assemble-jump (GotoStatement-target stmt))] (assemble-jump (GotoStatement-target stmt))]
[(PushControlFrame/Generic? stmt) [(PushControlFrame/Generic? stmt)
"MACHINE.control.push(new RUNTIME.Frame());"] "M.control.push(new RT.Frame());"]
[(PushControlFrame/Call? stmt) [(PushControlFrame/Call? stmt)
(format "MACHINE.control.push(new RUNTIME.CallFrame(~a,MACHINE.proc));" (format "M.control.push(new RT.CallFrame(~a,M.proc));"
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)]) (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
(cond (cond
[(symbol? label) [(symbol? label)
@ -463,7 +487,7 @@ EOF
[(PushControlFrame/Prompt? stmt) [(PushControlFrame/Prompt? stmt)
;; fixme: use a different frame structure ;; fixme: use a different frame structure
(format "MACHINE.control.push(new RUNTIME.PromptFrame(~a,~a));" (format "M.control.push(new RT.PromptFrame(~a,~a));"
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)]) (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
(cond (cond
[(symbol? label) [(symbol? label)
@ -480,12 +504,12 @@ EOF
(assemble-oparg tag)])))] (assemble-oparg tag)])))]
[(PopControlFrame? stmt) [(PopControlFrame? stmt)
"MACHINE.control.pop();"] "M.control.pop();"]
[(PushEnvironment? stmt) [(PushEnvironment? stmt)
(if (= (PushEnvironment-n stmt) 0) (if (= (PushEnvironment-n stmt) 0)
"" ""
(format "MACHINE.env.push(~a);" (string-join (format "M.env.push(~a);" (string-join
(build-list (PushEnvironment-n stmt) (build-list (PushEnvironment-n stmt)
(lambda: ([i : Natural]) (lambda: ([i : Natural])
(if (PushEnvironment-unbox? stmt) (if (PushEnvironment-unbox? stmt)
@ -496,16 +520,16 @@ EOF
(let: ([skip : OpArg (PopEnvironment-skip stmt)]) (let: ([skip : OpArg (PopEnvironment-skip stmt)])
(cond (cond
[(and (Const? skip) (= (ensure-natural (Const-const skip)) 0)) [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
(format "MACHINE.env.length-=~a;" (format "M.env.length-=~a;"
(assemble-oparg (PopEnvironment-n stmt)))] (assemble-oparg (PopEnvironment-n stmt)))]
[else [else
(format "MACHINE.env.splice(MACHINE.env.length-(~a +~a),~a);" (format "M.env.splice(M.env.length-(~a +~a),~a);"
(assemble-oparg (PopEnvironment-skip stmt)) (assemble-oparg (PopEnvironment-skip stmt))
(assemble-oparg (PopEnvironment-n stmt)) (assemble-oparg (PopEnvironment-n stmt))
(assemble-oparg (PopEnvironment-n stmt)))]))] (assemble-oparg (PopEnvironment-n stmt)))]))]
[(PushImmediateOntoEnvironment? stmt) [(PushImmediateOntoEnvironment? stmt)
(format "MACHINE.env.push(~a);" (format "M.env.push(~a);"
(let: ([val-string : String (let: ([val-string : String
(cond [(PushImmediateOntoEnvironment-box? stmt) (cond [(PushImmediateOntoEnvironment-box? stmt)
(format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)))] (format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)))]
@ -532,3 +556,31 @@ EOF
(if (natural? n) (if (natural? n)
n n
(error 'ensure-natural))) (error 'ensure-natural)))
(: get-function-entry-and-exit-names ((Listof Statement) -> (Listof Symbol)))
(define (get-function-entry-and-exit-names stmts)
(cond
[(empty? stmts)
'()]
[else
(define first-stmt (first stmts))
(cond
[(LinkedLabel? first-stmt)
(cons (LinkedLabel-label first-stmt)
(cons (LinkedLabel-linked-to first-stmt)
(get-function-entry-and-exit-names (rest stmts))))]
[(AssignPrimOpStatement? first-stmt)
(define op (AssignPrimOpStatement-op first-stmt))
(cond
[(MakeCompiledProcedure? op)
(cons (MakeCompiledProcedure-label op)
(get-function-entry-and-exit-names (rest stmts)))]
[(MakeCompiledProcedureShell? first-stmt)
(cons (MakeCompiledProcedureShell-label op)
(get-function-entry-and-exit-names (rest stmts)))]
[else
(get-function-entry-and-exit-names (rest stmts))])]
[else
(get-function-entry-and-exit-names (rest stmts))])]))

10
js-assembler/collect-jump-targets.rkt
View File

@ -112,8 +112,8 @@
(list (MakeCompiledProcedure-label op))] (list (MakeCompiledProcedure-label op))]
[(MakeCompiledProcedureShell? op) [(MakeCompiledProcedureShell? op)
(list (MakeCompiledProcedureShell-label op))] (list (MakeCompiledProcedureShell-label op))]
[(ApplyPrimitiveProcedure? op) ;; [(ApplyPrimitiveProcedure? op)
empty] ;; empty]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
empty] empty]
[(CaptureControl? op) [(CaptureControl? op)
@ -258,8 +258,8 @@
(list (MakeCompiledProcedure-label op))] (list (MakeCompiledProcedure-label op))]
[(MakeCompiledProcedureShell? op) [(MakeCompiledProcedureShell? op)
(list (MakeCompiledProcedureShell-label op))] (list (MakeCompiledProcedureShell-label op))]
[(ApplyPrimitiveProcedure? op) ;; [(ApplyPrimitiveProcedure? op)
empty] ;; empty]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
empty] empty]
[(CaptureControl? op) [(CaptureControl? op)
@ -279,7 +279,7 @@
;; currently written this way because I'm hitting some bad type-checking behavior. ;; currently written this way because I'm hitting some bad type-checking behavior.
#;([(CheckToplevelBound!? op) #;([(CheckToplevelBound!? op)
empty] empty]
[(CheckClosureArity!? op) [(CheckClosureAndArity!? op)
empty] empty]
[(CheckPrimitiveArity!? op) [(CheckPrimitiveArity!? op)
empty] empty]

60
js-assembler/package.rkt
View File

@ -19,10 +19,12 @@
racket/port racket/port
(prefix-in query: "../lang/js/query.rkt") (prefix-in query: "../lang/js/query.rkt")
(prefix-in resource-query: "../resource/query.rkt") (prefix-in resource-query: "../resource/query.rkt")
(planet dyoo/closure-compile:1:1)
(prefix-in runtime: "get-runtime.rkt") (prefix-in runtime: "get-runtime.rkt")
(prefix-in racket: racket/base)) (prefix-in racket: racket/base))
;; There is a dynamic require for (planet dyoo/closure-compile) that's done
;; if compression is turned on.
;; TODO: put proper contracts here ;; TODO: put proper contracts here
@ -155,23 +157,23 @@
module-requires)) module-requires))
(let ([module-body-text (let ([module-body-text
(format " (format "
if(--MACHINE.callsBeforeTrampoline<0) { throw arguments.callee; } if(--M.cbt<0) { throw arguments.callee; }
var modrec = MACHINE.modules[~s]; var modrec = M.modules[~s];
var exports = {}; var exports = {};
modrec.isInvoked = true; modrec.isInvoked = true;
(function(MACHINE, RUNTIME, EXPORTS){~a})(MACHINE, plt.runtime, exports); (function(MACHINE, EXPORTS){~a})(M, exports);
~a ~a
modrec.privateExports = exports; modrec.privateExports = exports;
return MACHINE.control.pop().label(MACHINE);" return M.control.pop().label(M);"
(symbol->string name) (symbol->string name)
text text
(get-provided-name-code bytecode))]) (get-provided-name-code bytecode))])
(make-UninterpretedSource (make-UninterpretedSource
(format " (format "
MACHINE.modules[~s] = M.modules[~s] =
new plt.runtime.ModuleRecord(~s, new plt.runtime.ModuleRecord(~s,
function(MACHINE) { function(M) {
~a ~a
}); });
" "
@ -204,10 +206,10 @@ MACHINE.modules[~s] =
(let ([name (rewrite-path (path->string path))] (let ([name (rewrite-path (path->string path))]
[afterName (gensym 'afterName)]) [afterName (gensym 'afterName)])
(format "var ~a = function() { ~a }; (format "var ~a = function() { ~a };
if (! MACHINE.modules[~s].isInvoked) { if (! M.modules[~s].isInvoked) {
MACHINE.modules[~s].internalInvoke(MACHINE, M.modules[~s].internalInvoke(M,
~a, ~a,
MACHINE.params.currentErrorHandler); M.params.currentErrorHandler);
} else { } else {
~a(); ~a();
}" }"
@ -229,7 +231,7 @@ MACHINE.modules[~s] =
;; following module paths of a source's dependencies. ;; following module paths of a source's dependencies.
;; ;;
;; The generated output defines a function called 'invoke' with ;; The generated output defines a function called 'invoke' with
;; four arguments (MACHINE, SUCCESS, FAIL, PARAMS). When called, it will ;; four arguments (M, SUCCESS, FAIL, PARAMS). When called, it will
;; execute the code to either run standalone expressions or ;; execute the code to either run standalone expressions or
;; load in modules. ;; load in modules.
(define (package source-code (define (package source-code
@ -265,7 +267,7 @@ MACHINE.modules[~s] =
plt.runtime.setReadyFalse(); plt.runtime.setReadyFalse();
(") (")
(assemble/write-invoke stmts op) (assemble/write-invoke stmts op)
(fprintf op ")(MACHINE, (fprintf op ")(M,
function() { function() {
if (window.console && window.console.log) { if (window.console && window.console.log) {
window.console.log('loaded ' + ~s); window.console.log('loaded ' + ~s);
@ -308,7 +310,7 @@ MACHINE.modules[~s] =
;; last ;; last
on-last-src)) on-last-src))
(fprintf op "var invoke = (function(MACHINE, SUCCESS, FAIL, PARAMS) {") (fprintf op "var invoke = (function(M, SUCCESS, FAIL, PARAMS) {")
(fprintf op " plt.runtime.ready(function() {") (fprintf op " plt.runtime.ready(function() {")
(fprintf op " plt.runtime.setReadyFalse();") (fprintf op " plt.runtime.setReadyFalse();")
(make (list (make-MainModuleSource source-code)) (make (list (make-MainModuleSource source-code))
@ -347,7 +349,7 @@ MACHINE.modules[~s] =
;; on ;; on
(lambda (src ast stmts) (lambda (src ast stmts)
(assemble/write-invoke stmts op) (assemble/write-invoke stmts op)
(fprintf op "(MACHINE, function() { ")) (fprintf op "(M, function() { "))
;; after ;; after
(lambda (src) (lambda (src)
@ -360,16 +362,18 @@ MACHINE.modules[~s] =
(display (runtime:get-runtime) op) (display (runtime:get-runtime) op)
(newline op) (newline op)
(fprintf op "(function(MACHINE, SUCCESS, FAIL, PARAMS) {") (fprintf op "(function(M, SUCCESS, FAIL, PARAMS) {")
(make (list only-bootstrapped-code) packaging-configuration) (make (list only-bootstrapped-code) packaging-configuration)
(fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n"))) (fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n")))
(define closure-compile-ns (make-base-namespace))
(define (compress x) (define (compress x)
(cond [(current-compress-javascript?) (cond [(current-compress-javascript?)
(log-debug "compressing javascript...") (log-debug "compressing javascript...")
(closure-compile x)] (parameterize ([current-namespace closure-compile-ns])
(define closure-compile (dynamic-require '(planet dyoo/closure-compile) 'closure-compile))
(closure-compile x))]
[else [else
(log-debug "not compressing javascript...") (log-debug "not compressing javascript...")
x])) x]))
@ -465,12 +469,12 @@ EOF
(define invoke-main-module-code (define invoke-main-module-code
#<<EOF #<<EOF
var invokeMainModule = function() { var invokeMainModule = function() {
var MACHINE = plt.runtime.currentMachine; var M = plt.runtime.currentMachine;
invoke(MACHINE, invoke(M,
function() { function() {
var startTime = new Date().valueOf(); var startTime = new Date().valueOf();
plt.runtime.invokeMains( plt.runtime.invokeMains(
MACHINE, M,
function() { function() {
// On main module invokation success: // On main module invokation success:
var stopTime = new Date().valueOf(); var stopTime = new Date().valueOf();
@ -478,25 +482,25 @@ var invokeMainModule = function() {
window.console.log('evaluation took ' + (stopTime - startTime) + ' milliseconds'); window.console.log('evaluation took ' + (stopTime - startTime) + ' milliseconds');
} }
}, },
function(MACHINE, e) { function(M, e) {
var contMarkSet, context, i, appName; var contMarkSet, context, i, appName;
// On main module invokation failure // On main module invokation failure
if (window.console && window.console.log) { if (window.console && window.console.log) {
window.console.log(e.stack || e); window.console.log(e.stack || e);
} }
MACHINE.params.currentErrorDisplayer( M.params.currentErrorDisplayer(
MACHINE, $(plt.baselib.format.toDomNode(e.stack || e)).css('color', 'red')); M, $(plt.baselib.format.toDomNode(e.stack || e)).css('color', 'red'));
if (e.hasOwnProperty('racketError') && if (e.hasOwnProperty('racketError') &&
plt.baselib.exceptions.isExn(e.racketError)) { plt.baselib.exceptions.isExn(e.racketError)) {
contMarkSet = plt.baselib.exceptions.exnContMarks(e.racketError); contMarkSet = plt.baselib.exceptions.exnContMarks(e.racketError);
if (contMarkSet) { if (contMarkSet) {
context = contMarkSet.getContext(MACHINE); context = contMarkSet.getContext(M);
for (i = 0; i < context.length; i++) { for (i = 0; i < context.length; i++) {
if (plt.runtime.isVector(context[i])) { if (plt.runtime.isVector(context[i])) {
MACHINE.params.currentErrorDisplayer( M.params.currentErrorDisplayer(
MACHINE, M,
$('<div/>').text(' at ' + context[i].elts[0] + $('<div/>').text(' at ' + context[i].elts[0] +
', line ' + context[i].elts[2] + ', line ' + context[i].elts[2] +
', column ' + context[i].elts[3]) ', column ' + context[i].elts[3])
@ -505,8 +509,8 @@ var invokeMainModule = function() {
.css('whitespace', 'pre') .css('whitespace', 'pre')
.css('color', 'red')); .css('color', 'red'));
} else if (plt.runtime.isProcedure(context[i])) { } else if (plt.runtime.isProcedure(context[i])) {
MACHINE.params.currentErrorDisplayer( M.params.currentErrorDisplayer(
MACHINE, M,
$('<div/>').text(' in ' + context[i].displayName) $('<div/>').text(' in ' + context[i].displayName)
.addClass('stacktrace') .addClass('stacktrace')
.css('margin-left', '10px') .css('margin-left', '10px')

38
js-assembler/runtime-src/baselib-functions.js
View File

@ -61,12 +61,11 @@
// I'd personally love for this to be a macro and avoid the // I'd personally love for this to be a macro and avoid the
// extra function call here. // extra function call here.
var finalizeClosureCall = function (MACHINE) { var finalizeClosureCall = function (MACHINE) {
MACHINE.callsBeforeTrampoline--; MACHINE.cbt--;
var i, returnArgs = [].slice.call(arguments, 1); var returnArgs = [].slice.call(arguments, 1);
// clear out stack space // clear out stack space
// TODO: replace with a splice. MACHINE.env.length -= MACHINE.argcount;
MACHINE.env.length = MACHINE.env.length - MACHINE.argcount;
if (returnArgs.length === 1) { if (returnArgs.length === 1) {
MACHINE.val = returnArgs[0]; MACHINE.val = returnArgs[0];
@ -77,10 +76,7 @@
} else { } else {
MACHINE.argcount = returnArgs.length; MACHINE.argcount = returnArgs.length;
MACHINE.val = returnArgs.shift(); MACHINE.val = returnArgs.shift();
// TODO: replace with a splice. MACHINE.env.push.apply(MACHINE.env, returnArgs.reverse());
for (i = 0; i < MACHINE.argcount - 1; i++) {
MACHINE.env.push(returnArgs.pop());
}
return MACHINE.control.pop().label.multipleValueReturn(MACHINE); return MACHINE.control.pop().label.multipleValueReturn(MACHINE);
} }
}; };
@ -311,15 +307,6 @@
var makePrimitiveProcedure = function (name, arity, f) {
f.racketArity = arity;
f.displayName = name;
return f;
};
var makeClosure = function (name, arity, f, closureArgs) { var makeClosure = function (name, arity, f, closureArgs) {
if (! closureArgs) { closureArgs = []; } if (! closureArgs) { closureArgs = []; }
return new Closure(f, return new Closure(f,
@ -329,6 +316,23 @@
}; };
var makePrimitiveProcedure = function (name, arity, f) {
// f.racketArity = arity;
// f.displayName = name;
// return f;
return makeClosure(name,
arity,
function(M) {
--M.cbt;
M.val = f(M);
M.env.length -= M.argcount;
return M.control.pop().label(M);
},
[]);
};

997
js-assembler/runtime-src/baselib-primitives.js
View File

File diff suppressed because it is too large Load Diff

8985
js-assembler/runtime-src/jquery.js vendored
View File

File diff suppressed because one or more lines are too long

79
js-assembler/runtime-src/runtime.js
View File

@ -186,7 +186,7 @@
var defaultCurrentPrintImplementation = function defaultCurrentPrintImplementation(MACHINE) { var defaultCurrentPrintImplementation = function defaultCurrentPrintImplementation(MACHINE) {
if(--MACHINE.callsBeforeTrampoline < 0) { if(--MACHINE.cbt < 0) {
throw defaultCurrentPrintImplementation; throw defaultCurrentPrintImplementation;
} }
var oldArgcount = MACHINE.argcount; var oldArgcount = MACHINE.argcount;
@ -211,12 +211,12 @@
// The MACHINE // The MACHINE
var Machine = function() { var Machine = function() {
this.callsBeforeTrampoline = STACK_LIMIT_ESTIMATE; this.cbt = STACK_LIMIT_ESTIMATE; // calls before trampoline
this.val = undefined; this.val = undefined; // value register
this.proc = undefined; this.proc = undefined; // procedure register
this.argcount = undefined; this.argcount = undefined; // argument count
this.env = []; this.env = []; // environment
this.control = []; // Arrayof (U Frame CallFrame PromptFrame) this.control = []; // control: Arrayof (U Frame CallFrame PromptFrame)
this.running = false; this.running = false;
this.modules = {}; // String -> ModuleRecord this.modules = {}; // String -> ModuleRecord
this.mainModules = []; // Arrayof String this.mainModules = []; // Arrayof String
@ -444,17 +444,16 @@
Machine.prototype.trampoline = function(initialJump) { Machine.prototype.trampoline = function(initialJump) {
var MACHINE = this;
var thunk = initialJump; var thunk = initialJump;
var startTime = (new Date()).valueOf(); var startTime = (new Date()).valueOf();
MACHINE.callsBeforeTrampoline = STACK_LIMIT_ESTIMATE; this.cbt = STACK_LIMIT_ESTIMATE;
MACHINE.params.numBouncesBeforeYield = this.params.numBouncesBeforeYield =
MACHINE.params.maxNumBouncesBeforeYield; this.params.maxNumBouncesBeforeYield;
MACHINE.running = true; this.running = true;
while(true) { while(true) {
try { try {
thunk(MACHINE); thunk(this);
break; break;
} catch (e) { } catch (e) {
// There are a few kinds of things that can get thrown // There are a few kinds of things that can get thrown
@ -479,35 +478,36 @@
// The running flag is set to false. // The running flag is set to false.
if (typeof(e) === 'function') { if (typeof(e) === 'function') {
thunk = e; thunk = e;
MACHINE.callsBeforeTrampoline = STACK_LIMIT_ESTIMATE; this.cbt = STACK_LIMIT_ESTIMATE;
if (MACHINE.params.numBouncesBeforeYield-- < 0) { if (this.params.numBouncesBeforeYield-- < 0) {
recomputeMaxNumBouncesBeforeYield( recomputeMaxNumBouncesBeforeYield(
MACHINE, this,
(new Date()).valueOf() - startTime); (new Date()).valueOf() - startTime);
scheduleTrampoline(MACHINE, thunk); scheduleTrampoline(this, thunk);
return; return;
} }
} else if (e instanceof Pause) { } else if (e instanceof Pause) {
var restart = makeRestartFunction(MACHINE); var restart = makeRestartFunction(this);
e.onPause(restart); e.onPause(restart);
return; return;
} else if (e instanceof HaltError) { } else if (e instanceof HaltError) {
MACHINE.running = false; this.running = false;
e.onHalt(MACHINE); e.onHalt(this);
return; return;
} else { } else {
// General error condition: just exit out // General error condition: just exit out
// of the trampoline and call the current error handler. // of the trampoline and call the current error handler.
MACHINE.running = false; this.running = false;
MACHINE.params.currentErrorHandler(MACHINE, e); this.params.currentErrorHandler(this, e);
return; return;
} }
} }
} }
MACHINE.running = false; this.running = false;
var that = this;
setTimeout( setTimeout(
function() { MACHINE.params.currentSuccessHandler(MACHINE); }, function() { that.params.currentSuccessHandler(that); },
0); 0);
return; return;
}; };
@ -655,6 +655,33 @@
var checkClosureAndArity = function(M, n) {
if(!(M.proc instanceof Closure)){
raiseOperatorIsNotClosure(M,M.proc);
}
if(!isArityMatching(M.proc.racketArity,n)) {
raiseArityMismatchError(M, M.proc,n);
}
};
//////////////////////////////////////////////////////////////////////
// Superinstructions to try to reduce code size.
var si_context_expected = function(n) {
if (n === 1) { return si_context_expected_1; }
return function(M) { raiseContextExpectedValuesError(M, n); }
};
var si_context_expected_1 = function(M) { raiseContextExpectedValuesError(M, 1); }
////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////
@ -784,4 +811,8 @@
exports['getTracedAppKey'] = getTracedAppKey; exports['getTracedAppKey'] = getTracedAppKey;
exports['getTracedCalleeKey'] = getTracedCalleeKey; exports['getTracedCalleeKey'] = getTracedCalleeKey;
exports['si_context_expected'] = si_context_expected;
exports['checkClosureAndArity'] = checkClosureAndArity;
}(this.plt, this.plt.baselib)); }(this.plt, this.plt.baselib));

17
js/js-impl.js
View File

@ -1,18 +1,21 @@
var VOID = plt.baselib.constants.VOID_VALUE;
var makePrimitiveProcedure = plt.baselib.functions.makePrimitiveProcedure;
EXPORTS['alert'] = EXPORTS['alert'] =
RUNTIME.makePrimitiveProcedure( makePrimitiveProcedure(
'alert', 'alert',
1, 1,
function(MACHINE) { function(MACHINE) {
var elt = MACHINE.env[MACHINE.env.length - 1]; var elt = MACHINE.env[MACHINE.env.length - 1];
alert(String(elt)); alert(String(elt));
return RUNTIME.VOID; return VOID;
}); });
EXPORTS['body'] = $(document.body); EXPORTS['body'] = $(document.body);
EXPORTS['$'] = EXPORTS['$'] =
RUNTIME.makePrimitiveProcedure( makePrimitiveProcedure(
'$', '$',
1, 1,
function(MACHINE) { function(MACHINE) {
@ -21,7 +24,7 @@ EXPORTS['$'] =
}); });
EXPORTS['call-method'] = EXPORTS['call-method'] =
RUNTIME.makePrimitiveProcedure( makePrimitiveProcedure(
'call-method', 'call-method',
plt.baselib.arity.makeArityAtLeast(2), plt.baselib.arity.makeArityAtLeast(2),
function(MACHINE) { function(MACHINE) {
@ -40,7 +43,7 @@ EXPORTS['call-method'] =
// Javascript-specific extensions. A small experiment. // Javascript-specific extensions. A small experiment.
EXPORTS['viewport-width'] = EXPORTS['viewport-width'] =
RUNTIME.makePrimitiveProcedure( makePrimitiveProcedure(
'viewport-width', 'viewport-width',
0, 0,
function(MACHINE) { function(MACHINE) {
@ -48,7 +51,7 @@ EXPORTS['viewport-width'] =
}); });
EXPORTS['viewport-height'] = EXPORTS['viewport-height'] =
RUNTIME.makePrimitiveProcedure( makePrimitiveProcedure(
'viewport-height', 'viewport-height',
0, 0,
function(MACHINE) { function(MACHINE) {
@ -57,7 +60,7 @@ EXPORTS['viewport-height'] =
EXPORTS['in-javascript-context?'] = EXPORTS['in-javascript-context?'] =
RUNTIME.makePrimitiveProcedure( makePrimitiveProcedure(
'in-javascript-context?', 'in-javascript-context?',
0, 0,
function(MACHINE) { function(MACHINE) {

3
lang/js/query.rkt
View File

@ -2,6 +2,7 @@
(require racket/contract (require racket/contract
racket/runtime-path racket/runtime-path
racket/gui/base
syntax/modresolve) syntax/modresolve)
@ -15,7 +16,7 @@
[lookup-module-requires (path? . -> . (listof path?))]) [lookup-module-requires (path? . -> . (listof path?))])
(define-runtime-path record.rkt "record.rkt") (define-runtime-path record.rkt "record.rkt")
(define ns (make-base-empty-namespace)) (define ns (make-gui-namespace))
;; query: module-path -> string? ;; query: module-path -> string?
;; Given a module, see if it's implemented via Javascript. ;; Given a module, see if it's implemented via Javascript.

5
resource/query.rkt
View File

@ -4,13 +4,14 @@
racket/runtime-path racket/runtime-path
syntax/modresolve syntax/modresolve
racket/path racket/path
"structs.rkt") "structs.rkt"
racket/gui/base)
(provide/contract [query (module-path? . -> . (listof resource?))]) (provide/contract [query (module-path? . -> . (listof resource?))])
(define-runtime-path record.rkt "record.rkt") (define-runtime-path record.rkt "record.rkt")
(define ns (make-base-namespace)) (define ns (make-gui-namespace))
;; query: module-path -> (listof record) ;; query: module-path -> (listof record)
;; Given a module, collect all of its resource records ;; Given a module, collect all of its resource records

67
scribblings/cs19.scrbl
View File

@ -66,7 +66,7 @@ Google Chrome should be in @filepath{/contrib/bin/google-chrome}.
@section{Usage} @section{Usage}
The @filepath{whalesong} launcher in the subdirectory will compile The @filepath{whalesong} launcher in the subdirectory will compile
programs to standalone @filepath{.xhtml} files. programs to @filepath{.html} and @filepath{.js} files.
Example usage: using @litchar{whalesong build} to compile a whalesong program. Example usage: using @litchar{whalesong build} to compile a whalesong program.
@ -81,7 +81,7 @@ fermi ~/whalesong/examples $ cat hello.rkt
fermi ~/whalesong/examples $ ../whalesong build hello.rkt fermi ~/whalesong/examples $ ../whalesong build hello.rkt
fermi ~/whalesong/examples $ google-chrome hello.xhtml fermi ~/whalesong/examples $ google-chrome hello.html
Created new window in existing browser session. Created new window in existing browser session.
fermi ~/whalesong/examples $ fermi ~/whalesong/examples $
@ -124,12 +124,16 @@ $
However, it can also be packaged with @filepath{whalesong}. However, it can also be packaged with @filepath{whalesong}.
@verbatim|{ @verbatim|{
$ whalesong build hello.rkt $ whalesong build hello.rkt
Writing program #<path:/home/dyoo/work/whalesong/examples/hello.js>
Writing html #<path:/home/dyoo/work/whalesong/examples/hello.html>
$ ls -l hello.xhtml $ ls -l hello.html
-rw-rw-r-- 1 dyoo nogroup 692213 Jun 7 18:00 hello.xhtml -rw-r--r-- 1 dyoo dyoo 3817 2011-09-10 15:02 hello.html
$ ls -l hello.js
-rw-r--r-- 1 dyoo dyoo 2129028 2011-09-10 15:02 hello.js
}| }|
Running @tt{whalesong build} on a Racket program will produce a self-contained Running @tt{whalesong build} on a Racket program will produce
@filepath{.xhtml} file. If we open this file in our favorite web browser, @filepath{.html} and @filepath{.js} files. If we open this file in our favorite web browser,
we should see a triumphant message show on screen. we should see a triumphant message show on screen.
@ -202,10 +206,59 @@ by @racket[on-tick], though because we're on the web, we can
bind to many other kinds of web events (by using @racket[view-bind]).} bind to many other kinds of web events (by using @racket[view-bind]).}
] ]
The rest of this document describes the API.
@subsection{More web-world examples}
Here are a collection of web-world demos:
@itemize[
@item{@link["http://hashcollision.org/whalesong/examples/attr-animation/attr-animation.html"]{attr-animation.html} [@link["http://hashcollision.org/whalesong/examples/attr-animation/attr-animation.rkt"]{src}] Uses @racket[update-view-attr] and @racket[on-tick] to perform a simple color animation.}
@item{@link["http://hashcollision.org/whalesong/examples/dwarves/dwarves.html"]{dwarves.html}
[@link["http://hashcollision.org/whalesong/examples/dwarves/dwarves.rkt"]{src}]
Uses @racket[view-show] and @racket[view-hide] to manipulate a view. Click on a dwarf to make them hide.
}
@item{@link["http://hashcollision.org/whalesong/examples/dwarves-with-remove/dwarves-with-remove.html"]{dwarves-with-remove.html}
[@link["http://hashcollision.org/whalesong/examples/dwarves-with-remove/dwarves-with-remove.rkt"]{src}]
Uses @racket[view-focus?] and @racket[view-remove] to see if a dwarf should be removed from the view.
}
@item{@link["http://hashcollision.org/whalesong/examples/field/field.html"]{field.html}
[@link["http://hashcollision.org/whalesong/examples/field/field.rkt"]{src}]
Uses @racket[view-bind] to read a text field, and @racket[update-view-text] to change
the text content of an element.
}
@item{@link["http://hashcollision.org/whalesong/examples/phases/phases.html"]{phases.html}
[@link["http://hashcollision.org/whalesong/examples/phases/phases.rkt"]{src}]
Switches out one view entirely in place of another. Different views can correspond to phases in a program.
}
@item{@link["http://hashcollision.org/whalesong/examples/tick-tock/tick-tock.html"]{tick-tock.html}
[@link["http://hashcollision.org/whalesong/examples/tick-tock/tick-tock.rkt"]{src}]
Uses @racket[on-tick] to show a timer counting up.
}
@item{@link["http://hashcollision.org/whalesong/examples/redirected/redirected.html"]{redirected.html}
[@link["http://hashcollision.org/whalesong/examples/redirected/redirected.rkt"]{src}]
Uses @racket[on-tick] to show a timer counting up, and also uses @racket[open-output-element] to
pipe side-effecting @racket[printf]s to a hidden @tt{div}.
}
@item{@link["http://hashcollision.org/whalesong/examples/todo/todo.html"]{todo.html}
[@link["http://hashcollision.org/whalesong/examples/todo/todo.rkt"]{src}]
A simple TODO list manager.
}
@item{@link["http://hashcollision.org/whalesong/examples/where-am-i/where-am-i.html"]{where-am-i.html}
[@link["http://hashcollision.org/whalesong/examples/where-am-i/where-am-i.rkt"]{src}]
Uses @racket[on-location-change] and @racket[on-mock-location-change] to demonstrate location services.
}
]

139
scribblings/manual.scrbl
View File

@ -5,6 +5,7 @@
scribble/eval scribble/eval
racket/sandbox racket/sandbox
racket/port racket/port
racket/list
(only-in racket/contract any/c) (only-in racket/contract any/c)
racket/runtime-path racket/runtime-path
"scribble-helpers.rkt" "scribble-helpers.rkt"
@ -99,7 +100,8 @@ The GitHub source repository to Whalesong can be found at
Prerequisites: at least @link["http://racket-lang.org/"]{Racket Prerequisites: at least @link["http://racket-lang.org/"]{Racket
5.1.1}, and a @link["http://www.java.com"]{Java 1.6} SDK. 5.1.1}. If you wish to use the JavaScript compression option,
you will need @link["http://www.java.com"]{Java 1.6} SDK.
@; (This might be superfluous information, so commented out @; (This might be superfluous information, so commented out
@; for the moment...) @; for the moment...)
@;The majority of the project is written @;The majority of the project is written
@ -194,7 +196,7 @@ recompile Whalesong on every single use, which can be very expensive.
@subsection{Making Standalone @tt{.xhtml} files with Whalesong} @subsection{Making @tt{.html} files with Whalesong}
Let's try making a simple, standalone executable. At the moment, the Let's try making a simple, standalone executable. At the moment, the
program must be written in the base language of @racket[(planet program must be written in the base language of @racket[(planet
@ -219,21 +221,28 @@ $
}| }|
However, it can also be packaged with @filepath{whalesong}. However, it can also be packaged with @filepath{whalesong}.
@verbatim|{ @verbatim|{
$ whalesong build hello.rkt $ whalesong build hello.rkt
Writing program #<path:/home/dyoo/work/whalesong/examples/hello.js>
Writing html #<path:/home/dyoo/work/whalesong/examples/hello.html>
$ ls -l hello.html
-rw-r--r-- 1 dyoo dyoo 3817 2011-09-10 15:02 hello.html
$ ls -l hello.js
-rw-r--r-- 1 dyoo dyoo 2129028 2011-09-10 15:02 hello.js
$ ls -l hello.xhtml
-rw-rw-r-- 1 dyoo nogroup 692213 Jun 7 18:00 hello.xhtml
}| }|
Running @tt{whalesong build} on a Racket program will produce a self-contained
@filepath{.xhtml} file. If you open this file in your favorite web browser, @margin-note{Visit @link["http://hashcollision.org/whalesong/examples/hello/hello.html"]{hello.html} to execute this program.}
you should see a triumphant message show on screen. Running @tt{whalesong build} on a Racket program will produce a
@filepath{.html} and @filepath{.js} file. If you open the
@filepath{.html} in your favorite web browser, you should see a
triumphant message show on screen.
We can do something slightly more interesting. Let's write a Whalesong program We can do something slightly more interesting. Let's write a Whalesong program
that accesses the JavaScript DOM. Call this file @filepath{dom-play.rkt}. that accesses the JavaScript DOM. Call this file @filepath{dom-play.rkt}.
@margin-note{ @margin-note{
The generated program can be downloaded here: @link["http://hashcollision.org/whalesong/examples/dom-play.xhtml"]{dom-play.xhtml} Visit @link["http://hashcollision.org/whalesong/examples/dom-play/dom-play.html"]{dom-play.html} to execute this program.}
}
@filebox["dom-play.rkt"]{ @filebox["dom-play.rkt"]{
@codeblock|{ @codeblock|{
@ -272,7 +281,7 @@ The generated program can be downloaded here: @link["http://hashcollision.org/wh
}|} }|}
This program uses the @link["http:/jquery.com"]{JQuery} API provided by @racketmodname[(planet dyoo/whalesong/js)], This program uses the @link["http:/jquery.com"]{JQuery} API provided by @racketmodname[(planet dyoo/whalesong/js)],
as well as the native JavaScript FFI to produce output on the browser. as well as the native JavaScript FFI to produce output on the browser.
If w run Whalesong on this program, and view the resulting @filepath{dom-play.xhtml} in your If w run Whalesong on this program, and view the resulting @filepath{dom-play.html} in your
web browser, we should see a pale, green page with some output. web browser, we should see a pale, green page with some output.
@ -289,12 +298,12 @@ function and define it in a module called @filepath{fact.rkt}:
@margin-note{ @margin-note{
The files can also be downloaded here: The files can also be downloaded here:
@itemlist[@item{@link["http://hashcollision.org/whalesong/fact-example/fact.rkt"]{fact.rkt}} @itemlist[@item{@link["http://hashcollision.org/whalesong/examples/fact/fact.rkt"]{fact.rkt}}
@item{@link["http://hashcollision.org/whalesong/fact-example/index.html"]{index.html}}] @item{@link["http://hashcollision.org/whalesong/examples/fact/index.html"]{index.html}}]
with generated JavaScript binaries here: with generated JavaScript binaries here:
@itemlist[ @itemlist[
@item{@link["http://hashcollision.org/whalesong/fact-example/fact.js"]{fact.js}} @item{@link["http://hashcollision.org/whalesong/examples/fact/fact.js"]{fact.js}}
@item{@link["http://hashcollision.org/whalesong/fact-example/runtime.js"]{runtime.js}} @item{@link["http://hashcollision.org/whalesong/examples/fact/runtime.js"]{runtime.js}}
] ]
} }
@ -311,7 +320,7 @@ with generated JavaScript binaries here:
(* x (fact (sub1 x)))])) (* x (fact (sub1 x)))]))
}|} }|}
Instead of creating a standalone @tt{.xhtml}, we can use @tt{whalesong} to Instead of creating a standalone @tt{.html}, we can use @tt{whalesong} to
get us the module's code. From the command-line: get us the module's code. From the command-line:
@verbatim|{ @verbatim|{
$ whalesong get-javascript fact.rkt > fact.js $ whalesong get-javascript fact.rkt > fact.js
@ -373,6 +382,7 @@ The factorial of 10000 is <span id="answer">being computed</span>.
}| }|
} }
@margin-note{See: @link["http://hashcollision.org/whalesong/examples/fact/bad-index.html"]{bad-index.html}.}
Replacing the @racket[10000] with @racket["one-billion-dollars"] should Replacing the @racket[10000] with @racket["one-billion-dollars"] should
reliably produce a proper error message. reliably produce a proper error message.
@ -385,28 +395,29 @@ Whalesong provides a command-line utility called @tt{whalesong} for
translating Racket to JavaScript. It can be run in several modes: translating Racket to JavaScript. It can be run in several modes:
@itemize[ @itemize[
@item{To create standalone XHTML documents} @item{To create HTML + js documents}
@item{To output the compiled JavaScript as a single @filepath{.js} file} @item{To output the compiled JavaScript as a single @filepath{.js} file}
@item{To output the compiled JavaScript as several @filepath{.js} files, one per module. (this isn't done yet...)}
] ]
Using @tt{whalesong} to generate standalone XHTML documents is Using @tt{whalesong} to generate HTML+js documents is
relatively straightforward with the @tt{build} command. To use it, relatively straightforward with the @tt{build} command. To use it,
pass the name of the file to it: pass the name of the file to it:
@verbatim|{ @verbatim|{
$ whalesong build [name-of-racket-file] $ whalesong build [name-of-racket-file]
}| }|
An @filepath{.xhtml} will be written to the current directory. A @filepath{.html} and @filepath{.js} will be written to the current directory, as will any external resources that the program uses.
Almost all of the @tt{whalesong} commands support two command line options: Almost all of the @tt{whalesong} commands support two command line options:
@itemize{ @itemize{
@item{@verbatim{--compress-javascript}: Use Google Closure's JavaScript @item{@verbatim{--compress-javascript} Use Google Closure's JavaScript
compiler to significantly compress the JavaScript. Using this compiler to significantly compress the JavaScript. Using this
currently requires a Java 1.6 JDK.} currently requires a Java 1.6 JDK.}
@item{@verbatim{--verbose}: write verbose debugging information to standard error.} @item{@verbatim{--verbose} Write verbose debugging information to standard error.}
@item{@verbatim{--dest-dir} Write files to a separate directory, rather than the current directory.}
} }
@ -421,11 +432,10 @@ program.
@subsection{@tt{build}} @subsection{@tt{build}}
Given the name of a program, this builds a standalone Given the name of a program, this builds
@filepath{.xhtml} file into the current working directory that @filepath{.html} and @filepath{.js} files into the current working directory.
executes the program in a web browser.
The @filepath{.xhtml} should be self-contained, with an exception: if The @filepath{.html} and @filepath{.js} should be self-contained, with an exception: if
the file uses any external @tech{resource}s by using the file uses any external @tech{resource}s by using
@racket[define-resource], those resources are written into the current @racket[define-resource], those resources are written into the current
working directory, if they do not already exist there. working directory, if they do not already exist there.
@ -545,7 +555,7 @@ the page itself is a source of state, it too will be passed to
callbacks. This library presents a functional version of the DOM in callbacks. This library presents a functional version of the DOM in
the form of a @tech{view}. the form of a @tech{view}.
@margin-note{Visit @link["http://hashcollision.org/whalesong/examples/tick-tock/tick-tock.html"]{tick-tock.html} to execute this program.}
Let's demonstrate this by creating a basic ticker that counts on the Let's demonstrate this by creating a basic ticker that counts on the
screen every second. screen every second.
@ -611,6 +621,56 @@ by @racket[on-tick], though because we're on the web, we can
bind to many other kinds of web events (by using @racket[view-bind]).} bind to many other kinds of web events (by using @racket[view-bind]).}
] ]
@subsection{More web-world examples}
Here are a collection of web-world demos:
@itemize[
@item{@link["http://hashcollision.org/whalesong/examples/attr-animation/attr-animation.html"]{attr-animation.html} [@link["http://hashcollision.org/whalesong/examples/attr-animation/attr-animation.rkt"]{src}] Uses @racket[update-view-attr] and @racket[on-tick] to perform a simple color animation.}
@item{@link["http://hashcollision.org/whalesong/examples/dwarves/dwarves.html"]{dwarves.html}
[@link["http://hashcollision.org/whalesong/examples/dwarves/dwarves.rkt"]{src}]
Uses @racket[view-show] and @racket[view-hide] to manipulate a view. Click on a dwarf to make them hide.
}
@item{@link["http://hashcollision.org/whalesong/examples/dwarves-with-remove/dwarves-with-remove.html"]{dwarves-with-remove.html}
[@link["http://hashcollision.org/whalesong/examples/dwarves-with-remove/dwarves-with-remove.rkt"]{src}]
Uses @racket[view-focus?] and @racket[view-remove] to see if a dwarf should be removed from the view.
}
@item{@link["http://hashcollision.org/whalesong/examples/field/field.html"]{field.html}
[@link["http://hashcollision.org/whalesong/examples/field/field.rkt"]{src}]
Uses @racket[view-bind] to read a text field, and @racket[update-view-text] to change
the text content of an element.
}
@item{@link["http://hashcollision.org/whalesong/examples/phases/phases.html"]{phases.html}
[@link["http://hashcollision.org/whalesong/examples/phases/phases.rkt"]{src}]
Switches out one view entirely in place of another. Different views can correspond to phases in a program.
}
@item{@link["http://hashcollision.org/whalesong/examples/tick-tock/tick-tock.html"]{tick-tock.html}
[@link["http://hashcollision.org/whalesong/examples/tick-tock/tick-tock.rkt"]{src}]
Uses @racket[on-tick] to show a timer counting up.
}
@item{@link["http://hashcollision.org/whalesong/examples/redirected/redirected.html"]{redirected.html}
[@link["http://hashcollision.org/whalesong/examples/redirected/redirected.rkt"]{src}]
Uses @racket[on-tick] to show a timer counting up, and also uses @racket[open-output-element] to
pipe side-effecting @racket[printf]s to a hidden @tt{div}.
}
@item{@link["http://hashcollision.org/whalesong/examples/todo/todo.html"]{todo.html}
[@link["http://hashcollision.org/whalesong/examples/todo/todo.rkt"]{src}]
A simple TODO list manager.
}
@item{@link["http://hashcollision.org/whalesong/examples/where-am-i/where-am-i.html"]{where-am-i.html}
[@link["http://hashcollision.org/whalesong/examples/where-am-i/where-am-i.rkt"]{src}]
Uses @racket[on-location-change] and @racket[on-mock-location-change] to demonstrate location services.
}
]
@subsection{@racket[big-bang] and its options} @subsection{@racket[big-bang] and its options}
@declare-exporting/this-package[web-world] @declare-exporting/this-package[web-world]
@ -824,6 +884,11 @@ Update the form value of the node at the focus.}
@defproc[(view-append-child [d dom]) view]{ @defproc[(view-append-child [d dom]) view]{
Add the dom node @racket[d] as the last child of the focused node.} Add the dom node @racket[d] as the last child of the focused node.}
@defproc[(view-remove [v view]) view]{
Remove the dom node at the focus from the view @racket[v]. Focus tries to move
to the right, if there's a next sibling. If that fails, focus then
moves to the left, if there's a previous sibling. If that fails too,
then focus moves to the parent.}
@subsection{Events} @subsection{Events}
@ -1569,14 +1634,26 @@ Whalesong uses code and utilities from the following external projects:
] ]
The following folks have helped tremendously in the implementation of The following folks have helped tremendously in the implementation of
Whalesong by implementing libraries, giving guidence, and suggesting Whalesong by implementing libraries, giving guidence, reporting bugs,
improvements: and suggesting improvements.
@itemlist[ @;;;;
@; in no particular order... really! I'm shuffling them! :)
@;;;;
@(apply itemlist
(shuffle (list
@item{Ethan Cecchetti} @item{Ethan Cecchetti}
@item{Scott Newman} @item{Scott Newman}
@item{Zhe Zhang} @item{Zhe Zhang}
@item{Jens Axel Søgaard} @item{Jens Axel Søgaard}
@item{Jay McCarthy}
@item{Sam Tobin-Hochstadt}
@item{Doug Orleans}
@item{Richard Cleis}
@item{Asumu Takikawa}
@item{Eric Hanchrow}
@item{Greg Hendershott}
@item{Shriram Krishnamurthi} @item{Shriram Krishnamurthi}
@item{Emmanuel Schanzer} @item{Emmanuel Schanzer}
] @item{Robby Findler}))
)

24
simulator/simulator.rkt
View File

@ -308,15 +308,15 @@
[else [else
'ok]))] 'ok]))]
[(CheckClosureArity!? op) [(CheckClosureAndArity!? op)
(let: ([clos : SlotValue (machine-proc m)]) (let: ([clos : SlotValue (machine-proc m)])
(cond (cond
[(closure? clos) [(closure? clos)
(if (arity-match? (closure-arity clos) (if (arity-match? (closure-arity clos)
(ensure-natural (evaluate-oparg m (CheckClosureArity!-num-args op)))) (ensure-natural (evaluate-oparg m (CheckClosureAndArity!-num-args op))))
'ok 'ok
(error 'check-closure-arity "arity mismatch: passed ~s args to ~s" (error 'check-closure-arity "arity mismatch: passed ~s args to ~s"
(ensure-natural (evaluate-oparg m (CheckClosureArity!-num-args op))) (ensure-natural (evaluate-oparg m (CheckClosureAndArity!-num-args op)))
(closure-display-name clos)))] (closure-display-name clos)))]
[else [else
(error 'check-closure-arity "not a closure: ~s" clos)]))] (error 'check-closure-arity "not a closure: ~s" clos)]))]
@ -654,23 +654,7 @@
(MakeCompiledProcedureShell-arity op) (MakeCompiledProcedureShell-arity op)
'() '()
(MakeCompiledProcedureShell-display-name op)))] (MakeCompiledProcedureShell-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(let: ([prim : SlotValue (machine-proc m)]
[args : (Listof PrimitiveValue)
(map ensure-primitive-value (take (machine-env m)
(ensure-natural (machine-argcount m))))])
(cond
[(primitive-proc? prim)
(target-updater! m (ensure-primitive-value
(parameterize ([current-output-port
(current-simulated-output-port)])
(apply (primitive-proc-f prim)
m
args))))]
[else
(error 'apply-primitive-procedure)]))]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
(target-updater! m (make-CapturedEnvironment (drop (machine-env m) (target-updater! m (make-CapturedEnvironment (drop (machine-env m)
(CaptureEnvironment-skip op))))] (CaptureEnvironment-skip op))))]

1
tests/more-tests/weird-cc.expected Normal file
View File

@ -0,0 +1 @@
11213

5
tests/more-tests/weird-cc.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang planet dyoo/whalesong
(define program (lambda () (let ((y (call/cc (lambda (c) c)))) (display 1) (call/cc (lambda (c) (y c))) (display 2) (call/cc (lambda (c) (y c))) (display 3))))
(program)
(newline)

1
tests/run-more-tests.rkt
View File

@ -27,3 +27,4 @@
(test "more-tests/conform.rkt") (test "more-tests/conform.rkt")
(test "more-tests/earley.rkt") (test "more-tests/earley.rkt")
(test "more-tests/view.rkt") (test "more-tests/view.rkt")
(test "more-tests/weird-cc.rkt")

6
tests/test-all.rkt
View File

@ -2,9 +2,9 @@
(require "test-parse.rkt" (require "test-parse.rkt"
"test-parse-bytecode.rkt" "test-parse-bytecode.rkt"
"test-simulator.rkt" ;; "test-simulator.rkt"
"test-compiler.rkt" ;; "test-compiler.rkt"
"test-compiler-2.rkt" ;; "test-compiler-2.rkt"
"test-assemble.rkt" "test-assemble.rkt"
"test-browser-evaluate.rkt" "test-browser-evaluate.rkt"
"test-package.rkt" "test-package.rkt"

174
tests/test-assemble.rkt
View File

@ -46,8 +46,8 @@
"(function() { " "(function() { "
runtime runtime
"var RUNTIME = plt.runtime;" "var RT = plt.runtime;"
"var MACHINE = new plt.runtime.Machine();\n" "var M = new plt.runtime.Machine();\n"
"return function(success, fail, params){" "return function(success, fail, params){"
snippet snippet
@ -55,7 +55,7 @@
"});")]) "});")])
(displayln snippet) (displayln snippet)
(display code op)))))) (display code op))))))
(define (E-single a-statement (inspector "MACHINE.val")) (define (E-single a-statement (inspector "M.val"))
(evaluated-value ((force -E) (cons a-statement inspector)))) (evaluated-value ((force -E) (cons a-statement inspector))))
;; evaluating many expressions[. ;; evaluating many expressions[.
@ -65,25 +65,25 @@
[inspector (cdr a-statement+inspector)]) [inspector (cdr a-statement+inspector)])
(display runtime op) (display runtime op)
"var RUNTIME = plt.runtime;" "var RT = plt.runtime;"
(display "var MACHINE = new plt.runtime.Machine();\n" op) (display "var M = new plt.runtime.Machine();\n" op)
(display "(function() { " op) (display "(function() { " op)
(display "var myInvoke = " op) (display "var myInvoke = " op)
(assemble/write-invoke a-statement op) (assemble/write-invoke a-statement op)
(display ";" op) (display ";" op)
(fprintf op (fprintf op
"return function(succ, fail, params) { "return function(succ, fail, params) {
var newParams = { currentDisplayer: function(MACHINE, v) { var newParams = { currentDisplayer: function(M, v) {
params.currentDisplayer(v); } }; params.currentDisplayer(v); } };
myInvoke(MACHINE, myInvoke(M,
function(v) { succ(plt.runtime.toDisplayedString(~a));}, function(v) { succ(plt.runtime.toDisplayedString(~a));},
function(MACHINE, exn) { fail(exn); }, function(M, exn) { fail(exn); },
newParams); newParams);
}" }"
inspector) inspector)
(display "})" op)))))) (display "})" op))))))
(define (E-many stmts (inspector "MACHINE.val")) (define (E-many stmts (inspector "M.val"))
(evaluated-value ((force -E-many) (cons stmts inspector)))) (evaluated-value ((force -E-many) (cons stmts inspector))))
@ -108,27 +108,27 @@
;; Assigning to proc means val should still be uninitialized. ;; Assigning to proc means val should still be uninitialized.
(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny"))) (test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny")))
"#<undefined>") "#<undefined>")
;; But we should see the assignment if we inspect MACHINE.proc. ;; But we should see the assignment if we inspect M.proc.
(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny")) (test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny"))
"MACHINE.proc") "M.proc")
"Danny") "Danny")
(test (E-single (make-PushEnvironment 1 #f) (test (E-single (make-PushEnvironment 1 #f)
"MACHINE.env.length") "M.env.length")
"1") "1")
(test (E-single (make-PushEnvironment 20 #f) (test (E-single (make-PushEnvironment 20 #f)
"MACHINE.env.length") "M.env.length")
"20") "20")
;; PopEnvironment ;; PopEnvironment
(test (E-many (list (make-PushEnvironment 2 #f)) (test (E-many (list (make-PushEnvironment 2 #f))
"MACHINE.env.length") "M.env.length")
"2") "2")
(test (E-many (list (make-PushEnvironment 2 #f) (test (E-many (list (make-PushEnvironment 2 #f)
(make-PopEnvironment (make-Const 1) (make-PopEnvironment (make-Const 1)
(make-Const 0))) (make-Const 0)))
"MACHINE.env.length") "M.env.length")
"1") "1")
@ -137,39 +137,39 @@
(test (E-many (list (make-PushEnvironment 2 #f) (test (E-many (list (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const 12345))) (make-Const 12345)))
"MACHINE.env[1]") "M.env[1]")
"12345") "12345")
(test (E-many (list (make-PushEnvironment 2 #f) (test (E-many (list (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const 12345))) (make-Const 12345)))
"MACHINE.env[0]") "M.env[0]")
"#<undefined>") "#<undefined>")
(test (E-many (list (make-PushEnvironment 2 #f) (test (E-many (list (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const 12345))) (make-Const 12345)))
"MACHINE.env[0]") "M.env[0]")
"12345") "12345")
;; Toplevel Environment loading ;; Toplevel Environment loading
(test (E-single (make-PerformStatement (make-ExtendEnvironment/Prefix! '(pi))) (test (E-single (make-PerformStatement (make-ExtendEnvironment/Prefix! '(pi)))
"plt.runtime.toWrittenString(MACHINE.env[0]).slice(0, 5)") "plt.runtime.toWrittenString(M.env[0]).slice(0, 5)")
"3.141") "3.141")
;; Simple application ;; Simple application
(test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ;; (make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
(make-PushEnvironment 2 #f) ;; (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) ;; (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const 3)) ;; (make-Const 3))
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) ;; (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const 4)) ;; (make-Const 4))
(make-AssignImmediateStatement 'argcount (make-Const 2)) ;; (make-AssignImmediateStatement 'argcount (make-Const 2))
(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) ;; (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
'done)) ;; 'done))
"7") ;; "7")
@ -180,7 +180,7 @@
(make-GotoStatement (make-Label 'afterLambda)) (make-GotoStatement (make-Label 'afterLambda))
'afterLambda 'afterLambda
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart))) (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart)))
"MACHINE.val.displayName") "M.val.displayName")
"closureStart") "closureStart")
@ -197,7 +197,7 @@
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0
(list 0 1) (list 0 1)
'closureStart))) 'closureStart)))
"MACHINE.val.closedVals[1] + ',' + MACHINE.val.closedVals[0]") "M.val.closedVals[1] + ',' + M.val.closedVals[0]")
"hello,world") "hello,world")
;; Let's try to install the closure values. ;; Let's try to install the closure values.
@ -220,7 +220,7 @@
(make-Const 0)) (make-Const 0))
(make-GotoStatement (make-Label 'closureStart)) (make-GotoStatement (make-Label 'closureStart))
'theEnd) 'theEnd)
"plt.runtime.toWrittenString(MACHINE.env.length) + ',' + MACHINE.env[1] + ',' + MACHINE.env[0]") "plt.runtime.toWrittenString(M.env.length) + ',' + M.env[1] + ',' + M.env[0]")
"2,hello,world") "2,hello,world")
@ -244,7 +244,7 @@
(make-PopEnvironment (make-Const 2) (make-Const 0)) (make-PopEnvironment (make-Const 2) (make-Const 0))
(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) (make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
'theEnd) 'theEnd)
"typeof(MACHINE.val) + ',' + (MACHINE.val === MACHINE.proc.label)") "typeof(M.val) + ',' + (M.val === M.proc.label)")
"function,true") "function,true")
@ -265,7 +265,7 @@
(list 0 1) (list 0 1)
'closureStart)) 'closureStart))
(make-PopEnvironment (make-Const 2) (make-Const 0)) (make-PopEnvironment (make-Const 2) (make-Const 0))
(make-PerformStatement (make-CheckClosureArity! (make-Const 5))) (make-PerformStatement (make-CheckClosureAndArity! (make-Const 5)))
'theEnd))) 'theEnd)))
;; this should fail, since the check is for 1, but the closure expects 5. ;; this should fail, since the check is for 1, but the closure expects 5.
@ -288,7 +288,7 @@
(list 0 1) (list 0 1)
'closureStart)) 'closureStart))
(make-PopEnvironment (make-Const 2) (make-Const 0)) (make-PopEnvironment (make-Const 2) (make-Const 0))
(make-PerformStatement (make-CheckClosureArity! (make-Const 1))) (make-PerformStatement (make-CheckClosureAndArity! (make-Const 1)))
'theEnd))) 'theEnd)))
(error 'expected-failure)) (error 'expected-failure))
@ -315,48 +315,48 @@
end)) end))
"ok") "ok")
;; Test for primitive procedure ;; ;; Test for primitive procedure
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+)) ;; (test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+))
,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) ;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end)) ;; ,(make-GotoStatement (make-Label 'end))
onTrue ;; onTrue
,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
end)) ;; end))
"ok") ;; "ok")
;; Give a primitive procedure in val ;; ;; Give a primitive procedure in val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0)) ;; ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))
,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) ;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end)) ;; ,(make-GotoStatement (make-Label 'end))
onTrue ;; onTrue
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'ok))
end)) ;; end))
"ok") ;; "ok")
;; Give a primitive procedure in proc, but test val ;; ;; Give a primitive procedure in proc, but test val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ;; ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) ;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end)) ;; ,(make-GotoStatement (make-Label 'end))
onTrue ;; onTrue
,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
end)) ;; end))
"not-a-procedure") ;; "not-a-procedure")
;; Give a primitive procedure in proc and test proc ;; ;; Give a primitive procedure in proc and test proc
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ;; ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue) ;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end)) ;; ,(make-GotoStatement (make-Label 'end))
onTrue ;; onTrue
,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
end)) ;; end))
"a-procedure") ;; "a-procedure")
@ -364,7 +364,7 @@
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor)))
,(make-AssignImmediateStatement 'val (make-Const "Kathi")) ,(make-AssignImmediateStatement 'val (make-Const "Kathi"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)))
"MACHINE.env[0][0]") "M.env[0][0]")
"Kathi") "Kathi")
@ -381,7 +381,7 @@
,(make-AssignImmediateStatement 'val (make-Const "Shriram")) ,(make-AssignImmediateStatement 'val (make-Const "Shriram"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
,(make-PerformStatement (make-CheckToplevelBound! 0 0))) ,(make-PerformStatement (make-CheckToplevelBound! 0 0)))
"MACHINE.env[0][0]") "M.env[0][0]")
"Shriram") "Shriram")
@ -391,7 +391,7 @@
(make-Const '(1 2 3))) (make-Const '(1 2 3)))
,(make-AssignImmediateStatement 'argcount (make-Const 1)) ,(make-AssignImmediateStatement 'argcount (make-Const 1))
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0)))) ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0))))
"MACHINE.argcount + ',' + MACHINE.env[0] + ',' + MACHINE.env[1] + ',' + MACHINE.env[2]") "M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2]")
"3,3,2,1") "3,3,2,1")
@ -404,7 +404,7 @@
(make-Const '(1 2 3))) (make-Const '(1 2 3)))
,(make-AssignImmediateStatement 'argcount (make-Const 3)) ,(make-AssignImmediateStatement 'argcount (make-Const 3))
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 2)))) ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 2))))
"MACHINE.argcount + ',' + MACHINE.env[0] + ',' + MACHINE.env[1] + ',' + MACHINE.env[2] + ',' + MACHINE.env[3] + ',' + MACHINE.env[4]") "M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2] + ',' + M.env[3] + ',' + M.env[4]")
"5,3,2,1,world,hello") "5,3,2,1,world,hello")
@ -420,7 +420,7 @@
,(make-AssignImmediateStatement 'argcount (make-Const 1)) ,(make-AssignImmediateStatement 'argcount (make-Const 1))
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0) ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0)
(make-Const 1)))) (make-Const 1))))
"MACHINE.argcount + ',' + plt.runtime.isList(MACHINE.env[0])") "M.argcount + ',' + plt.runtime.isList(M.env[0])")
"1,true") "1,true")
@ -438,7 +438,7 @@
(make-Const 'z)) (make-Const 'z))
,(make-AssignImmediateStatement 'argcount (make-Const 5)) ,(make-AssignImmediateStatement 'argcount (make-Const 5))
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2) (make-Const 3)))) ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2) (make-Const 3))))
"MACHINE.argcount + ',' + MACHINE.env.length + ',' + plt.runtime.isList(MACHINE.env[0]) + ',' + MACHINE.env[2] + ',' + MACHINE.env[1]") "M.argcount + ',' + M.env.length + ',' + plt.runtime.isList(M.env[0]) + ',' + M.env[2] + ',' + M.env[1]")
"3,3,true,hello,world") "3,3,true,hello,world")
@ -457,7 +457,7 @@
bad bad
,(make-AssignImmediateStatement 'val (make-Const 'bad)) ,(make-AssignImmediateStatement 'val (make-Const 'bad))
end) end)
"MACHINE.val") "M.val")
"ok") "ok")
@ -474,7 +474,7 @@
ok ok
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-AssignImmediateStatement 'val (make-Const 'ok))
end) end)
"MACHINE.val") "M.val")
"ok") "ok")
(test (E-many `(procedure-entry (test (E-many `(procedure-entry
@ -490,7 +490,7 @@
ok ok
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-AssignImmediateStatement 'val (make-Const 'ok))
end) end)
"MACHINE.val") "M.val")
"ok") "ok")
(test (E-many `(procedure-entry (test (E-many `(procedure-entry
@ -506,7 +506,7 @@
bad bad
,(make-AssignImmediateStatement 'val (make-Const 'bad)) ,(make-AssignImmediateStatement 'val (make-Const 'bad))
end) end)
"MACHINE.val") "M.val")
"ok") "ok")
@ -521,7 +521,7 @@
'proc 'proc
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry)) (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry))
,(make-AssignImmediateStatement 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 0))) ,(make-AssignImmediateStatement 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 0)))
"MACHINE.val") "M.val")
"4") "4")
(test (E-many `(,(make-PushImmediateOntoEnvironment (make-Const 3) #f) (test (E-many `(,(make-PushImmediateOntoEnvironment (make-Const 3) #f)
@ -532,7 +532,7 @@
'proc 'proc
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry)) (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry))
,(make-AssignImmediateStatement 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 1))) ,(make-AssignImmediateStatement 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 1)))
"MACHINE.val") "M.val")
"3") "3")

13
web-world/examples/tick-tock/tick-tock.rkt
View File

@ -6,19 +6,20 @@
;; draw: world view -> view ;; draw: world view -> view
(define (draw w v) (define (draw w dom)
(update-view-text (view-focus v "counter") w)) (update-view-text (view-focus dom "counter") w))
;; tick: world view -> world ;; tick: world view -> world
(define (tick w v) (define (tick w v)
(printf "Tick ~s\n" w) (add1 w))
(+ w 1))
(define (stop? world dom)
(> world 10))
(big-bang 0 (big-bang 0
(initial-view index.html) (initial-view index.html)
(to-draw draw) (to-draw draw)
(on-tick tick 1) (on-tick tick 1)
(stop-when (lambda (w v) (stop-when stop?))
(> w 10))))

14
web-world/js-impl.js
View File

@ -1,4 +1,4 @@
/*jslint browser: true, unparam: true, vars: true, white: true, plusplus: true, maxerr: 50, indent: 4 */ /*jslint browser: true, unparam: true, vars: true, white: true, plusplus: true, maxerr: 50, indent: 4, forin: true */
/*global plt,MACHINE,$,EXPORTS,TreeCursor*/ /*global plt,MACHINE,$,EXPORTS,TreeCursor*/
(function() { (function() {
@ -618,8 +618,7 @@
var isDomNode = function(x) { var isDomNode = function(x) {
return (x.hasOwnProperty('nodeType') && return (x.nodeType === 1);
x.nodeType === 1);
}; };
@ -754,8 +753,11 @@
var objectToEvent = function(obj) { var objectToEvent = function(obj) {
var key, val; var key, val;
var result = makeList(); var result = makeList();
// Note: for some reason, jslint is not satisfied that I check
// that the object has a hasOwnProperty before I use it. I've intentionally
// turned off jslint's forin check because it's breaking here:
for (key in obj) { for (key in obj) {
if (obj.hasOwnProperty(key)) { if (obj.hasOwnProperty && obj.hasOwnProperty(key)) {
val = obj[key]; val = obj[key];
if (typeof(val) === 'number') { if (typeof(val) === 'number') {
result = makePair(makeList(makeSymbol(key), result = makePair(makeList(makeSymbol(key),
@ -886,7 +888,9 @@
LocationEventSource.prototype.onStart = function(fireEvent) { LocationEventSource.prototype.onStart = function(fireEvent) {
if (this.id === undefined) { if (this.id === undefined) {
var success = function(position) { var success = function(position) {
if (position.hasOwnProperty('coords') && if (position.hasOwnProperty &&
position.hasOwnProperty('coords') &&
position.coords.hasOwnProperty &&
position.coords.hasOwnProperty('latitude') && position.coords.hasOwnProperty('latitude') &&
position.coords.hasOwnProperty('longitude')) { position.coords.hasOwnProperty('longitude')) {
fireEvent(undefined, fireEvent(undefined,