From 4949eef3c5f8c20e9721a0e1bb92ae36f9233c47 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 20 Mar 2011 22:43:58 -0400 Subject: [PATCH] fixing the assembler --- assemble.rkt | 30 +++++++++++++++++------------- test-assemble.rkt | 31 +++++++++++++------------------ 2 files changed, 30 insertions(+), 31 deletions(-) diff --git a/assemble.rkt b/assemble.rkt index 832919f..f78594c 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -344,17 +344,14 @@ EOF (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 -;; lexical references: they must remain boxes. -(define (assemble-env-reference/closure-capture ref) - (cond - [(EnvLexicalReference? ref) - (format "MACHINE.env[MACHINE.env.length - 1 - ~a]" - (EnvLexicalReference-depth ref))] - [(EnvWholePrefixReference? ref) - (format "MACHINE.env[MACHINE.env.length - 1 - ~a]" - (EnvWholePrefixReference-depth ref))])) +;; lexical references: they must remain boxes. So all we need is +;; the depth into the environment. +(define (assemble-env-reference/closure-capture depth) + (format "MACHINE.env[MACHINE.env.length - 1 - ~a]" + depth)) + (: assemble-display-name ((U Symbol False) -> String)) (define (assemble-display-name symbol-or-string) @@ -401,10 +398,11 @@ EOF (cond [(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!-pos op) - (symbol->string (CheckToplevelBound!-name op)))] + (CheckToplevelBound!-depth op) + (CheckToplevelBound!-pos 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\"); } }" @@ -413,7 +411,7 @@ EOF [(ExtendEnvironment/Prefix!? 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)]) (if (symbol? n) (format "MACHINE.params.currentNamespace[~s] || Primitives[~s]" @@ -421,6 +419,12 @@ EOF (symbol->string n)) "false")) names) + ",") + (string-join (map (lambda: ([n : (U Symbol False)]) + (if (symbol? n) + (format "~s" (symbol->string n)) + "false")) + names) ",")))] [(InstallClosureValues!? op) diff --git a/test-assemble.rkt b/test-assemble.rkt index 4154e82..dfaa876 100644 --- a/test-assemble.rkt +++ b/test-assemble.rkt @@ -144,7 +144,7 @@ ;; Simple application (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-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 3)) @@ -179,8 +179,7 @@ (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 - (list (make-EnvLexicalReference 0 #f) - (make-EnvLexicalReference 1 #f)) + (list 0 1) 'closureStart))) "MACHINE.val.closedVals[1] + ',' + MACHINE.val.closedVals[0]") "hello,world") @@ -199,8 +198,7 @@ (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 - (list (make-EnvLexicalReference 0 #f) - (make-EnvLexicalReference 1 #f)) + (list 0 1) 'closureStart)) (make-PopEnvironment 2 0) (make-GotoStatement (make-Label 'closureStart)) @@ -224,8 +222,7 @@ (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 - (list (make-EnvLexicalReference 0 #f) - (make-EnvLexicalReference 1 #f)) + (list 0 1) 'closureStart)) (make-PopEnvironment 2 0) (make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))) @@ -247,8 +244,7 @@ (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 - (list (make-EnvLexicalReference 0 #f) - (make-EnvLexicalReference 1 #f)) + (list 0 1) 'closureStart)) (make-PopEnvironment 2 0) (make-PerformStatement (make-CheckClosureArity! 5))))) @@ -270,8 +266,7 @@ (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 - (list (make-EnvLexicalReference 0 #f) - (make-EnvLexicalReference 1 #f)) + (list 0 1) 'closureStart)) (make-PopEnvironment 2 0) (make-PerformStatement (make-CheckClosureArity! 1))))) @@ -312,7 +307,7 @@ ;; Give a primitive procedure in val (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-AssignImmediateStatement 'val (make-Const 'not-ok)) ,(make-GotoStatement (make-Label 'end)) @@ -323,7 +318,7 @@ ;; Give a primitive procedure in proc, but test val (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-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ,(make-GotoStatement (make-Label 'end)) @@ -334,7 +329,7 @@ ;; Give a primitive procedure in proc and test proc (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-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ,(make-GotoStatement (make-Label 'end)) @@ -348,7 +343,7 @@ ;; Set-toplevel (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor))) ,(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]") "Kathi") @@ -358,13 +353,13 @@ (let ([dont-care (with-handlers ([void (lambda (exn) (return))]) (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"))) ;; check-toplevel-bound shouldn't fail here. (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor))) ,(make-AssignImmediateStatement 'val (make-Const "Shriram")) - ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'another-advisor) (make-Reg 'val)) - ,(make-PerformStatement (make-CheckToplevelBound! 0 0 'another-advisor))) + ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)) + ,(make-PerformStatement (make-CheckToplevelBound! 0 0))) "MACHINE.env[0][0]") "Shriram")