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

trying to fix the popenv stuff

Browse Source
This commit is contained in:
Danny Yoo 2011-03-07 23:08:58 -05:00
parent 470730bcb8
commit ab2f16508e
3 changed files with 88 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compile.rkt
View File

@ -249,7 +249,9 @@
(define (compile-lambda-body exp cenv lexical-references proc-entry)
(let*: ([formals : (Listof Symbol) (Lam-parameters exp)]
[extended-cenv : CompileTimeEnvironment
(extend-lexical-environment '() formals)]
(extend-lexical-environment
'()
(make-FunctionExtension formals))]
[extended-cenv : CompileTimeEnvironment
(lexical-references->compile-time-environment
lexical-references cenv extended-cenv)])
@ -355,8 +357,7 @@
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
target
(make-ApplyPrimitiveProcedure n))
,(make-PopEnvironment n 0))))
(make-ApplyPrimitiveProcedure n)))))
after-call))))

75
lexical-env.rkt
View File

@ -30,44 +30,81 @@
[else
(let: ([elt : CompileTimeEnvironmentEntry (first cenv)])
(cond
[(eq? #f elt)
(loop (rest cenv) (add1 depth))]
[(Prefix? elt)
(cond [(member name (Prefix-names elt))
(make-PrefixAddress depth (find-pos name (Prefix-names elt)) name)]
[else
(loop (rest cenv) (add1 depth))])]
[(symbol? elt)
[(FunctionExtension? elt)
(let: ([index : (U #f Natural) (list-index name (FunctionExtension-names elt))])
(cond
[(eq? name elt)
(make-LocalAddress depth)]
[(boolean? index)
(loop (rest cenv) (+ depth (length (FunctionExtension-names elt))))]
[else
(loop (rest cenv) (add1 depth))])]))])))
(make-LocalAddress (+ depth index))]))]
[(LocalExtension? elt)
(let: ([index : (U #f Natural) (list-index name (LocalExtension-names elt))])
(cond
[(boolean? index)
(loop (rest cenv) (+ depth (length (LocalExtension-names elt))))]
[else
(make-LocalAddress (+ depth index))]))]
[(TemporaryExtension? elt)
(loop (rest cenv)
(+ depth (TemporaryExtension-n elt)))]))])))
(: list-index (All (A) A (Listof A) -> (U #f Natural)))
(define (list-index x l)
(let loop ([i 0]
[l l])
(cond
[(empty? l)
#f]
[(eq? x (first l))
i]
[else
(loop (add1 i) (rest l))])))
(: extend-lexical-environment (CompileTimeEnvironment (U (Listof Symbol) Prefix) -> CompileTimeEnvironment))
(: extend-lexical-environment
(CompileTimeEnvironment CompileTimeEnvironmentEntry -> CompileTimeEnvironment))
;; Extends the lexical environment with procedure bindings.
(define (extend-lexical-environment cenv names)
(cond [(Prefix? names)
(cons names cenv)]
[(list? names)
(append names cenv)]))
(define (extend-lexical-environment cenv extension)
(cons extension cenv))
(: extend-lexical-environment/placeholders (CompileTimeEnvironment Natural -> CompileTimeEnvironment))
(: extend-lexical-environment/placeholders
(CompileTimeEnvironment Natural -> CompileTimeEnvironment))
;; Add placeholders to the lexical environment (This represents what happens during procedure application.)
(define (extend-lexical-environment/placeholders cenv n)
(cond [(= n 0)
cenv]
[else
(extend-lexical-environment/placeholders (cons #f cenv) (sub1 n))]))
(cons (make-TemporaryExtension n)
cenv))
(: lexical-environment-pop-depth (CompileTimeEnvironment -> Natural))
;; Computes how many environments we need to pop till we clear the procedure arguments.
(define (lexical-environment-pop-depth cenv)
(length cenv))
(cond
[(empty? cenv)
0]
[else
(let: ([entry : CompileTimeEnvironmentEntry (first cenv)])
(cond
[(Prefix? entry)
(+ (length (Prefix-names entry))
(lexical-environment-pop-depth (rest cenv)))]
[(FunctionExtension? entry)
(length (FunctionExtension-names entry))]
[(LocalExtension? entry)
(+ (length (LocalExtension-names entry))
(lexical-environment-pop-depth (rest cenv)))]
[(TemporaryExtension? entry)
(+ (TemporaryExtension-n entry)
(lexical-environment-pop-depth (rest cenv)))]))]))

18
lexical-structs.rkt
View File

@ -6,19 +6,27 @@
;; Lexical environments
;; A toplevel prefix contains a list of toplevel variables.
(define-struct: Prefix ([names : (Listof Symbol)])
#:transparent)
(define-struct: FunctionExtension ([names : (Listof Symbol)])
#:transparent)
(define-struct: LocalExtension ([names : (Listof Symbol)])
#:transparent)
(define-struct: TemporaryExtension ([n : Natural])
#:transparent)
(define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix
FunctionExtension
LocalExtension
TemporaryExtension))
(define-type CompileTimeEnvironmentEntry (U False ;; placeholder for temporary space
Symbol ;; lexically bound local identiifer
Prefix ;; a prefix
))
;; A compile-time environment is a (listof (listof symbol)).
;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))