54 lines
1.9 KiB
Racket
54 lines
1.9 KiB
Racket
#lang typed/racket/base
|
|
|
|
(require racket/list
|
|
"typed-structs.rkt")
|
|
(provide find-variable extend-lexical-environment lexical-environment-pop-depth)
|
|
|
|
|
|
;; 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))
|
|
(define (find-pos sym los)
|
|
(cond
|
|
[(eq? sym (car los))
|
|
0]
|
|
[else
|
|
(add1 (find-pos sym (cdr los)))]))
|
|
(let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv]
|
|
[depth : Natural 0])
|
|
(cond [(empty? cenv)
|
|
(error 'find-variable "Unable to find ~s in the environment" name)]
|
|
[(Prefix? (first cenv))
|
|
(cond [(member name (Prefix-names (first cenv)))
|
|
(make-PrefixAddress depth (find-pos name (Prefix-names (first cenv))) name)]
|
|
[else
|
|
(loop (rest cenv) (add1 depth))])]
|
|
[(member name (first cenv))
|
|
(make-LocalAddress depth (find-pos name (first cenv)))]
|
|
[else
|
|
(loop (rest cenv) (add1 depth))])))
|
|
|
|
|
|
|
|
(: extend-lexical-environment (CompileTimeEnvironment (U (Listof Symbol) Prefix) -> CompileTimeEnvironment))
|
|
;; Extends the lexical environment with procedure bindings.
|
|
(define (extend-lexical-environment cenv names)
|
|
(cond [(Prefix? names)
|
|
(cons names cenv)]
|
|
[(list? names)
|
|
(cons names 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)
|
|
(cond [(empty? cenv)
|
|
(error 'lexical-environment-pop-depth "Empty environment")]
|
|
[(Prefix? (first cenv))
|
|
1]
|
|
[(list? (first cenv))
|
|
1])) |