From e5ca5364b63ca122ca8374cfb6d28a05e382093c Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 14 Mar 2011 18:06:14 -0400 Subject: [PATCH] correcting bug with my implementation of lexical scope --- assemble.rkt | 12 +++++++----- compile.rkt | 9 ++++++--- find-toplevel-variables.rkt | 2 +- il-structs.rkt | 2 +- lexical-env.rkt | 32 ++++++++++++++++++++++++++++---- lexical-structs.rkt | 5 +++-- simulator.rkt | 5 ++++- test-all.rkt | 5 +++-- test-browser-evaluate.rkt | 2 +- 9 files changed, 54 insertions(+), 20 deletions(-) diff --git a/assemble.rkt b/assemble.rkt index 9261131..5e0257b 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -387,12 +387,14 @@ EOF )] [(ExtendEnvironment/Prefix!? op) - (let: ([names : (Listof Symbol) (ExtendEnvironment/Prefix!-names op)]) + (let: ([names : (Listof (U Symbol False)) (ExtendEnvironment/Prefix!-names op)]) (format "MACHINE.env.push([~a]);" - (string-join (map (lambda: ([n : Symbol]) - (format "MACHINE.params.currentNamespace[~s] || Primitives[~s]" - (symbol->string n) - (symbol->string n))) + (string-join (map (lambda: ([n : (U Symbol False)]) + (if (symbol? n) + (format "MACHINE.params.currentNamespace[~s] || Primitives[~s]" + (symbol->string n) + (symbol->string n)) + "false")) names) ",")))] diff --git a/compile.rkt b/compile.rkt index 4ba353a..8121312 100644 --- a/compile.rkt +++ b/compile.rkt @@ -70,7 +70,7 @@ (: compile-top (Top CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-top top cenv target linkage) (let*: ([cenv : CompileTimeEnvironment (extend-lexical-environment cenv (Top-prefix top))] - [names : (Listof Symbol) (Prefix-names (Top-prefix top))]) + [names : (Listof (U Symbol False)) (Prefix-names (Top-prefix top))]) (append-instruction-sequences (make-instruction-sequence `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) @@ -258,6 +258,7 @@ lexical-references))))) (compile-lambda-body exp cenv lexical-references + free-vars proc-entry) after-lambda))) @@ -268,11 +269,12 @@ (: compile-lambda-body (Lam CompileTimeEnvironment (Listof EnvReference) + (Listof Symbol) Linkage -> InstructionSequence)) ;; Compiles the body of the lambda in the appropriate environment. -(define (compile-lambda-body exp cenv lexical-references proc-entry) +(define (compile-lambda-body exp cenv lexical-references free-variables proc-entry) (let*: ([formals : (Listof Symbol) (Lam-parameters exp)] [extended-cenv : CompileTimeEnvironment (extend-lexical-environment/names @@ -280,7 +282,8 @@ formals)] [extended-cenv : CompileTimeEnvironment (lexical-references->compile-time-environment - lexical-references cenv extended-cenv)]) + lexical-references cenv extended-cenv + free-variables)]) (append-instruction-sequences (make-instruction-sequence `(,proc-entry diff --git a/find-toplevel-variables.rkt b/find-toplevel-variables.rkt index 8839014..9fa159c 100644 --- a/find-toplevel-variables.rkt +++ b/find-toplevel-variables.rkt @@ -15,7 +15,7 @@ (cond [(Top? exp) (list-difference (loop (Top-code exp)) - (Prefix-names (Top-prefix exp)))] + (filter symbol? (Prefix-names (Top-prefix exp))))] [(Constant? exp) empty] diff --git a/il-structs.rkt b/il-structs.rkt index 91d6976..b5ff080 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -191,7 +191,7 @@ ;; Extends the environment with a prefix that holds ;; lookups to the namespace. -(define-struct: ExtendEnvironment/Prefix! ([names : (Listof Symbol)]) +(define-struct: ExtendEnvironment/Prefix! ([names : (Listof (U Symbol False))]) #:transparent) ;; Adjusts the environment by pushing the values in the diff --git a/lexical-env.rkt b/lexical-env.rkt index 267799b..ddeb804 100644 --- a/lexical-env.rkt +++ b/lexical-env.rkt @@ -10,14 +10,15 @@ extend-lexical-environment/boxed-names extend-lexical-environment/placeholders collect-lexical-references - lexical-references->compile-time-environment) + lexical-references->compile-time-environment + place-prefix-mask) ;; find-variable: symbol compile-time-environment -> lexical-address ;; Find where the variable should be located. (: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress)) (define (find-variable name cenv) - (: find-pos (Symbol (Listof Symbol) -> Natural)) + (: find-pos (Symbol (Listof (U Symbol False)) -> Natural)) (define (find-pos sym los) (cond [(eq? sym (car los)) @@ -125,9 +126,10 @@ (: lexical-references->compile-time-environment ((Listof EnvReference) CompileTimeEnvironment CompileTimeEnvironment + (Listof Symbol) -> CompileTimeEnvironment)) ;; Creates a lexical environment containing the closure's bindings. -(define (lexical-references->compile-time-environment refs cenv new-cenv) +(define (lexical-references->compile-time-environment refs cenv new-cenv symbols-to-keep) (let: loop : CompileTimeEnvironment ([refs : (Listof EnvReference) (reverse refs)] [new-cenv : CompileTimeEnvironment new-cenv]) (cond @@ -142,5 +144,27 @@ new-cenv))] [(EnvWholePrefixReference? a-ref) (loop (rest refs) - (cons (list-ref cenv (EnvWholePrefixReference-depth a-ref)) + (cons (place-prefix-mask + (ensure-Prefix (list-ref cenv (EnvWholePrefixReference-depth a-ref))) + symbols-to-keep) new-cenv))]))]))) + +(: ensure-Prefix (Any -> Prefix)) +(define (ensure-Prefix x) + (if (Prefix? x) + x + (error 'ensure-Prefix "~s" x))) + + + +(: place-prefix-mask (Prefix (Listof Symbol) -> Prefix)) +;; Masks elements of the prefix off. +(define (place-prefix-mask a-prefix symbols-to-keep) + (make-Prefix + (map (lambda: ([n : (U Symbol False)]) + (cond [(symbol? n) + (if (member n symbols-to-keep) + n + #f)] + [else n])) + (Prefix-names a-prefix)))) \ No newline at end of file diff --git a/lexical-structs.rkt b/lexical-structs.rkt index a0e4f8c..83935d6 100644 --- a/lexical-structs.rkt +++ b/lexical-structs.rkt @@ -7,8 +7,9 @@ ;; Lexical environments -;; A toplevel prefix contains a list of toplevel variables. -(define-struct: Prefix ([names : (Listof Symbol)]) +;; A toplevel prefix contains a list of toplevel variables. Some of the +;; names may be masked out by #f. +(define-struct: Prefix ([names : (Listof (U Symbol False))]) #:transparent) diff --git a/simulator.rkt b/simulator.rkt index 10c56a5..e2b1920 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -197,7 +197,10 @@ [(ExtendEnvironment/Prefix!? op) (env-push! m - (make-toplevel (map lookup-primitive + (make-toplevel (map (lambda: ([id/false : (U Symbol False)]) + (if (symbol? id/false) + (lookup-primitive id/false) + #f)) (ExtendEnvironment/Prefix!-names op))))] [(InstallClosureValues!? op) diff --git a/test-all.rkt b/test-all.rkt index 9847788..12acfec 100644 --- a/test-all.rkt +++ b/test-all.rkt @@ -4,5 +4,6 @@ "test-simulator.rkt" "test-compiler.rkt" "test-assemble.rkt" - #;"test-browser-evaluate.rkt" - #;"test-package.rkt") \ No newline at end of file + "test-browser-evaluate.rkt" + "test-package.rkt" + #;"test-conform.rkt") \ No newline at end of file diff --git a/test-browser-evaluate.rkt b/test-browser-evaluate.rkt index 89b317d..ea555ae 100644 --- a/test-browser-evaluate.rkt +++ b/test-browser-evaluate.rkt @@ -144,5 +144,5 @@ -(test (read (open-input-file "tests/conform/program0.sch")) +#;(test (read (open-input-file "tests/conform/program0.sch")) (port->string (open-input-file "tests/conform/expected0.txt"))) \ No newline at end of file