diff --git a/assemble.rkt b/assemble.rkt index 09df986..f28c5b9 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -341,29 +341,16 @@ EOF (define (assemble-op-statement op) (cond [(SetToplevel!? op) - (error 'assemble-op-statement) - #;(let ([depth (first assembled-inputs)] - [pos (second assembled-inputs)] - [name (third assembled-inputs)] - [env (fourth assembled-inputs)] - [val (fifth assembled-inputs)]) - (format "(~a).valss[~a][~a] = ~a;" - env - depth - pos - val))] + (format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a] = MACHINE.val;" + (SetToplevel!-depth op) + (SetToplevel!-pos op))] [(CheckToplevelBound!? op) - (error 'assemble-op-statement) - #;(let ([depth (first assembled-inputs)] - [pos (second assembled-inputs)] - [name (third assembled-inputs)] - [env (fourth assembled-inputs)]) - (format "if ((~a).valss[~a][~a] === undefined) { throw new Error(\"Not bound: \" + ~a); }" - env - depth - pos - name))] + (format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { throw new Error(\"Not bound: \" + ~s); }" + (CheckToplevelBound!-depth op) + (CheckToplevelBound!-pos op) + (symbol->string (CheckToplevelBound!-name op)))] + [(CheckClosureArity!? op) ;; fixme (error 'assemble-op-statement)] diff --git a/test-all.rkt b/test-all.rkt index f900a03..e861d9a 100644 --- a/test-all.rkt +++ b/test-all.rkt @@ -3,7 +3,7 @@ (require "test-find-toplevel-variables.rkt" "test-simulator.rkt" "test-compiler.rkt" - + "test-assemble.rkt" #; test-browser-evaluate #; test-package ) \ No newline at end of file diff --git a/test-assemble.rkt b/test-assemble.rkt index 3cbc088..fab6d8f 100644 --- a/test-assemble.rkt +++ b/test-assemble.rkt @@ -20,7 +20,12 @@ (syntax/loc #'stx (begin (printf "Running ~s ...\n" (syntax->datum #'expr)) - (let ([actual expr]) + (let ([actual + (with-handlers ([void + (lambda (exn) + (raise-syntax-error #f (format "Runtime error: got ~s" exn) + #'stx))]) + expr)]) (unless (equal? actual expected) (raise-syntax-error #f (format "Expected ~s, got ~s" expected actual) #'stx)) @@ -247,6 +252,26 @@ +;; Set-toplevel +(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor))) + ,(make-AssignImmediateStatement 'val (make-Const "Kathi")) + ,(make-PerformStatement (make-SetToplevel! 0 0 'some-variable))) + "MACHINE.env[0][0]") + "Kathi") - +;; check-toplevel-bound +(let/ec return + (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)))))]) + (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-PerformStatement (make-SetToplevel! 0 0 'some-variable)) + ,(make-PerformStatement (make-CheckToplevelBound! 0 0 'another-advisor))) + "MACHINE.env[0][0]") + "Shriram") diff --git a/test-simulator.rkt b/test-simulator.rkt index 043a00f..ef48af8 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -223,8 +223,6 @@ ;; AssignPrimOpStatement (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))]) - ;; FIXME: I'm hitting what appears to be a Typed Racket bug that prevents me from inspecting - ;; the toplevel structure in the environment... :( (test (first (machine-env (run m))) (make-toplevel (list (lookup-primitive '+) (lookup-primitive '-)