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

fixing the assembler

Browse Source
This commit is contained in:
Danny Yoo 2011-03-20 22:43:58 -04:00
parent ee3ed353b0
commit 4949eef3c5
2 changed files with 30 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
assemble.rkt
View File

@ -344,17 +344,14 @@ EOF
(EnvWholePrefixReference-depth a-prefix-ref))) (EnvWholePrefixReference-depth a-prefix-ref)))
(: assemble-env-reference/closure-capture (EnvReference -> String)) (: assemble-env-reference/closure-capture (Natural -> String))
;; When we're capturing the values for a closure, we need to not unbox ;; When we're capturing the values for a closure, we need to not unbox
;; lexical references: they must remain boxes. ;; lexical references: they must remain boxes. So all we need is
(define (assemble-env-reference/closure-capture ref) ;; the depth into the environment.
(cond (define (assemble-env-reference/closure-capture depth)
[(EnvLexicalReference? ref) (format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]" depth))
(EnvLexicalReference-depth ref))]
[(EnvWholePrefixReference? ref)
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
(EnvWholePrefixReference-depth ref))]))
(: assemble-display-name ((U Symbol False) -> String)) (: assemble-display-name ((U Symbol False) -> String))
(define (assemble-display-name symbol-or-string) (define (assemble-display-name symbol-or-string)
@ -401,10 +398,11 @@ EOF
(cond (cond
[(CheckToplevelBound!? op) [(CheckToplevelBound!? op)
(format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { throw new Error(\"Not bound: \" + ~s); }" (format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { throw new Error(\"Not bound: \" + MACHINE.env[MACHINE.env.length - 1 - ~a].names[~a]); }"
(CheckToplevelBound!-depth op) (CheckToplevelBound!-depth op)
(CheckToplevelBound!-pos op) (CheckToplevelBound!-pos op)
(symbol->string (CheckToplevelBound!-name op)))] (CheckToplevelBound!-depth op)
(CheckToplevelBound!-pos op))]
[(CheckClosureArity!? op) [(CheckClosureArity!? op)
(format "if (! (MACHINE.proc instanceof Closure && MACHINE.proc.arity === ~a)) { if (! (MACHINE.proc instanceof Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure\"); } }" (format "if (! (MACHINE.proc instanceof Closure && MACHINE.proc.arity === ~a)) { if (! (MACHINE.proc instanceof Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure\"); } }"
@ -413,7 +411,7 @@ EOF
[(ExtendEnvironment/Prefix!? op) [(ExtendEnvironment/Prefix!? op)
(let: ([names : (Listof (U Symbol False)) (ExtendEnvironment/Prefix!-names op)]) (let: ([names : (Listof (U Symbol False)) (ExtendEnvironment/Prefix!-names op)])
(format "MACHINE.env.push([~a]);" (format "MACHINE.env.push([~a]); MACHINE.env[MACHINE.env.length-1].names = [~a];"
(string-join (map (lambda: ([n : (U Symbol False)]) (string-join (map (lambda: ([n : (U Symbol False)])
(if (symbol? n) (if (symbol? n)
(format "MACHINE.params.currentNamespace[~s] || Primitives[~s]" (format "MACHINE.params.currentNamespace[~s] || Primitives[~s]"
@ -421,6 +419,12 @@ EOF
(symbol->string n)) (symbol->string n))
"false")) "false"))
names) names)
",")
(string-join (map (lambda: ([n : (U Symbol False)])
(if (symbol? n)
(format "~s" (symbol->string n))
"false"))
names)
",")))] ",")))]
[(InstallClosureValues!? op) [(InstallClosureValues!? op)

31
test-assemble.rkt
View File

@ -144,7 +144,7 @@
;; Simple application ;; Simple application
(test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0 '+)) (make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
(make-PushEnvironment 2 #f) (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const 3)) (make-Const 3))
@ -179,8 +179,7 @@
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0
(list (make-EnvLexicalReference 0 #f) (list 0 1)
(make-EnvLexicalReference 1 #f))
'closureStart))) 'closureStart)))
"MACHINE.val.closedVals[1] + ',' + MACHINE.val.closedVals[0]") "MACHINE.val.closedVals[1] + ',' + MACHINE.val.closedVals[0]")
"hello,world") "hello,world")
@ -199,8 +198,7 @@
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0
(list (make-EnvLexicalReference 0 #f) (list 0 1)
(make-EnvLexicalReference 1 #f))
'closureStart)) 'closureStart))
(make-PopEnvironment 2 0) (make-PopEnvironment 2 0)
(make-GotoStatement (make-Label 'closureStart)) (make-GotoStatement (make-Label 'closureStart))
@ -224,8 +222,7 @@
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0
(list (make-EnvLexicalReference 0 #f) (list 0 1)
(make-EnvLexicalReference 1 #f))
'closureStart)) 'closureStart))
(make-PopEnvironment 2 0) (make-PopEnvironment 2 0)
(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))) (make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)))
@ -247,8 +244,7 @@
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5
(list (make-EnvLexicalReference 0 #f) (list 0 1)
(make-EnvLexicalReference 1 #f))
'closureStart)) 'closureStart))
(make-PopEnvironment 2 0) (make-PopEnvironment 2 0)
(make-PerformStatement (make-CheckClosureArity! 5))))) (make-PerformStatement (make-CheckClosureArity! 5)))))
@ -270,8 +266,7 @@
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5
(list (make-EnvLexicalReference 0 #f) (list 0 1)
(make-EnvLexicalReference 1 #f))
'closureStart)) 'closureStart))
(make-PopEnvironment 2 0) (make-PopEnvironment 2 0)
(make-PerformStatement (make-CheckClosureArity! 1))))) (make-PerformStatement (make-CheckClosureArity! 1)))))
@ -312,7 +307,7 @@
;; Give a primitive procedure in val ;; Give a primitive procedure in val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0 '+)) ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue) ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
@ -323,7 +318,7 @@
;; Give a primitive procedure in proc, but test val ;; Give a primitive procedure in proc, but test val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0 '+)) ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue) ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
@ -334,7 +329,7 @@
;; Give a primitive procedure in proc and test proc ;; Give a primitive procedure in proc and test proc
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0 '+)) ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'onTrue) ,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
@ -348,7 +343,7 @@
;; Set-toplevel ;; Set-toplevel
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor)))
,(make-AssignImmediateStatement 'val (make-Const "Kathi")) ,(make-AssignImmediateStatement 'val (make-Const "Kathi"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'advisor) (make-Reg 'val))) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)))
"MACHINE.env[0][0]") "MACHINE.env[0][0]")
"Kathi") "Kathi")
@ -358,13 +353,13 @@
(let ([dont-care (let ([dont-care
(with-handlers ([void (lambda (exn) (return))]) (with-handlers ([void (lambda (exn) (return))])
(E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable)))))]) ,(make-PerformStatement (make-CheckToplevelBound! 0 0)))))])
(raise "I expected an error"))) (raise "I expected an error")))
;; check-toplevel-bound shouldn't fail here. ;; check-toplevel-bound shouldn't fail here.
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor)))
,(make-AssignImmediateStatement 'val (make-Const "Shriram")) ,(make-AssignImmediateStatement 'val (make-Const "Shriram"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'another-advisor) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'another-advisor))) ,(make-PerformStatement (make-CheckToplevelBound! 0 0)))
"MACHINE.env[0][0]") "MACHINE.env[0][0]")
"Shriram") "Shriram")