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

Merge commit 'origin/master'

Browse Source
This commit is contained in:
Danny Yoo 2011-09-19 12:58:06 -04:00
commit 07c36eb332
39 changed files with 1411 additions and 13512 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
compiler/optimize-il.rkt
View File

@ -180,10 +180,14 @@
(loop (rest stmts)))] (loop (rest stmts)))]
[(DebugPrint? a-stmt) [(DebugPrint? a-stmt)
(cons a-stmt (loop (rest stmts)))] ;(cons a-stmt (loop (rest stmts)))
(loop (rest stmts))
]
[(Comment? a-stmt) [(Comment? a-stmt)
(cons a-stmt (loop (rest stmts)))] (loop (rest stmts))
;(cons a-stmt (loop (rest stmts)))
]
[(AssignImmediateStatement? a-stmt) [(AssignImmediateStatement? a-stmt)
(cons (make-AssignImmediateStatement (rewrite-target (AssignImmediateStatement-target a-stmt)) (cons (make-AssignImmediateStatement (rewrite-target (AssignImmediateStatement-target a-stmt))
@ -332,7 +336,8 @@
#f] #f]
[(DebugPrint? stmt) [(DebugPrint? stmt)
#f] ;#f
#t]
[(AssignImmediateStatement? stmt) [(AssignImmediateStatement? stmt)
(equal? (AssignImmediateStatement-target stmt) (equal? (AssignImmediateStatement-target stmt)

29
examples/mouse.rkt Normal file
View File

@ -0,0 +1,29 @@
#lang planet dyoo/whalesong
(require (planet dyoo/whalesong/world)
(planet dyoo/whalesong/image))
(define width 640)
(define height 480)
(define-struct posn (x y))
(define (mouse world x y type)
(cond
[(string=? type "move")
(make-posn x y)]
[else
world]))
(define (draw w)
(place-image (circle 20 'solid 'red)
(posn-x w)
(posn-y w)
(empty-scene width height)))
(printf "let's see how this works.\n\n")
(big-bang (make-posn 0 0)
(on-mouse mouse)
(to-draw draw))

12
expand-out-images.rkt
View File

@ -202,12 +202,16 @@
(define-values ids #,(on-expr #'expr)))] (define-values ids #,(on-expr #'expr)))]
[(define-syntaxes ids expr) [(define-syntaxes ids expr)
(quasisyntax/loc stx #'(void)
(define-syntaxes ids #,(on-expr #'expr)))] ;(quasisyntax/loc stx
; (define-syntaxes ids #,(on-expr #'expr)))
]
[(define-values-for-syntax ids expr) [(define-values-for-syntax ids expr)
(quasisyntax/loc stx #'(void)
(define-values-for-syntax ids #,(on-expr #'expr)))] ;(quasisyntax/loc stx
; (define-values-for-syntax ids #,(on-expr #'expr)))
]
[else [else
(on-expr stx)])) (on-expr stx)]))

18
get-module-bytecode.rkt
View File

@ -46,8 +46,12 @@
(error 'get-module-bytecode)])) (error 'get-module-bytecode)]))
(with-handlers ([exn? (lambda (exn) (with-handlers ([exn? (lambda (exn)
;(printf "error? ~s\n" (exn-message exn))
(define op (open-output-bytes)) (define op (open-output-bytes))
(write (alternative-f) op) ;(printf "trying alternative to get bytecode\n")
(define bytecode (alternative-f))
;(printf "got the bytecode\n")
(write bytecode op)
(get-output-bytes op))]) (get-output-bytes op))])
(define op (open-output-bytes)) (define op (open-output-bytes))
(write compiled-code op) (write compiled-code op)
@ -57,10 +61,11 @@
(define base-namespace (define base-namespace
(lookup-language-namespace (make-base-namespace))
#;'racket/base ;(lookup-language-namespace
`(file ,(path->string kernel-language-path))) ;;'racket/base
#;(make-base-namespace)) ;;`(file ,(path->string kernel-language-path)))
;(make-base-namespace)))
@ -82,8 +87,11 @@
;; get-compiled-code-from-port: input-port -> compiled-code ;; get-compiled-code-from-port: input-port -> compiled-code
;; Compiles the source from scratch. ;; Compiles the source from scratch.
(define (get-compiled-code-from-port ip) (define (get-compiled-code-from-port ip)
;(printf "get-compiled-code-from-port\n")
(parameterize ([read-accept-reader #t] (parameterize ([read-accept-reader #t]
[current-namespace base-namespace]) [current-namespace base-namespace])
(define stx (read-syntax (object-name ip) ip)) (define stx (read-syntax (object-name ip) ip))
;(printf "got stx; now expanding out the images\n")
(define expanded-stx (expand-out-images stx)) (define expanded-stx (expand-out-images stx))
;(printf "now trying to compile the expanded syntax\n")
(compile expanded-stx))) (compile expanded-stx)))

2
image/private/kernel.js
View File

@ -139,7 +139,7 @@ var makeCanvas = function(width, height) {
// KLUDGE: IE compatibility uses /js/excanvas.js, and dynamic // KLUDGE: IE compatibility uses /js/excanvas.js, and dynamic
// elements must be marked this way. // elements must be marked this way.
if (window && typeof window.G_vmlCanvasManager != 'undefined') { if (window.G_vmlCanvasManager) {
canvas = window.G_vmlCanvasManager.initElement(canvas); canvas = window.G_vmlCanvasManager.initElement(canvas);
} }
return canvas; return canvas;

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

@ -10,15 +10,16 @@
(: assemble-op-expression (PrimitiveOperator -> String)) (: assemble-op-expression (PrimitiveOperator Blockht -> String))
(define (assemble-op-expression op) (define (assemble-op-expression op blockht)
(cond (cond
[(GetCompiledProcedureEntry? op) [(GetCompiledProcedureEntry? op)
"M.proc.label"] "M.p.label"]
[(MakeCompiledProcedure? op) [(MakeCompiledProcedure? op)
(format "new RT.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))
blockht)
(assemble-arity (MakeCompiledProcedure-arity op)) (assemble-arity (MakeCompiledProcedure-arity op))
(string-join (map (string-join (map
assemble-env-reference/closure-capture assemble-env-reference/closure-capture
@ -32,7 +33,8 @@
[(MakeCompiledProcedureShell? op) [(MakeCompiledProcedureShell? op)
(format "new RT.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))
blockht)
(assemble-arity (MakeCompiledProcedureShell-arity op)) (assemble-arity (MakeCompiledProcedureShell-arity op))
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))] (assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
@ -48,7 +50,7 @@
(cond [(DefaultContinuationPromptTag? tag) (cond [(DefaultContinuationPromptTag? tag)
(assemble-default-continuation-prompt-tag)] (assemble-default-continuation-prompt-tag)]
[(OpArg? tag) [(OpArg? tag)
(assemble-oparg tag)])))] (assemble-oparg tag blockht)])))]
[(MakeBoxedEnvironmentValue? op) [(MakeBoxedEnvironmentValue? op)
@ -56,4 +58,4 @@
(add1 (MakeBoxedEnvironmentValue-depth op)))] (add1 (MakeBoxedEnvironmentValue-depth op)))]
[(CallKernelPrimitiveProcedure? op) [(CallKernelPrimitiveProcedure? op)
(open-code-kernel-primitive-procedure op)])) (open-code-kernel-primitive-procedure op blockht)]))

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

@ -4,8 +4,13 @@
"../compiler/expression-structs.rkt" "../compiler/expression-structs.rkt"
"../compiler/lexical-structs.rkt" "../compiler/lexical-structs.rkt"
"../compiler/arity-structs.rkt" "../compiler/arity-structs.rkt"
"assemble-structs.rkt"
racket/list racket/list
racket/string) racket/string
racket/match)
(provide assemble-oparg (provide assemble-oparg
assemble-target assemble-target
@ -14,6 +19,7 @@
assemble-prefix-reference assemble-prefix-reference
assemble-whole-prefix-reference assemble-whole-prefix-reference
assemble-reg assemble-reg
munge-label-name
assemble-label assemble-label
assemble-listof-assembled-values assemble-listof-assembled-values
assemble-default-continuation-prompt-tag assemble-default-continuation-prompt-tag
@ -22,19 +28,21 @@
assemble-jump assemble-jump
assemble-display-name assemble-display-name
assemble-location assemble-location
assemble-numeric-constant) assemble-numeric-constant
block-looks-like-context-expected-values?)
(require/typed typed/racket/base (require/typed typed/racket/base
[regexp-split (Regexp String -> (Listof String))]) [regexp-split (Regexp String -> (Listof String))])
(: assemble-oparg (OpArg -> String)) (: assemble-oparg (OpArg Blockht -> String))
(define (assemble-oparg v) (define (assemble-oparg v blockht)
(cond (cond
[(Reg? v) [(Reg? v)
(assemble-reg v)] (assemble-reg v)]
[(Label? v) [(Label? v)
(assemble-label v)] (assemble-label v blockht)]
[(Const? v) [(Const? v)
(assemble-const v)] (assemble-const v)]
[(EnvLexicalReference? v) [(EnvLexicalReference? v)
@ -44,7 +52,7 @@
[(EnvWholePrefixReference? v) [(EnvWholePrefixReference? v)
(assemble-whole-prefix-reference v)] (assemble-whole-prefix-reference v)]
[(SubtractArg? v) [(SubtractArg? v)
(assemble-subtractarg v)] (assemble-subtractarg v blockht)]
[(ControlStackLabel? v) [(ControlStackLabel? v)
(assemble-control-stack-label v)] (assemble-control-stack-label v)]
[(ControlStackLabel/MultipleValueReturn? v) [(ControlStackLabel/MultipleValueReturn? v)
@ -52,9 +60,9 @@
[(ControlFrameTemporary? v) [(ControlFrameTemporary? v)
(assemble-control-frame-temporary v)] (assemble-control-frame-temporary v)]
[(CompiledProcedureEntry? v) [(CompiledProcedureEntry? v)
(assemble-compiled-procedure-entry v)] (assemble-compiled-procedure-entry v blockht)]
[(CompiledProcedureClosureReference? v) [(CompiledProcedureClosureReference? v)
(assemble-compiled-procedure-closure-reference v)] (assemble-compiled-procedure-closure-reference v blockht)]
[(PrimitiveKernelValue? v) [(PrimitiveKernelValue? v)
(assemble-primitive-kernel-value v)] (assemble-primitive-kernel-value v)]
[(ModuleEntry? v) [(ModuleEntry? v)
@ -69,6 +77,8 @@
(: assemble-target (Target -> (String -> String))) (: assemble-target (Target -> (String -> String)))
(define (assemble-target target) (define (assemble-target target)
(cond (cond
@ -83,9 +93,9 @@
(format "~a=~a;" (format "~a=~a;"
(cond (cond
[(eq? target 'proc) [(eq? target 'proc)
"M.proc"] "M.p"]
[(eq? target 'val) [(eq? target 'val)
"M.val"] "M.v"]
[(eq? target 'argcount) [(eq? target 'argcount)
"M.a"] "M.a"]
[(EnvLexicalReference? target) [(EnvLexicalReference? target)
@ -103,7 +113,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 "M.control[M.control.length-1].~a" (format "M.c[M.c.length-1].~a"
(ControlFrameTemporary-name t))) (ControlFrameTemporary-name t)))
;; fixme: use js->string ;; fixme: use js->string
@ -279,19 +289,18 @@
(let ([name (Reg-name a-reg)]) (let ([name (Reg-name a-reg)])
(cond (cond
[(eq? name 'proc) [(eq? name 'proc)
"M.proc"] "M.p"]
[(eq? name 'val) [(eq? name 'val)
"M.val"] "M.v"]
[(eq? name 'argcount) [(eq? name 'argcount)
"M.a"]))) "M.a"])))
(: munge-label-name (Label -> String))
(: assemble-label (Label -> String)) (define (munge-label-name a-label)
(define (assemble-label a-label) (define chunks
(let ([chunks
(regexp-split #rx"[^a-zA-Z0-9]+" (regexp-split #rx"[^a-zA-Z0-9]+"
(symbol->string (Label-name a-label)))]) (symbol->string (Label-name a-label))))
(cond (cond
[(empty? chunks) [(empty? chunks)
(error "impossible: empty label ~s" a-label)] (error "impossible: empty label ~s" a-label)]
@ -300,39 +309,46 @@
[else [else
(string-append "_" (string-append "_"
(first chunks) (first chunks)
(apply string-append (map string-titlecase (rest chunks))))]))) (apply string-append (map string-titlecase (rest chunks))))]))
(: assemble-subtractarg (SubtractArg -> String)) (: assemble-label (Label Blockht -> String))
(define (assemble-subtractarg s) (define (assemble-label a-label Blockht)
(munge-label-name a-label))
(: assemble-subtractarg (SubtractArg Blockht -> String))
(define (assemble-subtractarg s blockht)
(format "(~a-~a)" (format "(~a-~a)"
(assemble-oparg (SubtractArg-lhs s)) (assemble-oparg (SubtractArg-lhs s) blockht)
(assemble-oparg (SubtractArg-rhs s)))) (assemble-oparg (SubtractArg-rhs s) blockht)))
(: 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)
"M.control[M.control.length-1].label") "M.c[M.c.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)
"M.control[M.control.length-1].label.mvr") "(M.c[M.c.length-1].label.mvr||RT.si_context_expected_1)")
(: assemble-compiled-procedure-entry (CompiledProcedureEntry -> String)) (: assemble-compiled-procedure-entry (CompiledProcedureEntry Blockht -> String))
(define (assemble-compiled-procedure-entry a-compiled-procedure-entry) (define (assemble-compiled-procedure-entry a-compiled-procedure-entry blockht)
(format "(~a).label" (format "(~a).label"
(assemble-oparg (CompiledProcedureEntry-proc a-compiled-procedure-entry)))) (assemble-oparg (CompiledProcedureEntry-proc a-compiled-procedure-entry)
blockht)))
(: assemble-compiled-procedure-closure-reference (CompiledProcedureClosureReference -> String)) (: assemble-compiled-procedure-closure-reference (CompiledProcedureClosureReference Blockht -> String))
(define (assemble-compiled-procedure-closure-reference a-ref) (define (assemble-compiled-procedure-closure-reference a-ref blockht)
(format "(~a).closedVals[(~a).closedVals.length - ~a]" (format "(~a).closedVals[(~a).closedVals.length - ~a]"
(assemble-oparg (CompiledProcedureClosureReference-proc a-ref)) (assemble-oparg (CompiledProcedureClosureReference-proc a-ref) blockht)
(assemble-oparg (CompiledProcedureClosureReference-proc a-ref)) (assemble-oparg (CompiledProcedureClosureReference-proc a-ref) blockht)
(add1 (CompiledProcedureClosureReference-n a-ref)))) (add1 (CompiledProcedureClosureReference-n a-ref))))
@ -379,9 +395,38 @@
(: assemble-jump (OpArg -> String))
(define (assemble-jump target) (: assemble-jump (OpArg Blockht -> String))
(format "return(~a)(M);" (assemble-oparg target))) (define (assemble-jump target blockht)
(define (default)
(format "return(~a)(M);" (assemble-oparg target blockht)))
;; Optimization: if the target of the jump goes to a block whose
;; only body is a si-context-expected_1, then jump directly to that code.
(cond
[(Label? target)
(define target-block (hash-ref blockht (Label-name target)))
(cond
[(block-looks-like-context-expected-values? target-block)
=>
(lambda (expected)
(format "RT.si_context_expected(~a)(M);\n" expected))]
[else
(default)])]
[else
(default)]))
(: block-looks-like-context-expected-values? (BasicBlock -> (U Natural False)))
(define (block-looks-like-context-expected-values? a-block)
(match (BasicBlock-stmts a-block)
[(list (struct PerformStatement ((struct RaiseContextExpectedValuesError! (expected))))
stmts ...)
expected]
[else
#f]))
@ -399,13 +444,13 @@
(: assemble-location ((U Reg Label) -> String)) (: assemble-location ((U Reg Label) Blockht -> String))
(define (assemble-location a-location) (define (assemble-location a-location blockht)
(cond (cond
[(Reg? a-location) [(Reg? a-location)
(assemble-reg a-location)] (assemble-reg a-location)]
[(Label? a-location) [(Label? a-location)
(assemble-label a-location)])) (assemble-label a-location blockht)]))
(: assemble-primitive-kernel-value (PrimitiveKernelValue -> String)) (: assemble-primitive-kernel-value (PrimitiveKernelValue -> String))

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

@ -4,6 +4,7 @@
"../compiler/il-structs.rkt" "../compiler/il-structs.rkt"
"../compiler/lexical-structs.rkt" "../compiler/lexical-structs.rkt"
"../compiler/kernel-primitives.rkt" "../compiler/kernel-primitives.rkt"
"assemble-structs.rkt"
racket/string racket/string
racket/list racket/list
typed/rackunit) typed/rackunit)
@ -12,10 +13,12 @@
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String)) (: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure Blockht -> String))
(define (open-code-kernel-primitive-procedure op) (define (open-code-kernel-primitive-procedure op blockht)
(let*: ([operator : KernelPrimitiveName/Inline (CallKernelPrimitiveProcedure-operator op)] (let*: ([operator : KernelPrimitiveName/Inline (CallKernelPrimitiveProcedure-operator op)]
[operands : (Listof String) (map assemble-oparg (CallKernelPrimitiveProcedure-operands op))] [operands : (Listof String) (map (lambda: ([op : OpArg])
(assemble-oparg op blockht))
(CallKernelPrimitiveProcedure-operands op))]
[checked-operands : (Listof String) [checked-operands : (Listof String)
(map (lambda: ([dom : OperandDomain] (map (lambda: ([dom : OperandDomain]
[pos : Natural] [pos : Natural]

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

@ -3,14 +3,15 @@
"../compiler/il-structs.rkt" "../compiler/il-structs.rkt"
"../compiler/lexical-structs.rkt" "../compiler/lexical-structs.rkt"
"../parameters.rkt" "../parameters.rkt"
"assemble-structs.rkt"
racket/string) racket/string)
(provide assemble-op-statement) (provide assemble-op-statement)
(: assemble-op-statement (PrimitiveCommand -> String)) (: assemble-op-statement (PrimitiveCommand Blockht -> String))
(define (assemble-op-statement op) (define (assemble-op-statement op blockht)
(cond (cond
[(CheckToplevelBound!? op) [(CheckToplevelBound!? op)
@ -70,7 +71,7 @@
",")))] ",")))]
[(InstallClosureValues!? op) [(InstallClosureValues!? op)
"M.e.push.apply(M.e,M.proc.closedVals);"] "M.e.push.apply(M.e,M.p.closedVals);"]
[(RestoreEnvironment!? op) [(RestoreEnvironment!? op)
"M.e=M.e[M.e.length-2].slice(0);"] "M.e=M.e[M.e.length-2].slice(0);"]
@ -83,7 +84,7 @@
[(DefaultContinuationPromptTag? tag) [(DefaultContinuationPromptTag? tag)
(assemble-default-continuation-prompt-tag)] (assemble-default-continuation-prompt-tag)]
[(OpArg? tag) [(OpArg? tag)
(assemble-oparg tag)])))] (assemble-oparg tag blockht)])))]
[(FixClosureShellMap!? op) [(FixClosureShellMap!? op)
(format "M.e[M.e.length-~a].closedVals=[~a];" (format "M.e[M.e.length-~a].closedVals=[~a];"
@ -98,22 +99,24 @@
","))] ","))]
[(SetFrameCallee!? op) [(SetFrameCallee!? op)
(format "M.control[M.control.length-1].proc=~a;" (format "M.c[M.c.length-1].p=~a;"
(assemble-oparg (SetFrameCallee!-proc op)))] (assemble-oparg (SetFrameCallee!-proc op)
blockht))]
[(SpliceListIntoStack!? op) [(SpliceListIntoStack!? op)
(format "M.spliceListIntoStack(~a);" (format "M.spliceListIntoStack(~a);"
(assemble-oparg (SpliceListIntoStack!-depth op)))] (assemble-oparg (SpliceListIntoStack!-depth op)
blockht))]
[(UnspliceRestFromStack!? op) [(UnspliceRestFromStack!? op)
(format "M.unspliceRestFromStack(~a,~a);" (format "M.unspliceRestFromStack(~a,~a);"
(assemble-oparg (UnspliceRestFromStack!-depth op)) (assemble-oparg (UnspliceRestFromStack!-depth op) blockht)
(assemble-oparg (UnspliceRestFromStack!-length op)))] (assemble-oparg (UnspliceRestFromStack!-length op) blockht))]
[(InstallContinuationMarkEntry!? op) [(InstallContinuationMarkEntry!? op)
(string-append "M.installContinuationMarkEntry(" (string-append "M.installContinuationMarkEntry("
"M.control[M.control.length-1].pendingContinuationMarkKey," "M.c[M.c.length-1].pendingContinuationMarkKey,"
"M.val);")] "M.v);")]
[(RaiseContextExpectedValuesError!? op) [(RaiseContextExpectedValuesError!? op)
(format "RT.raiseContextExpectedValuesError(M,~a);" (format "RT.raiseContextExpectedValuesError(M,~a);"
@ -122,13 +125,13 @@
[(RaiseArityMismatchError!? op) [(RaiseArityMismatchError!? op)
(format "RT.raiseArityMismatchError(M,~a,~a);" (format "RT.raiseArityMismatchError(M,~a,~a);"
(assemble-oparg (RaiseArityMismatchError!-proc op)) (assemble-oparg (RaiseArityMismatchError!-proc op) blockht)
(assemble-oparg (RaiseArityMismatchError!-received op)))] (assemble-oparg (RaiseArityMismatchError!-received op) blockht))]
[(RaiseOperatorApplicationError!? op) [(RaiseOperatorApplicationError!? op)
(format "RT.raiseOperatorApplicationError(M,~a);" (format "RT.raiseOperatorApplicationError(M,~a);"
(assemble-oparg (RaiseOperatorApplicationError!-operator op)))] (assemble-oparg (RaiseOperatorApplicationError!-operator op) blockht))]
[(RaiseUnimplementedPrimitiveError!? op) [(RaiseUnimplementedPrimitiveError!? op)
@ -140,7 +143,8 @@
(format "M.modules[~s]=new RT.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))
blockht))]
[(MarkModuleInvoked!? op) [(MarkModuleInvoked!? op)
(format "M.modules[~s].isInvoked=true;" (format "M.modules[~s].isInvoked=true;"

5
js-assembler/assemble-structs.rkt
View File

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

183
js-assembler/assemble.rkt
View File

@ -8,7 +8,6 @@
"assemble-helpers.rkt" "assemble-helpers.rkt"
"assemble-expression.rkt" "assemble-expression.rkt"
"assemble-perform-statement.rkt" "assemble-perform-statement.rkt"
"optimize-basic-blocks.rkt"
"fracture.rkt" "fracture.rkt"
"../compiler/il-structs.rkt" "../compiler/il-structs.rkt"
"../sets.rkt" "../sets.rkt"
@ -30,8 +29,6 @@
(define current-emit-debug-trace? (make-parameter #f)) (define current-emit-debug-trace? (make-parameter #f))
;; Represents a hashtable from symbols to basic blocks
(define-type Blockht (HashTable Symbol BasicBlock))
@ -49,12 +46,19 @@
(define function-entry-and-exit-names (define function-entry-and-exit-names
(list->set (get-function-entry-and-exit-names stmts))) (list->set (get-function-entry-and-exit-names stmts)))
(: blockht : Blockht)
(define blockht (make-hash))
(for ([b basic-blocks])
(hash-set! blockht (BasicBlock-name b) b))
(write-blocks basic-blocks (write-blocks basic-blocks
blockht
(list->set entry-points) (list->set entry-points)
function-entry-and-exit-names function-entry-and-exit-names
op) op)
(write-linked-label-attributes stmts op) (write-linked-label-attributes stmts blockht op)
(display "M.params.currentErrorHandler = fail;\n" op) (display "M.params.currentErrorHandler = fail;\n" op)
(display "M.params.currentSuccessHandler = success;\n" op) (display "M.params.currentSuccessHandler = success;\n" op)
@ -67,18 +71,14 @@ for (param in params) {
EOF EOF
op) op)
(fprintf op "M.trampoline(~a, true); })" (fprintf op "M.trampoline(~a, true); })"
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))))) (assemble-label (make-Label (BasicBlock-name (first basic-blocks)))
blockht)))
(: write-blocks ((Listof BasicBlock) (Setof Symbol) (Setof Symbol) Output-Port -> Void)) (: write-blocks ((Listof BasicBlock) Blockht (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 function-entry-and-exit-names op) (define (write-blocks blocks blockht entry-points function-entry-and-exit-names op)
(: blockht : Blockht)
(define blockht (make-hash))
(for ([b blocks])
(hash-set! blockht (BasicBlock-name b) b))
;; Since there may be cycles between the blocks, we cut the cycles by ;; Since there may be cycles between the blocks, we cut the cycles by
;; making them entry points as well. ;; making them entry points as well.
@ -125,24 +125,39 @@ EOF
(: write-linked-label-attributes ((Listof Statement) Output-Port -> 'ok)) (: write-linked-label-attributes ((Listof Statement) Blockht Output-Port -> 'ok))
(define (write-linked-label-attributes stmts op) (define (write-linked-label-attributes stmts blockht op)
(cond (cond
[(empty? stmts) [(empty? stmts)
'ok] 'ok]
[else [else
(let: ([stmt : Statement (first stmts)]) (let: ([stmt : Statement (first stmts)])
(define (next) (write-linked-label-attributes (rest stmts) op)) (define (next) (write-linked-label-attributes (rest stmts) blockht op))
(cond (cond
[(symbol? stmt) [(symbol? stmt)
(next)] (next)]
[(LinkedLabel? stmt) [(LinkedLabel? stmt)
;; Setting up multiple-value-return ;; Setting up multiple-value-return.
;; Optimization: in the most common case (expecting only one), we optimize away
;; the assignment, because there's a distinguished instruction, and it's implied
;; that if .mvr is missing, that the block only expects one.
(define linked-to-block (hash-ref blockht (LinkedLabel-linked-to stmt)))
(cond
[(block-looks-like-context-expected-values? linked-to-block)
=> (lambda (expected)
(cond
[(= expected 1)
(void)]
[else
(fprintf op "~a.mvr=RT.si_context_expected(~a);\n"
(munge-label-name (make-Label (LinkedLabel-label stmt)))
expected)]))]
[else
(fprintf op "~a.mvr=~a;\n" (fprintf op "~a.mvr=~a;\n"
(assemble-label (make-Label (LinkedLabel-label stmt))) (munge-label-name (make-Label (LinkedLabel-label stmt)))
(assemble-label (make-Label (LinkedLabel-linked-to stmt)))) (assemble-label (make-Label (LinkedLabel-linked-to stmt)) blockht))])
(next)] (next)]
[(DebugPrint? stmt) [(DebugPrint? stmt)
(next)] (next)]
@ -180,13 +195,18 @@ EOF
(: assemble-basic-block (BasicBlock Blockht (Setof Symbol) (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 function-entry-and-exit-names op) (define (assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)
(match (BasicBlock-stmts a-basic-block) (cond
[(list (struct PerformStatement ((struct RaiseContextExpectedValuesError! (expected)))) [(block-looks-like-context-expected-values? a-basic-block)
stmts ...) =>
(fprintf op "~a=RT.si_context_expected(~a);\n" (lambda (expected)
(assemble-label (make-Label (BasicBlock-name a-basic-block))) (cond
expected) [(= expected 1)
'ok] 'ok]
[else
(fprintf op "~a=RT.si_context_expected(~a);\n"
(munge-label-name (make-Label (BasicBlock-name a-basic-block)))
expected)
'ok]))]
[else [else
(default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)])) (default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
@ -197,11 +217,11 @@ EOF
(cond (cond
[(set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block)) [(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" (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)) blockht)
(assemble-label (make-Label (BasicBlock-name a-basic-block))))] (assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht))]
[else [else
(fprintf op "var ~a=function(M){--M.cbt<0;\n" (fprintf op "var ~a=function(M){--M.cbt<0;\n"
(assemble-label (make-Label (BasicBlock-name a-basic-block))))]) (assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht))])
(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
@ -222,7 +242,7 @@ EOF
(not (GotoStatement? stmt))) (not (GotoStatement? stmt)))
(log-debug (format "Last statement of the block ~a is not a goto" name))) (log-debug (format "Last statement of the block ~a is not a goto" name)))
(display (assemble-statement stmt) op) (display (assemble-statement stmt blockht) op)
(newline op) (newline op)
(assemble-block-statements name (assemble-block-statements name
(rest stmts) (rest stmts)
@ -254,30 +274,33 @@ EOF
(define test-code (cond (define test-code (cond
[(TestFalse? test) [(TestFalse? test)
(format "if(~a===false)" (format "if(~a===false)"
(assemble-oparg (TestFalse-operand test)))] (assemble-oparg (TestFalse-operand test)
blockht))]
[(TestTrue? test) [(TestTrue? test)
(format "if(~a!==false)" (format "if(~a!==false)"
(assemble-oparg (TestTrue-operand test)))] (assemble-oparg (TestTrue-operand test)
blockht))]
[(TestOne? test) [(TestOne? test)
(format "if(~a===1)" (format "if(~a===1)"
(assemble-oparg (TestOne-operand test)))] (assemble-oparg (TestOne-operand test)
blockht))]
[(TestZero? test) [(TestZero? test)
(format "if(~a===0)" (format "if(~a===0)"
(assemble-oparg (TestZero-operand test)))] (assemble-oparg (TestZero-operand test)
blockht))]
;; [(TestPrimitiveProcedure? test)
;; (format "if(typeof(~a)==='function')"
;; (assemble-oparg (TestPrimitiveProcedure-operand test)))]
[(TestClosureArityMismatch? test) [(TestClosureArityMismatch? test)
(format "if(!RT.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)))])) blockht)
(assemble-oparg (TestClosureArityMismatch-n test)
blockht))]))
(display test-code op) (display test-code op)
(display "{" op) (display "{" op)
(cond (cond
[(set-contains? entry-points (TestAndJumpStatement-label stmt)) [(set-contains? entry-points (TestAndJumpStatement-label stmt))
(display (assemble-jump (make-Label (TestAndJumpStatement-label stmt))) op)] (display (assemble-jump (make-Label (TestAndJumpStatement-label stmt))
blockht) op)]
[else [else
(assemble-block-statements (BasicBlock-name (assemble-block-statements (BasicBlock-name
(hash-ref blockht (TestAndJumpStatement-label stmt))) (hash-ref blockht (TestAndJumpStatement-label stmt)))
@ -307,7 +330,7 @@ EOF
(GotoStatement? (first target-statements))) (GotoStatement? (first target-statements)))
(loop (first target-statements))] (loop (first target-statements))]
[(set-contains? entry-points (Label-name target)) [(set-contains? entry-points (Label-name target))
(display (assemble-statement stmt) op) (display (assemble-statement stmt blockht) op)
'ok] 'ok]
[else [else
(log-debug (format "Assembling inlined jump into ~a" (Label-name target)) ) (log-debug (format "Assembling inlined jump into ~a" (Label-name target)) )
@ -317,13 +340,13 @@ EOF
entry-points entry-points
op)])] op)])]
[(Reg? target) [(Reg? target)
(display (assemble-statement stmt) op) (display (assemble-statement stmt blockht) op)
'ok] 'ok]
[(ModuleEntry? target) [(ModuleEntry? target)
(display (assemble-statement stmt) op) (display (assemble-statement stmt blockht) op)
'ok] 'ok]
[(CompiledProcedureEntry? target) [(CompiledProcedureEntry? target)
(display (assemble-statement stmt) op) (display (assemble-statement stmt blockht) op)
'ok]))] 'ok]))]
@ -430,79 +453,93 @@ EOF
(: assemble-statement (UnlabeledStatement -> String)) (: assemble-statement (UnlabeledStatement Blockht -> String))
;; Generates the code to assemble a statement. ;; Generates the code to assemble a statement.
(define (assemble-statement stmt) (define (assemble-statement stmt blockht)
(define assembled (define assembled
(cond (cond
[(DebugPrint? stmt) [(DebugPrint? stmt)
(format "M.params.currentOutputPort.writeDomNode(M, $('<span/>').text(~a));" (format "M.params.currentOutputPort.writeDomNode(M, $('<span/>').text(~a));"
(assemble-oparg (DebugPrint-value stmt)))] (assemble-oparg (DebugPrint-value stmt)
blockht))]
[(AssignImmediateStatement? stmt) [(AssignImmediateStatement? stmt)
(let: ([t : (String -> String) (assemble-target (AssignImmediateStatement-target stmt))] (let: ([t : (String -> String) (assemble-target (AssignImmediateStatement-target stmt))]
[v : OpArg (AssignImmediateStatement-value stmt)]) [v : OpArg (AssignImmediateStatement-value stmt)])
(t (assemble-oparg v)))] (t (assemble-oparg v blockht)))]
[(AssignPrimOpStatement? stmt) [(AssignPrimOpStatement? stmt)
((assemble-target (AssignPrimOpStatement-target stmt)) ((assemble-target (AssignPrimOpStatement-target stmt))
(assemble-op-expression (AssignPrimOpStatement-op stmt)))] (assemble-op-expression (AssignPrimOpStatement-op stmt)
blockht))]
[(PerformStatement? stmt) [(PerformStatement? stmt)
(assemble-op-statement (PerformStatement-op stmt))] (assemble-op-statement (PerformStatement-op stmt) blockht)]
[(TestAndJumpStatement? stmt) [(TestAndJumpStatement? stmt)
(let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)] (let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)]
[jump : String (assemble-jump [jump : String (assemble-jump
(make-Label (TestAndJumpStatement-label stmt)))]) (make-Label (TestAndJumpStatement-label stmt))
blockht)])
;; to help localize type checks, we add a type annotation here. ;; to help localize type checks, we add a type annotation here.
(ann (cond (ann (cond
[(TestFalse? test) [(TestFalse? test)
(format "if(~a===false){~a}" (format "if(~a===false){~a}"
(assemble-oparg (TestFalse-operand test)) (assemble-oparg (TestFalse-operand test)
blockht)
jump)] jump)]
[(TestTrue? test) [(TestTrue? test)
(format "if(~a!==false){~a}" (format "if(~a!==false){~a}"
(assemble-oparg (TestTrue-operand test)) (assemble-oparg (TestTrue-operand test)
blockht)
jump)] jump)]
[(TestOne? test) [(TestOne? test)
(format "if(~a===1){~a}" (format "if(~a===1){~a}"
(assemble-oparg (TestOne-operand test)) (assemble-oparg (TestOne-operand test)
blockht)
jump)] jump)]
[(TestZero? test) [(TestZero? test)
(format "if(~a===0){~a}" (format "if(~a===0){~a}"
(assemble-oparg (TestZero-operand test)) (assemble-oparg (TestZero-operand test)
blockht)
jump)] jump)]
[(TestClosureArityMismatch? test) [(TestClosureArityMismatch? test)
(format "if(!RT.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)) blockht)
(assemble-oparg (TestClosureArityMismatch-n test)
blockht)
jump)]) jump)])
String))] String))]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(assemble-jump (GotoStatement-target stmt))] (assemble-jump (GotoStatement-target stmt)
blockht)]
[(PushControlFrame/Generic? stmt) [(PushControlFrame/Generic? stmt)
"M.control.push(new RT.Frame());"] "M.c.push(new RT.Frame());"]
[(PushControlFrame/Call? stmt) [(PushControlFrame/Call? stmt)
(format "M.control.push(new RT.CallFrame(~a,M.proc));" (format "M.c.push(new RT.CallFrame(~a,M.p));"
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)]) (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
(cond (cond
[(symbol? label) [(symbol? label)
(assemble-label (make-Label label))] (assemble-label (make-Label label)
blockht)]
[(LinkedLabel? label) [(LinkedLabel? label)
(assemble-label (make-Label (LinkedLabel-label label)))])))] (assemble-label (make-Label (LinkedLabel-label label))
blockht)])))]
[(PushControlFrame/Prompt? stmt) [(PushControlFrame/Prompt? stmt)
;; fixme: use a different frame structure ;; fixme: use a different frame structure
(format "M.control.push(new RT.PromptFrame(~a,~a));" (format "M.c.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)
(assemble-label (make-Label label))] (assemble-label (make-Label label)
blockht)]
[(LinkedLabel? label) [(LinkedLabel? label)
(assemble-label (make-Label (LinkedLabel-label label)))])) (assemble-label (make-Label (LinkedLabel-label label))
blockht)]))
(let: ([tag : (U DefaultContinuationPromptTag OpArg) (let: ([tag : (U DefaultContinuationPromptTag OpArg)
(PushControlFrame/Prompt-tag stmt)]) (PushControlFrame/Prompt-tag stmt)])
@ -510,10 +547,10 @@ EOF
[(DefaultContinuationPromptTag? tag) [(DefaultContinuationPromptTag? tag)
(assemble-default-continuation-prompt-tag)] (assemble-default-continuation-prompt-tag)]
[(OpArg? tag) [(OpArg? tag)
(assemble-oparg tag)])))] (assemble-oparg tag blockht)])))]
[(PopControlFrame? stmt) [(PopControlFrame? stmt)
"M.control.pop();"] "M.c.pop();"]
[(PushEnvironment? stmt) [(PushEnvironment? stmt)
(cond [(= (PushEnvironment-n stmt) 0) (cond [(= (PushEnvironment-n stmt) 0)
@ -531,20 +568,22 @@ EOF
(cond (cond
[(and (Const? skip) (= (ensure-natural (Const-const skip)) 0)) [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
(format "M.e.length-=~a;" (format "M.e.length-=~a;"
(assemble-oparg (PopEnvironment-n stmt)))] (assemble-oparg (PopEnvironment-n stmt) blockht))]
[else [else
(format "M.e.splice(M.e.length-(~a+~a),~a);" (format "M.e.splice(M.e.length-(~a+~a),~a);"
(assemble-oparg (PopEnvironment-skip stmt)) (assemble-oparg (PopEnvironment-skip stmt) blockht)
(assemble-oparg (PopEnvironment-n stmt)) (assemble-oparg (PopEnvironment-n stmt) blockht)
(assemble-oparg (PopEnvironment-n stmt)))]))] (assemble-oparg (PopEnvironment-n stmt) blockht))]))]
[(PushImmediateOntoEnvironment? stmt) [(PushImmediateOntoEnvironment? stmt)
(format "M.e.push(~a);" (format "M.e.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)
blockht))]
[else [else
(assemble-oparg (PushImmediateOntoEnvironment-value stmt))])]) (assemble-oparg (PushImmediateOntoEnvironment-value stmt)
blockht)])])
val-string))] val-string))]
[(Comment? stmt) [(Comment? stmt)
;; TODO: maybe comments should be emitted as JavaScript comments. ;; TODO: maybe comments should be emitted as JavaScript comments.

75
js-assembler/optimize-basic-blocks.rkt
View File

@ -1,75 +0,0 @@
#lang typed/racket/base
;; Does some basic optimizations at the level of basic blocks.
(require "assemble-structs.rkt"
"../compiler/il-structs.rkt"
racket/list)
(require/typed "../logger.rkt" [log-debug (String -> Void)])
(provide optimize-basic-blocks)
(define-type Blockht (HashTable Symbol BasicBlock))
;; We want maps from unlabeled statements to their respective blocks.
(define-type Bodyht (HashTable (Listof UnlabeledStatement) (Listof Symbol)))
(: optimize-basic-blocks ((Listof BasicBlock) -> (Listof BasicBlock)))
(define (optimize-basic-blocks blocks)
(: blockht : Blockht)
(define blockht (make-hasheq))
(: bodyht : Bodyht)
(define bodyht (make-hasheq))
;; First, scan through the blocks, and pick up their names and bodies.
(for ([b blocks])
(hash-set! blockht (BasicBlock-name b) b)
(when (hash-has-key? bodyht (BasicBlock-stmts b))
(log-debug (format "block ~a has the same content as another block" (BasicBlock-name b))))
(hash-set! bodyht (BasicBlock-stmts b)
(cons (BasicBlock-name b)
(hash-ref bodyht (BasicBlock-stmts b) (lambda () '())))))
blocks
#;(define inlined-blocks
(map (lambda: ([b : BasicBlock])
(optimize-block b blockht))
blocks))
#;inlined-blocks)
(: optimize-block (BasicBlock Blockht -> BasicBlock))
;; Simple optimization: optimize away single-statement goto blocks with their
;; immediate contents.
(define (optimize-block b blocks)
(define stmts (BasicBlock-stmts b))
(cond
[(= (length stmts) 1)
(define first-stmt (first stmts))
(cond
[(GotoStatement? first-stmt)
(define target (GotoStatement-target first-stmt))
(cond
[(Label? target)
(log-debug (format "inlining basic block ~a" (BasicBlock-name b)))
(optimize-block (make-BasicBlock (BasicBlock-name b)
(BasicBlock-stmts
(hash-ref blocks (Label-name target))))
blocks)]
[else
b])]
[else
b])]
[else
b]))

2
js-assembler/package.rkt
View File

@ -164,7 +164,7 @@
(function(MACHINE, EXPORTS){~a})(M, exports); (function(MACHINE, EXPORTS){~a})(M, exports);
~a ~a
modrec.privateExports = exports; modrec.privateExports = exports;
return M.control.pop().label(M);" return M.c.pop().label(M);"
(symbol->string name) (symbol->string name)
text text
(get-provided-name-code bytecode))]) (get-provided-name-code bytecode))])

2
js-assembler/runtime-src/baselib-arity.js
View File

@ -41,7 +41,7 @@
while (arity !== baselib.lists.EMPTY) { while (arity !== baselib.lists.EMPTY) {
if (typeof(arity.first) === 'number') { if (typeof(arity.first) === 'number') {
if (arity.first === n) { return true; } if (arity.first === n) { return true; }
} else if (isArityAtLeast(arity)) { } else if (isArityAtLeast(arity.first)) {
if (n >= arityAtLeastValue(arity.first)) { return true; } if (n >= arityAtLeastValue(arity.first)) { return true; }
} }
arity = arity.rest; arity = arity.rest;

2
js-assembler/runtime-src/baselib-frames.js
View File

@ -31,7 +31,7 @@
// as well as the function being called. // as well as the function being called.
var CallFrame = function(label, proc) { var CallFrame = function(label, proc) {
this.label = label; this.label = label;
this.proc = proc; this.p = proc;
// The set of continuation marks. // The set of continuation marks.
this.marks = []; this.marks = [];

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

@ -68,16 +68,16 @@
MACHINE.e.length -= MACHINE.a; MACHINE.e.length -= MACHINE.a;
if (returnArgs.length === 1) { if (returnArgs.length === 1) {
MACHINE.val = returnArgs[0]; MACHINE.v = returnArgs[0];
return MACHINE.control.pop().label(MACHINE); return MACHINE.c.pop().label(MACHINE);
} else if (returnArgs.length === 0) { } else if (returnArgs.length === 0) {
MACHINE.a = 0; MACHINE.a = 0;
return MACHINE.control.pop().label.mvr(MACHINE); return (MACHINE.c.pop().label.mvr || plt.runtime.si_context_expected_1)(MACHINE);
} else { } else {
MACHINE.a = returnArgs.length; MACHINE.a = returnArgs.length;
MACHINE.val = returnArgs.shift(); MACHINE.v = returnArgs.shift();
MACHINE.e.push.apply(MACHINE.e, returnArgs.reverse()); MACHINE.e.push.apply(MACHINE.e, returnArgs.reverse());
return MACHINE.control.pop().label.mvr(MACHINE); return (MACHINE.c.pop().label.mvr || plt.runtime.si_context_expected_1)(MACHINE);
} }
}; };
@ -148,19 +148,19 @@
MACHINE.captureContinuationMarks()))); MACHINE.captureContinuationMarks())));
} }
var oldVal = MACHINE.val; var oldVal = MACHINE.v;
var oldArgcount = MACHINE.a; var oldArgcount = MACHINE.a;
var oldProc = MACHINE.proc; var oldProc = MACHINE.p;
var oldErrorHandler = MACHINE.params['currentErrorHandler']; var oldErrorHandler = MACHINE.params['currentErrorHandler'];
var afterGoodInvoke = function (MACHINE) { var afterGoodInvoke = function (MACHINE) {
plt.runtime.PAUSE( plt.runtime.PAUSE(
function (restart) { function (restart) {
MACHINE.params['currentErrorHandler'] = oldErrorHandler; MACHINE.params['currentErrorHandler'] = oldErrorHandler;
var returnValue = MACHINE.val; var returnValue = MACHINE.v;
MACHINE.val = oldVal; MACHINE.v = oldVal;
MACHINE.a = oldArgcount; MACHINE.a = oldArgcount;
MACHINE.proc = oldProc; MACHINE.p = oldProc;
succ(returnValue); succ(returnValue);
}); });
}; };
@ -168,30 +168,30 @@
plt.runtime.PAUSE( plt.runtime.PAUSE(
function (restart) { function (restart) {
MACHINE.params['currentErrorHandler'] = oldErrorHandler; MACHINE.params['currentErrorHandler'] = oldErrorHandler;
var returnValues = [MACHINE.val], i; var returnValues = [MACHINE.v], i;
for (i = 0; i < MACHINE.a - 1; i++) { for (i = 0; i < MACHINE.a - 1; i++) {
returnValues.push(MACHINE.e.pop()); returnValues.push(MACHINE.e.pop());
} }
MACHINE.val = oldVal; MACHINE.v = oldVal;
MACHINE.a = oldArgcount; MACHINE.a = oldArgcount;
MACHINE.proc = oldProc; MACHINE.p = oldProc;
succ.apply(null, returnValues); succ.apply(null, returnValues);
}); });
}; };
MACHINE.control.push( MACHINE.c.push(
new baselib.frames.CallFrame(afterGoodInvoke, v)); new baselib.frames.CallFrame(afterGoodInvoke, v));
MACHINE.a = arguments.length - 2; MACHINE.a = arguments.length - 2;
var i; var i;
for (i = 0; i < arguments.length - 2; i++) { for (i = 0; i < arguments.length - 2; i++) {
MACHINE.e.push(arguments[arguments.length - 1 - i]); MACHINE.e.push(arguments[arguments.length - 1 - i]);
} }
MACHINE.proc = v; MACHINE.p = v;
MACHINE.params['currentErrorHandler'] = function (MACHINE, e) { MACHINE.params['currentErrorHandler'] = function (MACHINE, e) {
MACHINE.params['currentErrorHandler'] = oldErrorHandler; MACHINE.params['currentErrorHandler'] = oldErrorHandler;
MACHINE.val = oldVal; MACHINE.v = oldVal;
MACHINE.a = oldArgcount; MACHINE.a = oldArgcount;
MACHINE.proc = oldProc; MACHINE.p = oldProc;
fail(e); fail(e);
}; };
MACHINE.trampoline(v.label); MACHINE.trampoline(v.label);
@ -246,48 +246,48 @@
} }
success(result); success(result);
} else if (isClosure(proc)) { } else if (isClosure(proc)) {
oldVal = MACHINE.val; oldVal = MACHINE.v;
oldArgcount = MACHINE.a; oldArgcount = MACHINE.a;
oldProc = MACHINE.proc; oldProc = MACHINE.p;
oldErrorHandler = MACHINE.params['currentErrorHandler']; oldErrorHandler = MACHINE.params['currentErrorHandler'];
var afterGoodInvoke = function (MACHINE) { var afterGoodInvoke = function (MACHINE) {
plt.runtime.PAUSE(function (restart) { plt.runtime.PAUSE(function (restart) {
MACHINE.params['currentErrorHandler'] = oldErrorHandler; MACHINE.params['currentErrorHandler'] = oldErrorHandler;
var returnValue = MACHINE.val; var returnValue = MACHINE.v;
MACHINE.val = oldVal; MACHINE.v = oldVal;
MACHINE.a = oldArgcount; MACHINE.a = oldArgcount;
MACHINE.proc = oldProc; MACHINE.p = oldProc;
success(returnValue); success(returnValue);
}); });
}; };
afterGoodInvoke.mvr = function (MACHINE) { afterGoodInvoke.mvr = function (MACHINE) {
plt.runtime.PAUSE(function (restart) { plt.runtime.PAUSE(function (restart) {
MACHINE.params['currentErrorHandler'] = oldErrorHandler; MACHINE.params['currentErrorHandler'] = oldErrorHandler;
var returnValues = [MACHINE.val]; var returnValues = [MACHINE.v];
var i; var i;
for (i = 0; i < MACHINE.a - 1; i++) { for (i = 0; i < MACHINE.a - 1; i++) {
returnValues.push(MACHINE.e.pop()); returnValues.push(MACHINE.e.pop());
} }
MACHINE.val = oldVal; MACHINE.v = oldVal;
MACHINE.a = oldArgcount; MACHINE.a = oldArgcount;
MACHINE.proc = oldProc; MACHINE.p = oldProc;
success.apply(null, returnValues); success.apply(null, returnValues);
}); });
}; };
MACHINE.control.push( MACHINE.c.push(
new baselib.frames.CallFrame(afterGoodInvoke, proc)); new baselib.frames.CallFrame(afterGoodInvoke, proc));
MACHINE.a = arguments.length - 4; MACHINE.a = arguments.length - 4;
for (i = 0; i < arguments.length - 4; i++) { for (i = 0; i < arguments.length - 4; i++) {
MACHINE.e.push(arguments[arguments.length - 1 - i]); MACHINE.e.push(arguments[arguments.length - 1 - i]);
} }
MACHINE.proc = proc; MACHINE.p = proc;
MACHINE.params['currentErrorHandler'] = function (MACHINE, e) { MACHINE.params['currentErrorHandler'] = function (MACHINE, e) {
MACHINE.params['currentErrorHandler'] = oldErrorHandler; MACHINE.params['currentErrorHandler'] = oldErrorHandler;
MACHINE.val = oldVal; MACHINE.v = oldVal;
MACHINE.a = oldArgcount; MACHINE.a = oldArgcount;
MACHINE.proc = oldProc; MACHINE.p = oldProc;
fail(e); fail(e);
}; };
MACHINE.trampoline(proc.label); MACHINE.trampoline(proc.label);
@ -324,9 +324,9 @@
arity, arity,
function(M) { function(M) {
--M.cbt; --M.cbt;
M.val = f(M); M.v = f(M);
M.e.length -= M.a; M.e.length -= M.a;
return M.control.pop().label(M); return M.c.pop().label(M);
}, },
[]); []);
}; };

2
js-assembler/runtime-src/baselib-modules.js
View File

@ -66,7 +66,7 @@
MACHINE.params['currentErrorHandler'] = oldErrorHandler; MACHINE.params['currentErrorHandler'] = oldErrorHandler;
fail(MACHINE, anError); fail(MACHINE, anError);
}; };
MACHINE.control.push(new plt.baselib.frames.CallFrame(afterGoodInvoke, null)); MACHINE.c.push(new plt.baselib.frames.CallFrame(afterGoodInvoke, null));
if (isInternal) { if (isInternal) {
throw that.label; throw that.label;
} else { } else {

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

@ -1150,7 +1150,7 @@
checkList(M, 'apply', M.a - 1); checkList(M, 'apply', M.a - 1);
M.spliceListIntoStack(M.a - 1); M.spliceListIntoStack(M.a - 1);
if (baselib.arity.isArityMatching(proc.racketArity, M.a)) { if (baselib.arity.isArityMatching(proc.racketArity, M.a)) {
M.proc = proc; M.p = proc;
if (baselib.functions.isPrimitiveProcedure(proc)) { if (baselib.functions.isPrimitiveProcedure(proc)) {
return finalizeClosureCall(M, proc(M)); return finalizeClosureCall(M, proc(M));
} else { } else {

513
js-assembler/runtime-src/helpers.js
View File

@ -1,513 +0,0 @@
// Helper functions for whalesong.
//
// Note: this originally came from js-vm, and may have cruft that
// doesn't belong in whalesong. I need to clean this up.
if (! this['plt']) { this['plt'] = {}; }
// Helpers library: includes a bunch of helper functions that will be used
//
//
// FIXME: there's a circularity between this module and types, and that circularly
// should not be there!
//////////////////////////////////////////////////////////////
// File of helper functions for primitives and world.
(function(scope) {
var helpers = {};
scope.helpers = helpers;
// types refers to plt.types, and will be initialized later.
var types = scope['types'];
scope.link.ready('types',
function() {
types = scope['types'];
});
// forEachK: CPS( array CPS(array -> void) (error -> void) -> void )
// Iterates through an array and applies f to each element using CPS
// If an error is thrown, it catches the error and calls f_error on it
var forEachK = function(a, f, f_error, k) {
var forEachHelp = function(i) {
if( i >= a.length ) {
if (k) {
return k();
} else {
return;
}
}
try {
return f(a[i], function() { return forEachHelp(i+1); });
} catch (e) {
f_error(e);
}
};
return forEachHelp(0);
};
// reportError: (or exception string) -> void
// Reports an error to the user, either at the console
// if the console exists, or as alerts otherwise.
var reportError = function(e) {
var reporter;
if (typeof(console) != 'undefined' &&
typeof(console.log) != 'undefined') {
reporter = (function(x) { console.log(x); });
} else {
reporter = (function(x) { alert(x); });
}
if (typeof e == 'string') {
reporter(e);
} else if ( types.isSchemeError(e) ) {
if ( types.isExn(e.val) ) {
reporter( types.exnMessage(e.val) );
}
else {
reporter(e.val);
}
} else if ( types.isInternalError(e) ) {
reporter(e.val);
} else if (e.message) {
reporter(e.message);
} else {
reporter(e.toString());
}
// if (plt.Kernel.lastLoc) {
// var loc = plt.Kernel.lastLoc;
// if (typeof(loc) === 'string') {
// reporter("Error was raised around " + loc);
// } else if (typeof(loc) !== 'undefined' &&
// typeof(loc.line) !== 'undefined') {
// reporter("Error was raised around: "
// + plt.Kernel.locToString(loc));
// }
// }
};
var raise = function(v) {
throw types.schemeError(v);
};
// var throwCheckError = function(details, pos, args) {
// var errorFormatStr;
// if (args && args.length > 1) {
// var errorFormatStrBuffer = ['~a: expects type <~a> as ~a arguments, given: ~s; other arguments were:'];
// for (var i = 0; i < args.length; i++) {
// if ( i != pos-1 ) {
// errorFormatStrBuffer.push(toWrittenString(args[i]));
// }
// }
// errorFormatStr = errorFormatStrBuffer.join(' ');
// }
// else {
// errorFormatStr = "~a: expects argument of type <~a>, given: ~s";
// details.splice(2, 1);
// }
// raise( types.incompleteExn(types.exnFailContract,
// helpers.format(errorFormatStr, details),
// []) );
// };
// var check = function(x, f, functionName, typeName, position, args) {
// if ( !f(x) ) {
// throwCheckError([functionName,
// typeName,
// helpers.ordinalize(position),
// x],
// position,
// args);
// }
// };
var isList = function(x) {
var seenPairs = plt.baselib.hash.makeLowLevelEqHash();
while (true) {
if (seenPairs.containsKey(x)) {
return true;
} else if (x === types.EMPTY) {
return true;
} else if (types.isPair(x)) {
seenPairs.put(x, true);
x = x.rest();
} else {
return false;
}
}
};
var isListOf = function(x, f) {
var seenPairs = plt.baselib.hash.makeLowLevelEqHash();
while (true) {
if (seenPairs.containsKey(x)) {
return true;
} else if (x === types.EMPTY) {
return true;
} else if (types.isPair(x)) {
seenPairs.put(x, true);
if (f(x.first())) {
x = x.rest();
} else {
return false;
}
} else {
return false;
}
}
};
// var checkListOf = function(lst, f, functionName, typeName, position, args) {
// if ( !isListOf(lst, f) ) {
// helpers.throwCheckError([functionName,
// 'list of ' + typeName,
// helpers.ordinalize(position),
// lst],
// position,
// args);
// }
// };
// // remove: array any -> array
// // removes the first instance of v in a
// // or returns a copy of a if v does not exist
// var remove = function(a, v) {
// for (var i = 0; i < a.length; i++) {
// if (a[i] === v) {
// return a.slice(0, i).concat( a.slice(i+1, a.length) );
// }
// }
// return a.slice(0);
// };
// map: array (any -> any) -> array
// applies f to each element of a and returns the result
// as a new array
var map = function(f, a) {
var b = new Array(a.length);
for (var i = 0; i < a.length; i++) {
b[i] = f(a[i]);
}
return b;
};
var concatMap = function(f, a) {
var b = [];
for (var i = 0; i < a.length; i++) {
b = b.concat( f(a[i]) );
}
return b;
};
var schemeListToArray = function(lst) {
var result = [];
while ( !lst.isEmpty() ) {
result.push(lst.first());
lst = lst.rest();
}
return result;
}
// deepListToArray: any -> any
// Converts list structure to array structure.
var deepListToArray = function(x) {
var thing = x;
if (thing === types.EMPTY) {
return [];
} else if (types.isPair(thing)) {
var result = [];
while (!thing.isEmpty()) {
result.push(deepListToArray(thing.first()));
thing = thing.rest();
}
return result;
} else {
return x;
}
}
var flattenSchemeListToArray = function(x) {
if ( !isList(x) ) {
return [x];
}
var ret = [];
while ( !x.isEmpty() ) {
ret = ret.concat( flattenSchemeListToArray(x.first()) );
x = x.rest();
}
return ret;
};
var ordinalize = function(n) {
// special case for 11th:
if ( n % 100 == 11 ) {
return n + 'th';
}
var res = n;
switch( n % 10 ) {
case 1: res += 'st'; break;
case 2: res += 'nd'; break;
case 3: res += 'rd'; break;
default: res += 'th'; break;
}
return res;
}
// var wrapJsValue = function(x) {
// if (x === undefined) {
// return types.jsValue('undefined', x);
// }
// else if (x === null) {
// return types.jsValue('null', x);
// }
// else if (typeof(x) == 'function') {
// return types.jsValue('function', x);
// }
// else if ( x instanceof Array ) {
// return types.jsValue('array', x);
// }
// else if ( typeof(x) == 'string' ) {
// return types.jsValue("'" + x.toString() + "'", x);
// }
// else {
// return types.jsValue(x.toString(), x);
// }
// };
var getKeyCodeName = function(e) {
var code = e.charCode || e.keyCode;
var keyname;
switch(code) {
case 16: keyname = "shift"; break;
case 17: keyname = "control"; break;
case 19: keyname = "pause"; break;
case 27: keyname = "escape"; break;
case 33: keyname = "prior"; break;
case 34: keyname = "next"; break;
case 35: keyname = "end"; break;
case 36: keyname = "home"; break;
case 37: keyname = "left"; break;
case 38: keyname = "up"; break;
case 39: keyname = "right"; break;
case 40: keyname = "down"; break;
case 42: keyname = "print"; break;
case 45: keyname = "insert"; break;
case 46: keyname = String.fromCharCode(127); break;
case 106: keyname = "*"; break;
case 107: keyname = "+"; break;
case 109: keyname = "-"; break;
case 110: keyname = "."; break;
case 111: keyname = "/"; break;
case 144: keyname = "numlock"; break;
case 145: keyname = "scroll"; break;
case 186: keyname = ";"; break;
case 187: keyname = "="; break;
case 188: keyname = ","; break;
case 189: keyname = "-"; break;
case 190: keyname = "."; break;
case 191: keyname = "/"; break;
case 192: keyname = "`"; break;
case 219: keyname = "["; break;
case 220: keyname = "\\"; break;
case 221: keyname = "]"; break;
case 222: keyname = "'"; break;
default: if (code >= 96 && code <= 105) {
keyname = (code - 96).toString();
}
else if (code >= 112 && code <= 123) {
keyname = "f" + (code - 111);
}
else {
keyname = String.fromCharCode(code).toLowerCase();
}
break;
}
return keyname;
};
// maybeCallAfterAttach: dom-node -> void
// walk the tree rooted at aNode, and call afterAttach if the element has
// such a method.
var maybeCallAfterAttach = function(aNode) {
var stack = [aNode];
while (stack.length !== 0) {
var nextNode = stack.pop();
if (nextNode.afterAttach) {
nextNode.afterAttach(nextNode);
}
if (nextNode.hasChildNodes && nextNode.hasChildNodes()) {
var children = nextNode.childNodes;
for (var i = 0; i < children.length; i++) {
stack.push(children[i]);
}
}
}
};
// makeLocationDom: location -> dom
// Dom type that has special support in the editor through the print hook.
// The print hook is expected to look at the printing of dom values with
// this particular structure. In the context of WeScheme, the environment
// will rewrite these to be clickable links.
var makeLocationDom = function(aLocation) {
var locationSpan = document.createElement("span");
var idSpan = document.createElement("span");
var offsetSpan = document.createElement("span");
var lineSpan = document.createElement("span");
var columnSpan = document.createElement("span");
var spanSpan = document.createElement("span");
locationSpan['className'] = 'location-reference';
idSpan['className'] = 'location-id';
offsetSpan['className'] = 'location-offset';
lineSpan['className'] = 'location-line';
columnSpan['className'] = 'location-column';
spanSpan['className'] = 'location-span';
idSpan.appendChild(document.createTextNode(String(aLocation.id)));
offsetSpan.appendChild(document.createTextNode(String(aLocation.offset)));
lineSpan.appendChild(document.createTextNode(String(aLocation.line)));
columnSpan.appendChild(document.createTextNode(String(aLocation.column)));
spanSpan.appendChild(document.createTextNode(String(aLocation.span)));
locationSpan.appendChild(idSpan);
locationSpan.appendChild(offsetSpan);
locationSpan.appendChild(lineSpan);
locationSpan.appendChild(columnSpan);
locationSpan.appendChild(spanSpan);
return locationSpan;
};
var isLocationDom = function(thing) {
return (thing
&&
(thing.nodeType === Node.TEXT_NODE ||
thing.nodeType === Node.ELEMENT_NODE)
&&
thing['className'] === 'location-reference');
};
// Inheritance.
var heir = function(parentPrototype) {
var f = function() {}
f.prototype = parentPrototype;
return new f();
};
// clone: object -> object
// Copies an object. The new object should respond like the old
// object, including to things like instanceof
var clone = function(obj) {
var C = function() {}
C.prototype = obj;
var c = new C();
for (property in obj) {
if (obj.hasOwnProperty(property)) {
c[property] = obj[property];
}
}
return c;
};
////////////////////////////////////////////////
helpers.forEachK = forEachK;
helpers.reportError = reportError;
helpers.raise = raise;
// helpers.throwCheckError = throwCheckError;
helpers.isList = isList;
helpers.isListOf = isListOf;
// helpers.check = check;
// helpers.checkListOf = checkListOf;
// helpers.remove = remove;
helpers.map = map;
helpers.concatMap = concatMap;
helpers.schemeListToArray = schemeListToArray;
helpers.deepListToArray = deepListToArray;
helpers.flattenSchemeListToArray = flattenSchemeListToArray;
helpers.ordinalize = ordinalize;
// helpers.wrapJsValue = wrapJsValue;
helpers.getKeyCodeName = getKeyCodeName;
helpers.maybeCallAfterAttach = maybeCallAfterAttach;
helpers.makeLocationDom = makeLocationDom;
helpers.isLocationDom = isLocationDom;
helpers.heir = heir;
helpers.clone = clone;
scope.link.announceReady('helpers');
})(this['plt']);
/////////////////////////////////////////////////////////////////

4701
js-assembler/runtime-src/js-vm-primitives.js
View File

File diff suppressed because it is too large Load Diff

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

@ -212,16 +212,19 @@
var Machine = function() { var Machine = function() {
this.cbt = STACK_LIMIT_ESTIMATE; // calls before trampoline this.cbt = STACK_LIMIT_ESTIMATE; // calls before trampoline
this.val = undefined; // value register this.v = undefined; // value register
this.proc = undefined; // procedure register this.p = undefined; // procedure register
this.a = undefined; // argument count this.a = undefined; // argument count
this.e = []; // environment this.e = []; // environment
this.control = []; // control: Arrayof (U Frame CallFrame PromptFrame) this.c = []; // 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
this.params = { this.params = {
// print-as-expression: boolean
'print-as-expression' : true,
// currentDisplayer: DomNode -> Void // currentDisplayer: DomNode -> Void
// currentDisplayer is responsible for displaying to the browser. // currentDisplayer is responsible for displaying to the browser.
'currentDisplayer': function(MACHINE, domNode) { 'currentDisplayer': function(MACHINE, domNode) {
@ -293,10 +296,10 @@
Machine.prototype.captureControl = function(skip, tag) { Machine.prototype.captureControl = function(skip, tag) {
var MACHINE = this; var MACHINE = this;
var i; var i;
for (i = MACHINE.control.length - 1 - skip; i >= 0; i--) { for (i = MACHINE.c.length - 1 - skip; i >= 0; i--) {
if (MACHINE.control[i].tag === tag) { if (MACHINE.c[i].tag === tag) {
return MACHINE.control.slice(i + 1, return MACHINE.c.slice(i + 1,
MACHINE.control.length - skip); MACHINE.c.length - skip);
} }
} }
raise(MACHINE, new Error("captureControl: unable to find tag " + tag)); raise(MACHINE, new Error("captureControl: unable to find tag " + tag));
@ -311,10 +314,10 @@
Machine.prototype.restoreControl = function(tag) { Machine.prototype.restoreControl = function(tag) {
var MACHINE = this; var MACHINE = this;
var i; var i;
for (i = MACHINE.control.length - 1; i >= 0; i--) { for (i = MACHINE.c.length - 1; i >= 0; i--) {
if (MACHINE.control[i].tag === tag) { if (MACHINE.c[i].tag === tag) {
MACHINE.control = MACHINE.c =
MACHINE.control.slice(0, i+1).concat( MACHINE.c.slice(0, i+1).concat(
MACHINE.e[MACHINE.e.length - 1]); MACHINE.e[MACHINE.e.length - 1]);
return; return;
} }
@ -359,7 +362,7 @@
// Save the continuation mark on the top control frame. // Save the continuation mark on the top control frame.
Machine.prototype.installContinuationMarkEntry = function(key, value) { Machine.prototype.installContinuationMarkEntry = function(key, value) {
var frame = this.control[this.control.length - 1]; var frame = this.c[this.c.length - 1];
var marks = frame.marks; var marks = frame.marks;
var i; var i;
for (i = 0; i < marks.length; i++) { for (i = 0; i < marks.length; i++) {
@ -375,7 +378,7 @@
Machine.prototype.captureContinuationMarks = function() { Machine.prototype.captureContinuationMarks = function() {
var kvLists = []; var kvLists = [];
var i; var i;
var control = this.control; var control = this.c;
var tracedCalleeKey = getTracedCalleeKey(this); var tracedCalleeKey = getTracedCalleeKey(this);
for (i = control.length-1; i >= 0; i--) { for (i = control.length-1; i >= 0; i--) {
if (control[i].marks.length !== 0) { if (control[i].marks.length !== 0) {
@ -384,8 +387,8 @@
if (tracedCalleeKey !== null && if (tracedCalleeKey !== null &&
control[i] instanceof CallFrame && control[i] instanceof CallFrame &&
control[i].proc !== null) { control[i].p !== null) {
kvLists.push([[tracedCalleeKey, control[i].proc]]); kvLists.push([[tracedCalleeKey, control[i].p]]);
} }
} }
return new baselib.contmarks.ContinuationMarkSet(kvLists); return new baselib.contmarks.ContinuationMarkSet(kvLists);
@ -661,11 +664,11 @@
var checkClosureAndArity = function(M) { var checkClosureAndArity = function(M) {
if(!(M.proc instanceof Closure)){ if(!(M.p instanceof Closure)){
raiseOperatorIsNotClosure(M,M.proc); raiseOperatorIsNotClosure(M,M.p);
} }
if(!isArityMatching(M.proc.racketArity,M.a)) { if(!isArityMatching(M.p.racketArity,M.a)) {
raiseArityMismatchError(M, M.proc,M.a); raiseArityMismatchError(M,M.p,M.a);
} }
}; };
@ -675,7 +678,8 @@
// Superinstructions to try to reduce code size. // Superinstructions to try to reduce code size.
var si_context_expected = function(n) { var si_context_expected = function(n) {
if (n === 1) { return si_context_expected_1; } if (n === 1) { return si_context_expected_1; }
return function(M) { raiseContextExpectedValuesError(M, n); } var f = function(M) { raiseContextExpectedValuesError(M, n); };
return f;
}; };
var si_context_expected_1 = function(M) { raiseContextExpectedValuesError(M, 1); } var si_context_expected_1 = function(M) { raiseContextExpectedValuesError(M, 1); }
@ -686,7 +690,6 @@
////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////
@ -817,6 +820,7 @@
exports['getTracedCalleeKey'] = getTracedCalleeKey; exports['getTracedCalleeKey'] = getTracedCalleeKey;
exports['si_context_expected'] = si_context_expected; exports['si_context_expected'] = si_context_expected;
exports['si_context_expected_1'] = si_context_expected_1;
exports['checkClosureAndArity'] = checkClosureAndArity; exports['checkClosureAndArity'] = checkClosureAndArity;

573
js-assembler/runtime-src/types.js
View File

@ -1,573 +0,0 @@
// The definitions of the basic types in Whalesong.
//
// Note: this originally came from js-vm, and as a result,
// there's quite a lot of cruft and unused code in this module.
// I need to filter and rip out the values that aren't used in Whalesong.
if (! this['plt']) { this['plt'] = {}; }
// FIXME: there's a circularity between this module and helpers, and that circularly
// should not be there!
(function (scope) {
//////////////////////////////////////////////////////////////////////
var types = {};
scope['types'] = types;
var getEqHashCode = plt.baselib.hashes.getEqHashCode;
// makeLowLevelEqHash: -> hashtable
// Constructs an eq hashtable that uses Moby's getEqHashCode function.
var makeLowLevelEqHash = plt.baselib.hashes.makeLowLevelEqHash;
var toWrittenString = plt.baselib.format.toWrittenString;
var toDisplayedString = plt.baselib.format.toDisplayedString;
var toDomNode = plt.baselib.format.toDomNode;
var appendChild = function(parent, child) {
parent.appendChild(child);
};
var Symbol = plt.baselib.symbols.Symbol;
var Empty = plt.baselib.lists.Empty;
var Cons = plt.baselib.lists.Cons;
var isNumber = jsnums.isSchemeNumber;
var isReal = jsnums.isReal;
var isRational = jsnums.isRational;
var isComplex = isNumber;
var isInteger = jsnums.isInteger;
var isNatural = function(x) {
return (jsnums.isExact(x) && isInteger(x)
&& jsnums.greaterThanOrEqual(x, 0));
};
var isNonNegativeReal = function(x) {
return isReal(x) && jsnums.greaterThanOrEqual(x, 0);
};
var isString = plt.baselib.strings.isString;
var equals = plt.baselib.equality.equals;
// isList: Any -> Boolean
// Returns true if x is a list (a chain of pairs terminated by EMPTY).
var isList = function(x) {
while (x !== Empty.EMPTY) {
if (x instanceof Cons){
x = x.rest;
} else {
return false;
}
}
return true;
};
var makeList = function() {
var result = Empty.EMPTY;
for(var i = arguments.length-1; i >= 0; i--) {
result = Cons.makeInstance(arguments[i], result);
}
return result;
};
var makeVector = function() {
return Vector.makeInstance(arguments.length, arguments);
};
var makeVectorImmutable = function() {
var v = Vector.makeInstance(arguments.length, arguments);
v.mutable = false;
return v;
};
var makeString = function(s) {
if (s instanceof plt.baselib.strings.Str) {
return s;
}
else if (s instanceof Array) {
// for (var i = 0; i < s.length; i++) {
// if ( typeof s[i] !== 'string' || s[i].length != 1 ) {
// return undefined;
// }
// }
return plt.baselib.strings.Str.makeInstance(s);
}
else if (typeof s === 'string') {
return plt.baselib.strings.Str.fromString(s);
}
else {
throw types.internalError('makeString expects and array of 1-character strings or a string;' +
' given ' + s.toString(),
false);
}
};
var makeHashEq = function(lst) {
var newHash = new plt.baselib.hashes.EqHashTable();
while ( !isEmpty(lst) ) {
newHash.hash.put(lst.first.first, lst.first.rest);
lst = lst.rest;
}
return newHash;
};
var makeHashEqual = function(lst) {
var newHash = new plt.baselib.hashes.EqualHashTable();
while ( !isEmpty(lst) ) {
newHash.hash.put(lst.first.first, lst.first.rest);
lst = lst.rest;
}
return newHash;
};
var Color = plt.baselib.structs.makeStructureType(
'color', false, 3, 0, false, false);
//////////////////////////////////////////////////////////////////////
// var JsValue = function(name, val) {
// this.name = name;
// this.val = val;
// };
// JsValue.prototype.toString = function() {
// return '#<js-value:' + typeof(this.val) + ':' + this.name + '>';
// };
// JsValue.prototype.toDomNode = function(cache) {
// return toDomNode(this.val, cache);
// };
// JsValue.prototype.equals = function(other, aUnionFind) {
// return (this.val === other.val);
// };
// // unbox: jsvalue -> any
// // Unwraps the value out of the JsValue box.
// JsValue.prototype.unbox = function() {
// return this.val;
// };
// var WrappedSchemeValue = function(val) {
// this.val = val;
// };
// WrappedSchemeValue.prototype.toString = function() { return toString(this.val); };
// WrappedSchemeValue.prototype.toWrittenString = function(cache) { return toWrittenString(this.val, cache); };
// WrappedSchemeValue.prototype.toDisplayedString = function(cache) { return toDisplayedString(this.val, cache); };
// // unbox: jsvalue -> any
// // Unwraps the value out of the WrappedSchemeValue box.
// WrappedSchemeValue.prototype.unbox = function() {
// return this.val;
// };
//////////////////////////////////////////////////////////////////////
// var WorldConfig = function(startup, shutdown, startupArgs) {
// this.startup = startup;
// this.shutdown = shutdown;
// this.startupArgs = startupArgs;
// };
// WorldConfig.prototype.toString = function() {
// return '#<world-config>';
// };
// WorldConfig.prototype.equals = function(other, aUnionFind) {
// return ( equals(this.startup, other.startup, aUnionFind) &&
// equals(this.shutdown, other.shutdown, aUnionFind) &&
// equals(this.shutdownArg, other.shutdownArg, aUnionFind) &&
// equals(this.restartArg, other.restartArg, aUnionFind) );
// };
// var Effect = plt.baselib.structs.makeStructureType('effect', false, 0, 0, false, false);
// Effect.type.prototype.invokeEffect = function() {
// helpers.raise(types.incompleteExn(
// types.exnFail,
// 'effect type created without using make-effect-type',
// []));
// };
// var makeEffectType = function(name, superType, initFieldCnt, impl, guard) {
// if ( !superType ) {
// superType = Effect;
// }
// var newType = plt.baselib.structs.makeStructureType(name, superType, initFieldCnt, 0, false, guard);
// var lastFieldIndex = newType.firstField + newType.numberOfFields;
// newType.type.prototype.invokeEffect = function(aBigBang, k) {
// var schemeChangeWorld = new PrimProc('update-world', 1, false, false,
// function(worldUpdater) {
// //helpers.check(worldUpdater, helpers.procArityContains(1),
// // 'update-world', 'procedure (arity 1)', 1);
// return new INTERNAL_PAUSE(
// function(caller, onSuccess, onFail) {
// aBigBang.changeWorld(function(w, k2) {
// caller(worldUpdater,
// [w], k2,
// function(e) { throw e; },
// 'change-world (effect)');
// },
// function() { onSuccess(VOID_VALUE, 'restarting (change-world (effect))'); });
// });
// });
// var args = this._fields.slice(0, lastFieldIndex);
// args.unshift(schemeChangeWorld);
// return aBigBang.caller(impl, args, k, function(e) { throw e; }, 'invoking effect ' + name);
// }
// return newType;
// };
// var RenderEffect = plt.baselib.structs.makeStructureType('render-effect', false, 0, 0, false, false);
// RenderEffect.type.prototype.callImplementation = function(caller, k) {
// helpers.raise(types.incompleteExn(
// types.exnFail,
// 'render effect created without using make-render-effect-type',
// []));
// };
// var makeRenderEffectType = function(name, superType, initFieldCnt, impl, guard) {
// if ( !superType ) {
// superType = RenderEffect;
// }
// var newType = plt.baselib.structs.makeStructureType(name, superType, initFieldCnt, 0, false, guard);
// var lastFieldIndex = newType.firstField + newType.numberOfFields;
// newType.type.prototype.callImplementation = function(caller, k) {
// var args = this._fields.slice(0, lastFieldIndex);
// caller(impl, args, k);
// }
// return newType;
// };
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
// var makeOptionPrimitive = function(name,
// numArgs,
// defaultVals,
// usesState,
// bodyF) {
// var makeNthPrimitive = function(n) {
// return new PrimProc(name,
// numArgs + n,
// false,
// usesState,
// function() {
// var expectedNumArgs = numArgs + n + (usesState ? 1 : 0);
// assert.equal(arguments.length,
// expectedNumArgs);
// var args = [arguments];
// for (var i = 0; i < arguments.length; i++) {
// args.push(arguments[i]);
// }
// var startDefaults = i - numArgs - (usesState ? 1 : 0);
// return bodyF.apply(
// bodyF,
// args.concat(defaultVals.slice(startDefaults)));
// });
// };
// var cases = [];
// for (var i = 0; i <= defaultVals.length; i++) {
// cases.push(makeNthPrimitive(i));
// }
// return new CasePrimitive(name, cases);
// };
//////////////////////////////////////////////////////////////////////
// INTERNAL_CALL
// used for interaction between the Primitives and the interpreter (callPrimitiveProcedure).
// Don't confuse this with CallControl.
// var INTERNAL_CALL = function(operator, operands, k) {
// this.operator = operator;
// this.operands = operands;
// this.k = k;
// };
// // INTERNAL_PAUSE
// // used for interaction between the Primitive functions and the
// // interpreter.
// // Halts the interpreter, but passing onPause the functions necessary
// // to restart computation.
// var INTERNAL_PAUSE = function(onPause) {
// this.onPause = onPause;
// };
//////////////////////////////////////////////////////////////////////
// // ContinuationPromptTag: symbol | false -> ContinuationPromptTag
// var ContinuationPromptTag = function(sym) {
// this.sym = sym;
// };
// var defaultContinuationPromptTag = new ContinuationPromptTag();
// var defaultContinuationPromptTagHandler = new PrimProc(
// 'default-continuation-prompt-tag-handler',
// 1,
// false,
// true,
// function(aState, thunk) {
// aState.pushControl(
// new control.ApplicationControl(
// new control.ConstantControl(thunk),
// []));
// });
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
// Exports
types.symbol = Symbol.makeInstance;
types.rational = jsnums.makeRational;
types.floatpoint = jsnums.makeFloat;
types.complex = jsnums.makeComplex;
types.bignum = jsnums.makeBignum;
types.list = makeList;
types.vector = makeVector;
types.vectorImmutable = makeVectorImmutable;
types.regexp = function(p) { return new plt.baselib.regexps.RegularExpression(p) ; }
types.byteRegexp = function(p) { return new plt.baselib.regexps.ByteRegularExpression(p) ; }
types.character = plt.baselib.chars.Char.makeInstance;
types['string'] = makeString;
types.placeholder = function(x) { return new plt.baselib.placeholders.Placeholder(x); };
types.box = function(x) { return new plt.baselib.boxes.Box(x, true); };
types.boxImmutable = function(x) { return new plt.baselib.boxes.Box(x, false); };
types.path = function(x) { return new plt.baselib.paths.Path(x); };
types.bytes = function(x, mutable) { return new plt.baselib.bytes.Bytes(x, mutable); };
types.bytesImmutable = function(x) { return new plt.baselib.bytes.Bytes(x, false); };
types.keyword = function(k) { return new plt.baselib.keywords.Keyword(k); };
types.pair = function(x, y) { return plt.baselib.lists.Cons.makeInstance(x, y); };
types.hash = makeHashEqual;
types.hashEq = makeHashEq;
// types.jsValue = function(name, val) { return new JsValue(name, val); };
// types.wrappedSchemeValue = function(val) { return new WrappedSchemeValue(val); };
types.color = Color.constructor;
types.colorRed = function(x) { return Color.accessor(x, 0); };
types.colorGreen = function(x) { return Color.accessor(x, 1); };
types.colorBlue = function(x) { return Color.accessor(x, 2); };
types.FALSE = false;
types.TRUE = true;
types.EMPTY = Empty.EMPTY;
types.equals = equals;
types.isNumber = isNumber;
types.isReal = jsnums.isReal;
types.isRational = jsnums.isRational;
types.isComplex = isNumber;
types.isInteger = jsnums.isInteger;
types.isNatural = isNatural;
types.isNonNegativeReal = isNonNegativeReal;
types.isSymbol = function(x) { return x instanceof Symbol; };
types.isChar = function(x) { return x instanceof plt.baselib.chars.Char; };
types.isString = isString;
types.isPair = function(x) { return x instanceof Cons; };
types.isList = isList;
types.isEmpty = function(x) { return x === Empty.EMPTY; };
types.isVector = function(x) { return x instanceof Vector; };
types.isBox = function(x) { return x instanceof plt.baselib.boxes.Box; };
types.isPlaceholder = function(x) { return x instanceof plt.baselib.placeholders.Placeholder; };
types.isHash = function(x) { return (x instanceof plt.baselib.hashes.EqHashTable ||
x instanceof plt.baselib.hashes.EqualHashTable); };
types.isByteString = function(x) { return x instanceof plt.baselib.bytes.Bytes; };
types.isStruct = function(x) { return x instanceof Struct; };
types.isColor = Color.predicate;
// types.isFunction = function(x) {
// return (x instanceof PrimProc);
// };
// types.isJsValue = function(x) { return x instanceof JsValue; };
// types.isWrappedSchemeValue = function(x) { return x instanceof WrappedSchemeValue; };
types.cons = Cons.makeInstance;
types.VOID = plt.baselib.constants.VOID_VALUE;
types.EOF = plt.baselib.constants.EOF_VALUE;
// types.ContinuationPromptTag = ContinuationPromptTag;
// types.defaultContinuationPromptTag = defaultContinuationPromptTag;
// types.defaultContinuationPromptTagHandler = defaultContinuationPromptTagHandler;
// types.makeOptionPrimitive = makeOptionPrimitive;
// types.internalCall = function(op, args, k) { return new INTERNAL_CALL(op, args, k); };
// types.isInternalCall = function(x) { return (x instanceof INTERNAL_CALL); };
// types.internalPause = function(onPause) { return new INTERNAL_PAUSE(onPause) };
// types.isInternalPause = function(x) { return (x instanceof INTERNAL_PAUSE); };
types.continuationMarkSet = function(dict) { return new plt.baselib.contmarks.ContinuationMarkSet(dict); };
types.isContinuationMarkSet = function(x) { return x instanceof plt.baselib.contmarks.ContinuationMarkSet; };
// types.isContinuationPromptTag = function(x) { return x instanceof ContinuationPromptTag; };
types.Box = plt.baselib.boxes.Box;
types.Placeholder = plt.baselib.placeholders.Placeholder;
types.isStructType = function(x) { return x instanceof plt.baselib.structs.StructType; };
// types.StructProc = StructProc;
// types.StructConstructorProc = StructConstructorProc;
// types.StructPredicateProc = StructPredicateProc;
// types.StructAccessorProc = StructAccessorProc;
// types.StructMutatorProc = StructMutatorProc;
types.makeLowLevelEqHash = makeLowLevelEqHash;
///////////////////////////////////////
// World-specific exports
// // big bang info to be passed into a make-world-config startup argument
// var BigBangInfo = plt.baselib.structs.makeStructureType('bb-info', false, 2, 0, false,
// function(args, name, k) {
// //helpers.check(args[0], helpers.procArityContains(1), name, 'procedure (arity 1)', 1);
// //helpers.check(args[1], types.isJsValue, name, 'js-object', 2);
// return k(args);
// });
// types.BigBangInfo = BigBangInfo;
// types.makeBigBangInfo = BigBangInfo.constructor;
// types.isBigBangInfo = BigBangInfo.predicate;
// types.bbInfoChangeWorld = function(info) { return BigBangInfo.accessor(info, 0); };
// types.bbInfoToplevelNode = function(info) { return BigBangInfo.accessor(info, 1); };
// World config information for user-defined configurations
// types.worldConfig = function(startup, shutdown, pause, restart) { return new WorldConfig(startup, shutdown, pause, restart); };
// types.isWorldConfig = function(x) { return x instanceof WorldConfig; };
// exporting information to create effect types
// types.makeEffectType = makeEffectType;
// types.isEffectType = function(x) {
// return ((x instanceof plt.baselib.structs.StructType)&& x.type.prototype.invokeEffect) ? true : false;
// };
// types.isEffect = Effect.predicate;
// exporting functions to create render effect types
// types.makeRenderEffectType = makeRenderEffectType;
// types.isRenderEffectType = function(x) {
// return (x instanceof plt.baselib.structs.StructType && x.type.prototype.callImplementation) ? true : false;
// };
// types.isRenderEffect = RenderEffect.predicate;
scope.link.announceReady('types');
})(this['plt']);

1
scribblings/manual.scrbl
View File

@ -1856,5 +1856,6 @@ and suggesting improvements.
"Robby Findler" "Robby Findler"
"Gregor Kiczales" "Gregor Kiczales"
"Cristina Teodoropol" "Cristina Teodoropol"
"Matthew Flatt"
) string<?)) ) string<?))
) )

4
tests/more-tests/map.expected Normal file
View File

@ -0,0 +1,4 @@
(5 7 9)
(5 7 9)
(12 15 18)
(1 2 3)

6
tests/more-tests/map.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang planet dyoo/whalesong
(map (lambda (x y) (+ x y)) (list 1 2 3) (list 4 5 6))
(map + (list 1 2 3) (list 4 5 6))
(map + (list 1 2 3) (list 4 5 6) (list 7 8 9))
(map + (list 1 2 3))

40
tests/more-tests/nqueens.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang planet dyoo/whalesong/base
;;; NQUEENS -- Compute number of solutions to 8-queens problem.
;; 2006/08 -- renamed `try' to `try-it' to avoid Bigloo collision (mflatt)
;; 2010/04 -- got rid of the one-armed id (stamourv)
(define trace? #f)
(define (nqueens n)
(define (one-to n)
(let loop ((i n) (l '()))
(if (= i 0) l (loop (- i 1) (cons i l)))))
(define (try-it x y z)
(if (null? x)
(if (null? y)
(begin (if trace? (begin (write z) (newline)) #t) 1)
0)
(+ (if (ok? (car x) 1 z)
(try-it (append (cdr x) y) '() (cons (car x) z))
0)
(try-it (cdr x) (cons (car x) y) z))))
(define (ok? row dist placed)
(if (null? placed)
#t
(and (not (= (car placed) (+ row dist)))
(not (= (car placed) (- row dist)))
(ok? row (+ dist 1) (cdr placed)))))
(try-it (one-to n) '() '()))
(let loop ((n 1000 ;10000
)
(v 0))
(if (zero? n)
v
(loop (- n 1) (nqueens 8
; (if input 8 0)
))))

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

@ -14,6 +14,7 @@
(test "more-tests/hello.rkt") (test "more-tests/hello.rkt")
(test "more-tests/sharing.rkt") (test "more-tests/sharing.rkt")
(test "more-tests/simple-functions.rkt") (test "more-tests/simple-functions.rkt")
(test "more-tests/map.rkt")
(test "more-tests/quasi.rkt") (test "more-tests/quasi.rkt")
(test "more-tests/sk-generator.rkt") (test "more-tests/sk-generator.rkt")
(test "more-tests/sk-generator-2.rkt") (test "more-tests/sk-generator-2.rkt")

17
world/js-impl.js
View File

@ -21,6 +21,12 @@ var checkProcedureWithKey = plt.baselib.check.makeCheckArgumentType(
plt.baselib.arity.isArityMatching(x.racketArity, 2)); }, plt.baselib.arity.isArityMatching(x.racketArity, 2)); },
'procedure that consumes a world argument and a key'); 'procedure that consumes a world argument and a key');
var checkProcedureWithMouse = plt.baselib.check.makeCheckArgumentType(
function(x) { return (plt.baselib.functions.isProcedure(x) &&
plt.baselib.arity.isArityMatching(x.racketArity, 4)); },
'procedure that consumes a world argument, an x and y coordinate, and a mouse event');
var checkHandler = plt.baselib.check.makeCheckArgumentType( var checkHandler = plt.baselib.check.makeCheckArgumentType(
isWorldConfigOption, isWorldConfigOption,
@ -97,6 +103,17 @@ EXPORTS['on-key'] =
return new OnKey(f); return new OnKey(f);
}); });
EXPORTS['on-mouse'] =
makePrimitiveProcedure(
'on-mouse',
1,
function(MACHINE) {
var f = checkProcedureWithMouse(MACHINE, "on-key", 0);
return new OnMouse(f);
});
EXPORTS['key=?'] = EXPORTS['key=?'] =
makePrimitiveProcedure( makePrimitiveProcedure(
'on-key', 'on-key',

888
world/kernel.js
View File

@ -233,6 +233,27 @@ var getKeyCodeName = function(e) {
var OnMouse = function(handler) {
WorldConfigOption.call(this, 'on-mouse');
this.handler = handler;
}
OnMouse.prototype = plt.baselib.heir(WorldConfigOption.prototype);
OnMouse.prototype.toRawHandler = function(MACHINE, toplevelNode) {
var that = this;
var worldFunction = adaptWorldFunction(that.handler);
return rawJsworld.on_mouse(
function(w, x, y, type, success) {
worldFunction(w, x, y, type, success);
});
};
var OutputConfig = function() {} var OutputConfig = function() {}
@ -351,870 +372,3 @@ StopWhen.prototype.toRawHandler = function(MACHINE, toplevelNode) {
var worldFunction = adaptWorldFunction(that.handler); var worldFunction = adaptWorldFunction(that.handler);
return rawJsworld.stop_when(worldFunction); return rawJsworld.stop_when(worldFunction);
}; };
// // This needs to be cleaned up!
// //////////////////////////////////////////////////////////////////////
// //////////////////////////////////////////////////////////////////////
// //////////////////////////////////////////////////////////////////////
// //////////////////////////////////////////////////////////////////////
// //////////////////////////////////////////////////////////////////////
// // The real low-level jsworld module:
// var _js = jsworld.Jsworld;
// var caller;
// var setCaller = function(c) {
// caller = function(op, args, k) {
// c(op, args, k, handleError);
// };
// };
// var unsetCaller = function() {
// caller = function(op, args, k) {
// throw new Error('caller not defined!');
// };
// };
// unsetCaller();
// // The restarted and things to set it
// // Note that we never want to restart the same computation
// // more than once, so we throw an error if someone tries to do that
// var restarter;
// var setRestarter = function(r) {
// var hasRestarted = false;
// restarter = function(v) {
// if (hasRestarted) {
// throw new Error('Cannot restart twice!');
// }
// hasRestarted = true;
// r(v);
// };
// };
// var unsetRestarter = function() {
// restarter = function() {
// throw new Error('restarter not defined!');
// };
// };
// unsetRestarter();
// var errorReporter = function(e) {
// // default: do nothing.
// };
// var terminator;
// var setTerminator = function(t) {
// terminator = t;
// };
// var unsetTerminator = function() {
// terminator = function() {
// throw new Error('terminator not defined!');
// };
// };
// unsetTerminator();
// // mutateStringsInDeepArray: array -> array
// // walks and in-place mutates Scheme strings to primitive strings.
// var mutateStringsInDeepArray = function(thing) {
// var i, length;
// if (typeof(thing) === 'object' &&
// thing.constructor === Array) {
// length = thing.length;
// for (i = 0; i < length; i++) {
// thing[i] = mutateStringsInDeepArray(thing[i]);
// }
// } else if (types.isString(thing)) {
// return thing.toString();
// }
// return thing;
// };
// var userConfigs = [];
// var startUserConfigs = function(k) {
// helpers.forEachK(userConfigs,
// function(aConfig, k2) {
// caller(aConfig.startup, aConfig.startupArgs,
// function(res) {
// aConfig.isRunning = true;
// aConfig.shutdownArg = res;
// k2()
// });
// },
// handleError,
// k);
// }
// var shutdownUserConfigs = function(k) {
// // console.log('shutting down user configs');
// var theConfigs = userConfigs;
// userConfigs = []
// helpers.forEachK(theConfigs,
// function(aConfig, k2) {
// // console.log(' shutting down a config');
// if (aConfig.isRunning) {
// aConfig.isRunning = false;
// caller(aConfig.shutdown, [aConfig.shutdownArg], k2);
// } else {
// k2();
// }
// },
// handleError,
// k);
// }
// var expandHandler = function(handler) {
// return types.jsValue('function', function() {
// var wrappedStimulusArgs = [];
// for (var i = 0; i < arguments.length; i++) {
// wrappedStimulusArgs.push( helpers.wrapJsValue(arguments[i]) );
// }
// Jsworld.updateWorld(
// function(w, k) {
// var args = [w].concat(wrappedStimulusArgs);
// caller(handler, args, k);
// },
// function() {});
// });
// };
// // var unwrapWorldEffects = function(w) {
// // if ( _js.has_effects(w) ) {
// // var unwrappedEffects =
// // helpers.map(function(e) {
// // if ( types.isEffect(e) ) {
// // return types.makeJsworldEffect(function(k) {
// // caller(types.effectThunk(e), [], k);
// // });
// // }
// // else {
// // return e;
// // }
// // },
// // w.getEffects());
// // var returnVal = _js.with_multiple_effects(w.getWorld(), unwrappedEffects);
// // return returnVal;
// // }
// // else {
// // return w;
// // }
// // };
// var deepUnwrapJsValues = function(x, k) {
// if ( types.isJsValue(x) ) {
// k(x.unbox());
// }
// else if ( types.isRenderEffect(x) ) {
// x.callImplementation(caller, function(y) { deepUnwrapJsValues(y, k); });
// }
// // var effects = helpers.schemeListToArray( types.renderEffectEffects(x) ).reverse();
// // types.setRenderEffectEffects(x, types.EMPTY);
// //
// // helpers.forEachK(effects,
// // function(ef, k2) { caller(ef, [], k2); },
// // handleError,
// // function() { deepUnwrapJsValues(types.renderEffectDomNode(x), k); });
// // }
// else if ( types.isPair(x) ) {
// deepUnwrapJsValues(x.first(), function(first) {
// deepUnwrapJsValues(x.rest(), function(rest) {
// k( types.cons(first, rest) );
// });
// });
// }
// else {
// k(x);
// }
// };
// // isHandler: X -> boolean
// // Right now, a handler is a function that consumes and produces
// // configs. We should tighten up the type check eventually.
// var isHandler = function(x) {
// return typeof(x) == 'function';
// }
// //////////////////////////////////////////////////////////////////////
// //From this point forward, we define wrappers to integrate jsworld
// //with Moby.
// // getBigBangWindow: -> window
// var getBigBangWindow = function() {
// if (window.document.getElementById("jsworld-div") !== undefined) {
// return window;
// } else {
// var newDiv = window.document.createElement("div");
// newDiv.id = 'jsworld-div';
// window.document.appendChild(newDiv);
// return window;
// }
// }
// // types are
// // sexp: (cons node (listof sexp))
// // css-style: (node (listof (list string string)))
// // Exports:
// var isPair = types.isPair;
// var isEmpty = function(x) { return x === types.EMPTY; };
// var isList = function(x) { return (isPair(x) || isEmpty(x)); };
// // The default printWorldHook will write the written content of the node.
// // We probably want to invoke the pretty printer here instead!
// Jsworld.printWorldHook = function(world, node) {
// var newNode;
// if(node.lastChild == null) {
// newNode = types.toDomNode(world);
// node.appendChild(newNode);
// helpers.maybeCallAfterAttach(newNode);
// } else {
// newNode = types.toDomNode(world);
// node.replaceChild(newNode, node.lastChild);
// helpers.maybeCallAfterAttach(newNode);
// }
// };
// // Figure out the target of an event.
// // http://www.quirksmode.org/js/events_properties.html#target
// var findEventTarget = function(e) {
// var targ;
// if (e.target)
// targ = e.target;
// else if (e.srcElement)
// targ = e.srcElement;
// if (targ.nodeType == 3) // defeat Safari bug
// targ = targ.parentNode;
// return targ;
// }
// // isNode: any -> boolean
// // Returns true if the thing has a nodeType.
// var isNode = function(thing) {
// return thing && typeof(thing.nodeType) != 'undefined';
// }
// // checkWellFormedDomTree: X X (or number undefined) -> void
// // Check to see if the tree is well formed. If it isn't,
// // we need to raise a meaningful error so the user can repair
// // the structure.
// //
// // Invariants:
// // The dom tree must be a pair.
// // The first element must be a node.
// // Each of the rest of the elements must be dom trees.
// // If the first element is a text node, it must NOT have children.
// var checkWellFormedDomTree = function(x, top, index) {
// var fail = function(formatStr, formatArgs) {
// throw types.schemeError(
// types.incompleteExn(types.exnFailContract,
// helpers.format(formatStr, formatArgs),
// []));
// }
// if (_js.isPage(x)) {
// return;
// }
// if (types.isPair(x)) {
// var firstElt = x.first();
// var restElts = x.rest();
// if (! isNode(firstElt)) {
// fail("on-draw: expected a dom-element, but received ~s instead, the first element within ~s", [firstElt, top]);
// }
// if (firstElt.nodeType == Node.TEXT_NODE && !restElts.isEmpty() ) {
// fail("on-draw: the text node ~s must not have children. It has ~s", [firstElt, restElts]);
// }
// var i = 2;
// while( !restElts.isEmpty() ) {
// checkWellFormedDomTree(restElts.first(), x, i);
// restElts = restElts.rest();
// i++;
// }
// } else {
// var formatStr = "on-draw: expected a dom-s-expression, but received ~s instead";
// var formatArgs = [x];
// if (index != undefined) {
// formatStr += ", the ~a element within ~s";
// formatArgs.push( helpers.ordinalize(index) );
// formatArgs.push(top);
// }
// formatStr += ".";
// fail(formatStr, formatArgs);
// }
// };
// // Compatibility for attaching events to nodes.
// var attachEvent = function(node, eventName, fn) {
// if (node.addEventListener) {
// // Mozilla
// node.addEventListener(eventName, fn, false);
// } else {
// // IE
// node.attachEvent('on' + eventName, fn, false);
// }
// return function() {
// detachEvent(node, eventName, fn);
// }
// };
// var detachEvent = function(node, eventName, fn) {
// if (node.addEventListener) {
// // Mozilla
// node.removeEventListener(eventName, fn, false);
// } else {
// // IE
// node.detachEvent('on' + eventName, fn, false);
// }
// }
// var preventDefault = function(event) {
// if (event.preventDefault) {
// event.preventDefault();
// } else {
// event.returnValue = false;
// }
// }
// var stopPropagation = function(event) {
// if (event.stopPropagation) {
// event.stopPropagation();
// } else {
// event.cancelBubble = true;
// }
// }
// // bigBang: world dom (listof (list string string)) (arrayof handler) -> world
// Jsworld.bigBang = function(initWorld, toplevelNode, handlers, theCaller, theRestarter, onFail) {
// // shutdownListeners: arrayof (-> void)
// // We maintain a list of thunks that need to be called as soon as we come out of
// // bigBang, to do cleanup.
// var shutdownListeners = [];
// var onTermination = function(w) {
// for (var i = 0; i < shutdownListeners.length; i++) {
// try {
// shutdownListeners[i]();
// } catch (e) { }
// }
// shutdownUserConfigs(function() {
// unsetCaller();
// theRestarter(w);
// });
// }
// //console.log('in high level big-bang');
// errorReporter = onFail;
// setCaller(theCaller);
// setRestarter(theRestarter);
// setTerminator(function(w) {
// detachEvent(toplevelNode, 'click', absorber);
// shutdownUserConfigs(function() {
// unsetCaller();
// unsetTerminator();
// restarter(w);
// });
// });
// var attribs = types.EMPTY;
// // Ensure that the toplevelNode can be focused by mouse or keyboard
// toplevelNode.tabIndex = 0;
// // Absorb all click events so they don't bubble up.
// var absorber = function(e) {
// preventDefault(e);
// stopPropagation(e);
// return false;
// }
// attachEvent(toplevelNode, 'click', absorber);
// shutdownListeners.push(function() { detachEvent(toplevelNode, 'click', absorber)});
// var config = new world.Kernel.config.WorldConfig();
// for(var i = 0; i < handlers.length; i++) {
// if (isList(handlers[i])) {
// attribs = handlers[i];
// }
// else if (isHandler(handlers[i])) {
// config = handlers[i](config);
// }
// else if ( types.isWorldConfig(handlers[i]) ) {
// handlers[i].startupArgs = helpers.map(expandHandler, handlers[i].startupArgs);
// userConfigs.push(handlers[i]);
// }
// }
// config = config.updateAll({'changeWorld': Jsworld.updateWorld,
// 'shutdownWorld': Jsworld.shutdownWorld});
// var stimuli = new world.Kernel.stimuli.StimuliHandler(config, caller, restarter);
// var wrappedHandlers = [];
// var wrappedRedraw;
// var wrappedRedrawCss;
// if (config.lookup('onDraw')) {
// wrappedRedraw = function(w, k) {
// try {
// caller(config.lookup('onDraw'), [w],
// function(newDomTree) {
// deepUnwrapJsValues(newDomTree, function(unwrappedTree) {
// checkWellFormedDomTree(unwrappedTree, unwrappedTree, undefined);
// var result = [toplevelNode,
// helpers.deepListToArray(unwrappedTree)];
// k(result);
// });
// });
// } catch (e) {
// handleError(e);
// // throw e;
// }
// }
// if (config.lookup('onDrawCss')) {
// wrappedRedrawCss = function(w, k) {
// try {
// caller(config.lookup('onDrawCss'), [w],
// function(res) {
// var result = helpers.deepListToArray(res);
// result = mutateStringsInDeepArray(result);
// // plt.Kernel.setLastLoc(undefined);
// k(result);
// });
// } catch (e) {
// handleError(e);
// // throw e;
// }
// }
// }
// else {
// wrappedRedrawCss = function(w, k) { k([]); };
// }
// wrappedHandlers.push(_js.on_draw(wrappedRedraw, wrappedRedrawCss));
// } else if (config.lookup('onRedraw')) {
// var reusableCanvas = undefined;
// var reusableCanvasNode = undefined;
// wrappedRedraw = function(w, k) {
// try {
// //console.log('in onRedraw handler');
// caller(config.lookup('onRedraw'), [w],
// function(aScene) {
// // Performance hack: if we're using onRedraw, we know
// // we've got a scene, so we optimize away the repeated
// // construction of a canvas object.
// if ( world.Kernel.isImage(aScene) ) {
// var width = aScene.getWidth();
// var height = aScene.getHeight();
// if (! reusableCanvas) {
// reusableCanvas = world.Kernel.makeCanvas(width, height);
// // Note: the canvas object may itself manage objects,
// // as in the case of an excanvas. In that case, we must make
// // sure jsworld doesn't try to disrupt its contents!
// reusableCanvas.jsworldOpaque = true;
// reusableCanvasNode = _js.node_to_tree(reusableCanvas);
// }
// reusableCanvas.width = width;
// reusableCanvas.height = height;
// var ctx = reusableCanvas.getContext("2d");
// aScene.render(ctx, 0, 0);
// k([toplevelNode, reusableCanvasNode]);
// } else {
// k([toplevelNode, _js.node_to_tree(types.toDomNode(aScene))]);
// }
// });
// } catch (e) {
// handleError(e);
// // throw e;
// }
// }
// wrappedRedrawCss = function(w, k) {
// //console.log('in RedrawCss handler');
// k([[reusableCanvas,
// ["width", reusableCanvas.width + "px"],
// ["height", reusableCanvas.height + "px"]]]);
// }
// wrappedHandlers.push(_js.on_draw(wrappedRedraw, wrappedRedrawCss));
// } else {
// wrappedHandlers.push(_js.on_world_change
// (function(w, k) {
// Jsworld.printWorldHook(w, toplevelNode);
// k();
// }));
// }
// if (config.lookup('tickDelay')) {
// var wrappedTick = function(w, k) {
// caller(config.lookup('onTick'),
// [w],
// k);
// }
// var wrappedDelay = jsnums.toFixnum( config.lookup('tickDelay') );
// wrappedHandlers.push(_js.on_tick(wrappedDelay, wrappedTick));
// }
// if (config.lookup('stopWhen')) {
// wrappedHandlers.push(_js.stop_when(
// function(w, k) {
// caller(config.lookup('stopWhen'), [w],
// function(res) { k(res); });
// }));
// }
// if (config.lookup('onKey')) {
// var wrappedKey = function(w, e, k) {
// caller(config.lookup('onKey'), [w, helpers.getKeyCodeName(e)], k);
// }
// wrappedHandlers.push(_js.on_key(wrappedKey));
// toplevelNode.focus();
// }
// if (config.lookup('initialEffect')) {
// var updaters =
// world.Kernel.applyEffect(config.lookup('initialEffect'));
// for (var i = 0 ; i < updaters.length; i++) {
// if (config.lookup('stopWhen') &&
// config.lookup('stopWhen')([initWorld])) {
// break;
// } else {
// initWorld = updaters[i](initWorld);
// }
// }
// }
// _js.big_bang(toplevelNode,
// initWorld,
// wrappedHandlers,
// helpers.assocListToHash(attribs),
// terminator);
// startUserConfigs(function() {});
// return {
// breaker: function() {
// handleError(types.schemeError(
// types.incompleteExn(types.exnBreak, 'user break', [])));
// }
// };
// }
// var handleError = function(e) {
// // helpers.reportError(e);
// // When something bad happens, shut down
// // the world computation.
// // helpers.reportError("Shutting down jsworld computations");
// // world.Kernel.stimuli.onShutdown();
// world.Kernel.stimuli.massShutdown();
// shutdownUserConfigs(function() {
// errorReporter(e);
// // console.log('Got an error, the error was:');
// // console.log(e);
// if (typeof(console) !== 'undefined' && console.log) {
// if (e.stack) {
// console.log(e.stack);
// }
// else {
// console.log(e);
// }
// }
// if ( types.isSchemeError(e) ) {
// terminator(e);
// }
// else if ( types.isInternalError(e) ) {
// terminator(e);
// }
// else if (typeof(e) == 'string') {
// terminator( types.schemeError(types.incompleteExn(types.exnFail, e, [])) );
// }
// else if (e instanceof Error) {
// terminator( types.schemeError(types.incompleteExn(types.exnFail, e.message, [])) );
// }
// else {
// terminator( types.schemeError(e) );
// }
// });
// }
// // updateWorld: CPS( CPS(world -> world) -> void )
// Jsworld.updateWorld = function(updater, k) {
// var wrappedUpdater = function(w, k2) {
// try {
// updater(w, k2);
// } catch (e) {
// if (typeof(console) !== 'undefined' && console.log && e.stack) {
// console.log(e.stack);
// }
// handleError(e);
// // k2(w);
// }
// }
// _js.change_world(wrappedUpdater, k);
// }
// // shutdownWorld: -> void
// // Shut down all world computations.
// Jsworld.shutdownWorld = function() {
// _js.shutdown();
// };
// // var getAttribs = function(args) {
// // if (args.length == 0) {
// // return []
// // }
// // if (args.length == 1) {
// // return helpers.assocListToHash(args[0]);
// // } else {
// // throw new Error("getAttribs recevied unexpected value for args: "
// // + args);
// // }
// // }
// Jsworld.p = _js.p;
// Jsworld.div = _js.div;
// Jsworld.buttonBang = function(updateWorldF, effectF, attribs) {
// var wrappedF = function(w, evt, k) {
// try {
// // FIXME: Get effects back online!
// // caller(effectF, [world],
// // function(effect) {
// caller(updateWorldF, [w],
// function(newWorld) {
// // world.Kernel.applyEffect(effect);
// k(newWorld);
// });
// // });
// } catch (e) {
// if (typeof(console) !== 'undefined' && console.log && e.stack) {
// console.log(e.stack);
// }
// handleError(e);
// // k(w);
// }
// }
// return _js.button(wrappedF, attribs);
// };
// Jsworld.input = function(type, updateF, attribs) {
// var wrappedUpdater = function(w, evt, k) {
// caller(updateF, [w, evt], k);
// }
// return _js.input(type, wrappedUpdater, attribs);
// };
// Jsworld.get_dash_input_dash_value = function(node) {
// // plt.Kernel.check(node,
// // function(x) { return (plt.Kernel.isString(node) ||
// // node.nodeType ==
// // Node.ELEMENT_NODE) },
// // "get-input-value",
// // "dom-node",
// // 1);
// if (types.isString(node)) {
// return (document.getElementById(node).value || "");
// } else {
// return (node.value || "");
// }
// };
// // Images.
// Jsworld.img = _js.img;
// // text: string -> node
// Jsworld.text = _js.text;
// Jsworld.select = function(options, updateF, attribs) {
// var wrappedUpdater = function(w, e, k) {
// // console.log(e);
// caller(updateF, [w, e.target.value], k);
// }
// return _js.select(attribs, options, wrappedUpdater);
// };
// //////////////////////////////////////////////////////////////////////
// Jsworld.emptyPage = _js.emptyPage;
// Jsworld.placeOnPage = function(elt, left, top, page) {
// deepUnwrapJsValues(elt, function(newElt) {
// elt = types.toDomNode(newElt);});
// return _js.placeOnPage(elt, left, top, page);
// };
// var convertAttribList = function(attribList) {
// var nextElt;
// var key, val;
// var hash = {};
// while (attribList !== EMPTY) {
// nextElt = attribList.first;
// key = nextElt.first;
// val = nextElt.rest.first;
// key = String(key);
// if (isString(val)) {
// val = String(val);
// } else if (isBoolean(val)) {
// // do nothing: the representation is the same.
// } else if (isSymbol(val)) {
// if (String(val) === 'true') {
// val = true;
// } else if (String(val) === 'false') {
// val = false;
// } else {
// val = String(val);
// }
// } else {
// // raise error: neither string nor boolean
// throw new Error(
// plt.baselib.format.format(
// "attribute value ~s neither a string nor a boolean",
// [val]));
// }
// hash[key] = val;
// attribList = attribList.rest;
// }
// return hash;
// }

1
world/main.rkt
View File

@ -16,6 +16,7 @@
#:provided-values (big-bang #:provided-values (big-bang
on-tick on-tick
on-key on-key
on-mouse
key=? key=?
to-draw to-draw
stop-when)) stop-when))

21
world/racket-impl.rkt
View File

@ -1,8 +1,9 @@
#lang s-exp "../lang/base.rkt" #lang s-exp "../lang/base.rkt"
(provide big-bang (provide big-bang
on-tick
to-draw to-draw
on-tick
on-mouse
on-key on-key
key=? key=?
stop-when) stop-when)
@ -13,23 +14,27 @@
(define (big-bang initial-world . args) (define (big-bang initial-world . args)
(error 'big-bang "not done yet")) (error 'big-bang "must be run in JavaScript context"))
(define on-tick (define on-tick
(case-lambda [(handler) (case-lambda [(handler)
(error 'on-tick "not done yet")] (error 'on-tick "must be run in JavaScript context")]
[(handler interval) [(handler interval)
(error 'on-tick "not done yet")])) (error 'on-tick "must be run in JavaScript context")]))
(define (on-mouse handle)
(error 'on-mouse "must be run in JavaScript context"))
(define (to-draw handler) (define (to-draw handler)
(error 'to-draw "not done yet")) (error 'to-draw "must be run in JavaScript context"))
(define (on-key handler) (define (on-key handler)
(error 'on-key "not done yet")) (error 'on-key "must be run in JavaScript context"))
(define (key=? key-1 key-2) (define (key=? key-1 key-2)
(error 'key=? "not done yet")) (error 'key=? "must be run in JavaScript context"))
(define (stop-when handler) (define (stop-when handler)
(error 'stop-when "not done yet")) (error 'stop-when "must be run in JavaScript context"))

582
world/raw-jsworld.js
View File

File diff suppressed because it is too large Load Diff

82
world/scratch/jsworld/define-effect.rkt
View File

@ -1,82 +0,0 @@
#lang s-exp "../lang/base.rkt"
(require "jsworld.rkt")
(require (for-syntax racket/base))
(provide define-effect)
(define-syntax (define-effect stx)
(syntax-case stx ()
[(_ name (field ...) #:impl impl)
(identifier? #'name)
(syntax/loc stx
(define-effect (name #f) (field ...) #:impl impl))]
[(_ (name supertype) (field ...) #:impl impl)
(with-syntax ([field-count
(length (syntax->list #'(field ...)))]
[struct:name
(datum->syntax #'name
(string->symbol
(format "struct:~a"
(syntax-e #'name))))]
[make-name
(datum->syntax #'name
(string->symbol
(format "make-~a"
(syntax-e #'name))))]
[name?
(datum->syntax #'name
(string->symbol
(format "~a?"
(syntax-e #'name))))]
[(field-index ...)
(build-list (length (syntax->list
#'(field ...)))
(lambda (i) i))]
[(accessor ...)
(map (lambda (field)
(datum->syntax
field
(string->symbol
(format "~a-~a"
(syntax-e #'name)
(syntax-e field)))))
(syntax->list #'(field ...)))]
[(mutator ...)
(map (lambda (field)
(datum->syntax
field
(string->symbol
(format "set-~a-~a!"
(syntax-e #'name)
(syntax-e field)))))
(syntax->list #'(field ...)))])
(syntax/loc stx
(begin (define-values (struct:name
make-name
name?
name-accessor
name-mutator)
(make-effect-type 'name
supertype
field-count
impl))
(begin
(define accessor
(make-struct-field-accessor
name-accessor field-index 'field))
...)
(begin
(define mutator
(make-struct-field-mutator
name-mutator field-index 'field))
...)
)))]))

1396
world/scratch/jsworld/jsworld.js
View File

File diff suppressed because it is too large Load Diff

50
world/scratch/jsworld/jsworld.rkt
View File

@ -1,50 +0,0 @@
#lang s-exp "../lang/js-impl/js-impl.rkt"
;; Loaded so we have access to image library stuff, as well as the world kernel
(require "../world/kernel.rkt"
"../image/image.rkt")
(require-js "private/jsworld/jsworld.js"
"private/jsworld.js"
"jsworld.js")
(provide big-bang
to-draw
to-draw-page
key=?
on-tick on-tick!
on-key on-key!
stop-when stop-when!
initial-effect
js-p
js-div
js-button
js-button!
js-input
js-img
js-text
js-select
empty-page
place-on-page
make-world-config
make-effect-type
effect-type?
effect?
#;make-render-effect-type
#;render-effect-type?
world-with-effects
#;make-render-effect
#;render-effect?
#;render-effect-dom-node
#;render-effect-effects)

777
world/scratch/jsworld/private/jsworld.js
View File

@ -1,777 +0,0 @@
// Depends on world.js, world-config.js
(function() {
var world = {};
world.Kernel = STATE.invokedModules["mzscheme-vm/world/kernel"].lookup("kernel");
var Jsworld = jsworld.MobyJsworld = {};
// The real low-level jsworld module:
var _js = jsworld.Jsworld;
var caller;
var setCaller = function(c) {
caller = function(op, args, k) {
c(op, args, k, handleError);
};
};
var unsetCaller = function() {
caller = function(op, args, k) {
throw new Error('caller not defined!');
};
};
unsetCaller();
// The restarted and things to set it
// Note that we never want to restart the same computation
// more than once, so we throw an error if someone tries to do that
var restarter;
var setRestarter = function(r) {
var hasRestarted = false;
restarter = function(v) {
if (hasRestarted) {
throw new Error('Cannot restart twice!');
}
hasRestarted = true;
r(v);
};
};
var unsetRestarter = function() {
restarter = function() {
throw new Error('restarter not defined!');
};
};
unsetRestarter();
var errorReporter = function(e) {
// default: do nothing.
};
var terminator;
var setTerminator = function(t) {
terminator = t;
};
var unsetTerminator = function() {
terminator = function() {
throw new Error('terminator not defined!');
};
};
unsetTerminator();
// mutateStringsInDeepArray: array -> array
// walks and in-place mutates Scheme strings to primitive strings.
var mutateStringsInDeepArray = function(thing) {
var i, length;
if (typeof(thing) === 'object' &&
thing.constructor === Array) {
length = thing.length;
for (i = 0; i < length; i++) {
thing[i] = mutateStringsInDeepArray(thing[i]);
}
} else if (types.isString(thing)) {
return thing.toString();
}
return thing;
};
var userConfigs = [];
var startUserConfigs = function(k) {
helpers.forEachK(userConfigs,
function(aConfig, k2) {
caller(aConfig.startup, aConfig.startupArgs,
function(res) {
aConfig.isRunning = true;
aConfig.shutdownArg = res;
k2()
});
},
handleError,
k);
}
var shutdownUserConfigs = function(k) {
// console.log('shutting down user configs');
var theConfigs = userConfigs;
userConfigs = []
helpers.forEachK(theConfigs,
function(aConfig, k2) {
// console.log(' shutting down a config');
if (aConfig.isRunning) {
aConfig.isRunning = false;
caller(aConfig.shutdown, [aConfig.shutdownArg], k2);
} else {
k2();
}
},
handleError,
k);
}
var expandHandler = function(handler) {
return types.jsValue('function', function() {
var wrappedStimulusArgs = [];
for (var i = 0; i < arguments.length; i++) {
wrappedStimulusArgs.push( helpers.wrapJsValue(arguments[i]) );
}
Jsworld.updateWorld(
function(w, k) {
var args = [w].concat(wrappedStimulusArgs);
caller(handler, args, k);
},
function() {});
});
};
// var unwrapWorldEffects = function(w) {
// if ( _js.has_effects(w) ) {
// var unwrappedEffects =
// helpers.map(function(e) {
// if ( types.isEffect(e) ) {
// return types.makeJsworldEffect(function(k) {
// caller(types.effectThunk(e), [], k);
// });
// }
// else {
// return e;
// }
// },
// w.getEffects());
// var returnVal = _js.with_multiple_effects(w.getWorld(), unwrappedEffects);
// return returnVal;
// }
// else {
// return w;
// }
// };
var deepUnwrapJsValues = function(x, k) {
if ( types.isJsValue(x) ) {
k(x.unbox());
}
else if ( types.isRenderEffect(x) ) {
x.callImplementation(caller, function(y) { deepUnwrapJsValues(y, k); });
}
// var effects = helpers.schemeListToArray( types.renderEffectEffects(x) ).reverse();
// types.setRenderEffectEffects(x, types.EMPTY);
//
// helpers.forEachK(effects,
// function(ef, k2) { caller(ef, [], k2); },
// handleError,
// function() { deepUnwrapJsValues(types.renderEffectDomNode(x), k); });
// }
else if ( types.isPair(x) ) {
deepUnwrapJsValues(x.first(), function(first) {
deepUnwrapJsValues(x.rest(), function(rest) {
k( types.cons(first, rest) );
});
});
}
else {
k(x);
}
};
// isHandler: X -> boolean
// Right now, a handler is a function that consumes and produces
// configs. We should tighten up the type check eventually.
var isHandler = function(x) {
return typeof(x) == 'function';
}
//////////////////////////////////////////////////////////////////////
//From this point forward, we define wrappers to integrate jsworld
//with Moby.
// getBigBangWindow: -> window
var getBigBangWindow = function() {
if (window.document.getElementById("jsworld-div") !== undefined) {
return window;
} else {
var newDiv = window.document.createElement("div");
newDiv.id = 'jsworld-div';
window.document.appendChild(newDiv);
return window;
}
}
// types are
// sexp: (cons node (listof sexp))
// css-style: (node (listof (list string string)))
// Exports:
var isPair = types.isPair;
var isEmpty = function(x) { return x === types.EMPTY; };
var isList = function(x) { return (isPair(x) || isEmpty(x)); };
// The default printWorldHook will write the written content of the node.
// We probably want to invoke the pretty printer here instead!
Jsworld.printWorldHook = function(world, node) {
var newNode;
if(node.lastChild == null) {
newNode = types.toDomNode(world);
node.appendChild(newNode);
helpers.maybeCallAfterAttach(newNode);
} else {
newNode = types.toDomNode(world);
node.replaceChild(newNode, node.lastChild);
helpers.maybeCallAfterAttach(newNode);
}
};
// Figure out the target of an event.
// http://www.quirksmode.org/js/events_properties.html#target
var findEventTarget = function(e) {
var targ;
if (e.target)
targ = e.target;
else if (e.srcElement)
targ = e.srcElement;
if (targ.nodeType == 3) // defeat Safari bug
targ = targ.parentNode;
return targ;
}
// isNode: any -> boolean
// Returns true if the thing has a nodeType.
var isNode = function(thing) {
return thing && typeof(thing.nodeType) != 'undefined';
}
// checkWellFormedDomTree: X X (or number undefined) -> void
// Check to see if the tree is well formed. If it isn't,
// we need to raise a meaningful error so the user can repair
// the structure.
//
// Invariants:
// The dom tree must be a pair.
// The first element must be a node.
// Each of the rest of the elements must be dom trees.
// If the first element is a text node, it must NOT have children.
var checkWellFormedDomTree = function(x, top, index) {
var fail = function(formatStr, formatArgs) {
throw types.schemeError(
types.incompleteExn(types.exnFailContract,
helpers.format(formatStr, formatArgs),
[]));
}
if (_js.isPage(x)) {
return;
}
if (types.isPair(x)) {
var firstElt = x.first();
var restElts = x.rest();
if (! isNode(firstElt)) {
fail("on-draw: expected a dom-element, but received ~s instead, the first element within ~s", [firstElt, top]);
}
if (firstElt.nodeType == Node.TEXT_NODE && !restElts.isEmpty() ) {
fail("on-draw: the text node ~s must not have children. It has ~s", [firstElt, restElts]);
}
var i = 2;
while( !restElts.isEmpty() ) {
checkWellFormedDomTree(restElts.first(), x, i);
restElts = restElts.rest();
i++;
}
} else {
var formatStr = "on-draw: expected a dom-s-expression, but received ~s instead";
var formatArgs = [x];
if (index != undefined) {
formatStr += ", the ~a element within ~s";
formatArgs.push( helpers.ordinalize(index) );
formatArgs.push(top);
}
formatStr += ".";
fail(formatStr, formatArgs);
}
};
// Compatibility for attaching events to nodes.
var attachEvent = function(node, eventName, fn) {
if (node.addEventListener) {
// Mozilla
node.addEventListener(eventName, fn, false);
} else {
// IE
node.attachEvent('on' + eventName, fn, false);
}
return function() {
detachEvent(node, eventName, fn);
}
};
var detachEvent = function(node, eventName, fn) {
if (node.addEventListener) {
// Mozilla
node.removeEventListener(eventName, fn, false);
} else {
// IE
node.detachEvent('on' + eventName, fn, false);
}
}
var preventDefault = function(event) {
if (event.preventDefault) {
event.preventDefault();
} else {
event.returnValue = false;
}
}
var stopPropagation = function(event) {
if (event.stopPropagation) {
event.stopPropagation();
} else {
event.cancelBubble = true;
}
}
// bigBang: world dom (listof (list string string)) (arrayof handler) -> world
Jsworld.bigBang = function(initWorld, toplevelNode, handlers, theCaller, theRestarter, onFail) {
// shutdownListeners: arrayof (-> void)
// We maintain a list of thunks that need to be called as soon as we come out of
// bigBang, to do cleanup.
var shutdownListeners = [];
var onTermination = function(w) {
for (var i = 0; i < shutdownListeners.length; i++) {
try {
shutdownListeners[i]();
} catch (e) { }
}
shutdownUserConfigs(function() {
unsetCaller();
theRestarter(w);
});
}
//console.log('in high level big-bang');
errorReporter = onFail;
setCaller(theCaller);
setRestarter(theRestarter);
setTerminator(function(w) {
detachEvent(toplevelNode, 'click', absorber);
shutdownUserConfigs(function() {
unsetCaller();
unsetTerminator();
restarter(w);
});
});
var attribs = types.EMPTY;
// Ensure that the toplevelNode can be focused by mouse or keyboard
toplevelNode.tabIndex = 0;
// Absorb all click events so they don't bubble up.
var absorber = function(e) {
preventDefault(e);
stopPropagation(e);
return false;
}
attachEvent(toplevelNode, 'click', absorber);
shutdownListeners.push(function() { detachEvent(toplevelNode, 'click', absorber)});
var config = new world.Kernel.config.WorldConfig();
for(var i = 0; i < handlers.length; i++) {
if (isList(handlers[i])) {
attribs = handlers[i];
}
else if (isHandler(handlers[i])) {
config = handlers[i](config);
}
else if ( types.isWorldConfig(handlers[i]) ) {
handlers[i].startupArgs = helpers.map(expandHandler, handlers[i].startupArgs);
userConfigs.push(handlers[i]);
}
}
config = config.updateAll({'changeWorld': Jsworld.updateWorld,
'shutdownWorld': Jsworld.shutdownWorld});
var stimuli = new world.Kernel.stimuli.StimuliHandler(config, caller, restarter);
var wrappedHandlers = [];
var wrappedRedraw;
var wrappedRedrawCss;
if (config.lookup('onDraw')) {
wrappedRedraw = function(w, k) {
try {
caller(config.lookup('onDraw'), [w],
function(newDomTree) {
deepUnwrapJsValues(newDomTree, function(unwrappedTree) {
checkWellFormedDomTree(unwrappedTree, unwrappedTree, undefined);
var result = [toplevelNode,
helpers.deepListToArray(unwrappedTree)];
k(result);
});
});
} catch (e) {
handleError(e);
// throw e;
}
}
if (config.lookup('onDrawCss')) {
wrappedRedrawCss = function(w, k) {
try {
caller(config.lookup('onDrawCss'), [w],
function(res) {
var result = helpers.deepListToArray(res);
result = mutateStringsInDeepArray(result);
// plt.Kernel.setLastLoc(undefined);
k(result);
});
} catch (e) {
handleError(e);
// throw e;
}
}
}
else {
wrappedRedrawCss = function(w, k) { k([]); };
}
wrappedHandlers.push(_js.on_draw(wrappedRedraw, wrappedRedrawCss));
} else if (config.lookup('onRedraw')) {
var reusableCanvas = undefined;
var reusableCanvasNode = undefined;
wrappedRedraw = function(w, k) {
try {
//console.log('in onRedraw handler');
caller(config.lookup('onRedraw'), [w],
function(aScene) {
// Performance hack: if we're using onRedraw, we know
// we've got a scene, so we optimize away the repeated
// construction of a canvas object.
if ( world.Kernel.isImage(aScene) ) {
var width = aScene.getWidth();
var height = aScene.getHeight();
if (! reusableCanvas) {
reusableCanvas = world.Kernel.makeCanvas(width, height);
// Note: the canvas object may itself manage objects,
// as in the case of an excanvas. In that case, we must make
// sure jsworld doesn't try to disrupt its contents!
reusableCanvas.jsworldOpaque = true;
reusableCanvasNode = _js.node_to_tree(reusableCanvas);
}
reusableCanvas.width = width;
reusableCanvas.height = height;
var ctx = reusableCanvas.getContext("2d");
aScene.render(ctx, 0, 0);
k([toplevelNode, reusableCanvasNode]);
} else {
k([toplevelNode, _js.node_to_tree(types.toDomNode(aScene))]);
}
});
} catch (e) {
handleError(e);
// throw e;
}
}
wrappedRedrawCss = function(w, k) {
//console.log('in RedrawCss handler');
k([[reusableCanvas,
["width", reusableCanvas.width + "px"],
["height", reusableCanvas.height + "px"]]]);
}
wrappedHandlers.push(_js.on_draw(wrappedRedraw, wrappedRedrawCss));
} else {
wrappedHandlers.push(_js.on_world_change
(function(w, k) {
Jsworld.printWorldHook(w, toplevelNode);
k();
}));
}
if (config.lookup('tickDelay')) {
var wrappedTick = function(w, k) {
caller(config.lookup('onTick'),
[w],
k);
}
var wrappedDelay = jsnums.toFixnum( config.lookup('tickDelay') );
wrappedHandlers.push(_js.on_tick(wrappedDelay, wrappedTick));
}
if (config.lookup('stopWhen')) {
wrappedHandlers.push(_js.stop_when(
function(w, k) {
caller(config.lookup('stopWhen'), [w],
function(res) { k(res); });
}));
}
if (config.lookup('onKey')) {
var wrappedKey = function(w, e, k) {
caller(config.lookup('onKey'), [w, helpers.getKeyCodeName(e)], k);
}
wrappedHandlers.push(_js.on_key(wrappedKey));
toplevelNode.focus();
}
if (config.lookup('initialEffect')) {
var updaters =
world.Kernel.applyEffect(config.lookup('initialEffect'));
for (var i = 0 ; i < updaters.length; i++) {
if (config.lookup('stopWhen') &&
config.lookup('stopWhen')([initWorld])) {
break;
} else {
initWorld = updaters[i](initWorld);
}
}
}
_js.big_bang(toplevelNode,
initWorld,
wrappedHandlers,
helpers.assocListToHash(attribs),
terminator);
startUserConfigs(function() {});
return {
breaker: function() {
handleError(types.schemeError(
types.incompleteExn(types.exnBreak, 'user break', [])));
}
};
}
var handleError = function(e) {
// helpers.reportError(e);
// When something bad happens, shut down
// the world computation.
// helpers.reportError("Shutting down jsworld computations");
// world.Kernel.stimuli.onShutdown();
world.Kernel.stimuli.massShutdown();
shutdownUserConfigs(function() {
errorReporter(e);
// console.log('Got an error, the error was:');
// console.log(e);
if (typeof(console) !== 'undefined' && console.log) {
if (e.stack) {
console.log(e.stack);
}
else {
console.log(e);
}
}
if ( types.isSchemeError(e) ) {
terminator(e);
}
else if ( types.isInternalError(e) ) {
terminator(e);
}
else if (typeof(e) == 'string') {
terminator( types.schemeError(types.incompleteExn(types.exnFail, e, [])) );
}
else if (e instanceof Error) {
terminator( types.schemeError(types.incompleteExn(types.exnFail, e.message, [])) );
}
else {
terminator( types.schemeError(e) );
}
});
}
// updateWorld: CPS( CPS(world -> world) -> void )
Jsworld.updateWorld = function(updater, k) {
var wrappedUpdater = function(w, k2) {
try {
updater(w, k2);
} catch (e) {
if (typeof(console) !== 'undefined' && console.log && e.stack) {
console.log(e.stack);
}
handleError(e);
// k2(w);
}
}
_js.change_world(wrappedUpdater, k);
}
// shutdownWorld: -> void
// Shut down all world computations.
Jsworld.shutdownWorld = function() {
_js.shutdown();
};
// var getAttribs = function(args) {
// if (args.length == 0) {
// return []
// }
// if (args.length == 1) {
// return helpers.assocListToHash(args[0]);
// } else {
// throw new Error("getAttribs recevied unexpected value for args: "
// + args);
// }
// }
Jsworld.p = _js.p;
Jsworld.div = _js.div;
Jsworld.buttonBang = function(updateWorldF, effectF, attribs) {
var wrappedF = function(w, evt, k) {
try {
// FIXME: Get effects back online!
// caller(effectF, [world],
// function(effect) {
caller(updateWorldF, [w],
function(newWorld) {
// world.Kernel.applyEffect(effect);
k(newWorld);
});
// });
} catch (e) {
if (typeof(console) !== 'undefined' && console.log && e.stack) {
console.log(e.stack);
}
handleError(e);
// k(w);
}
}
return _js.button(wrappedF, attribs);
};
Jsworld.input = function(type, updateF, attribs) {
var wrappedUpdater = function(w, evt, k) {
caller(updateF, [w, evt], k);
}
return _js.input(type, wrappedUpdater, attribs);
};
Jsworld.get_dash_input_dash_value = function(node) {
// plt.Kernel.check(node,
// function(x) { return (plt.Kernel.isString(node) ||
// node.nodeType ==
// Node.ELEMENT_NODE) },
// "get-input-value",
// "dom-node",
// 1);
if (types.isString(node)) {
return (document.getElementById(node).value || "");
} else {
return (node.value || "");
}
};
// Images.
Jsworld.img = _js.img;
// text: string -> node
Jsworld.text = _js.text;
Jsworld.select = function(options, updateF, attribs) {
var wrappedUpdater = function(w, e, k) {
// console.log(e);
caller(updateF, [w, e.target.value], k);
}
return _js.select(attribs, options, wrappedUpdater);
};
//////////////////////////////////////////////////////////////////////
Jsworld.emptyPage = _js.emptyPage;
Jsworld.placeOnPage = function(elt, left, top, page) {
deepUnwrapJsValues(elt, function(newElt) {
elt = types.toDomNode(newElt);});
return _js.placeOnPage(elt, left, top, page);
};
// fixme: add support for textarea, h1, canvas
// // raw_node: scheme-value assoc -> node
// Jsworld.rawNode = function(x, args) {
// var attribs = getAttribs(args);
// var node = _js.raw_node(types.toDomNode(x), attribs);
// node.toWrittenString = function(cache) { return "(js-raw-node ...)"; }
// node.toDisplayedString = node.toWrittenString;
// node.toDomNode = function(cache) { return node; }
// return node;
// };
})();

1488
world/scratch/jsworld/private/jsworld/jsworld.js
View File

File diff suppressed because it is too large Load Diff

1938
world/scratch/world/kernel.js
View File

File diff suppressed because it is too large Load Diff

3
world/scratch/world/kernel.rkt
View File

@ -1,3 +0,0 @@
#lang s-exp "../lang/js-impl/js-impl.rkt"
(require-js "kernel.js")