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

getting cm to type

Browse Source
This commit is contained in:
Danny Yoo 2011-02-18 18:55:12 -05:00
parent 61a1d62a05
commit 120895c624
1 changed files with 21 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
cm.rkt
View File

@ -17,7 +17,7 @@
;; A compile-time environment is a (listof (listof symbol)). ;; A compile-time environment is a (listof (listof symbol)).
;; A lexical address is either a 2-tuple (depth pos), or 'not-found. ;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
(define-type CompileTimeEnvironment (Listof (Listof Symbol))) (define-type CompileTimeEnvironment (Listof (Listof Symbol)))
(define-type LexicalAddress (List Number Number)) (define-type LexicalAddress (U (List Number Number) 'not-found))
;; find-variable: symbol compile-time-environment -> lexical-address ;; find-variable: symbol compile-time-environment -> lexical-address
;; Find where the variable should be located. ;; Find where the variable should be located.
@ -30,8 +30,8 @@
0] 0]
[else [else
(add1 (find-pos sym (cdr los)))])) (add1 (find-pos sym (cdr los)))]))
(let: loop : (U LexicalAddress 'not-found) ([cenv : CompileTimeEnvironment cenv] (let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv]
[depth : Natural 0]) [depth : Natural 0])
(cond [(empty? cenv) (cond [(empty? cenv)
'not-found] 'not-found]
[(member name (first cenv)) [(member name (first cenv))
@ -39,11 +39,6 @@
[else [else
(loop (rest cenv) (add1 depth))]))) (loop (rest cenv) (add1 depth))])))
;; global-lexical-address?: lexical-address -> boolean
;; Produces true if the address refers to the toplevel environment.
(: global-lexical-address? (LexicalAddress -> Boolean))
(define (global-lexical-address? address)
(eq? address 'not-found))
;; extend-lexical-environment: lexical-environment (listof symbol) -> lexical-envrionment ;; extend-lexical-environment: lexical-environment (listof symbol) -> lexical-envrionment
@ -98,7 +93,7 @@
instruction-sequence instruction-sequence
(compile-linkage linkage))) (compile-linkage linkage)))
(: compile-self-evaluating (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-self-evaluating (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-self-evaluating exp cenv target linkage) (define (compile-self-evaluating exp cenv target linkage)
(end-with-linkage linkage (end-with-linkage linkage
(make-instruction-sequence (make-instruction-sequence
@ -106,7 +101,7 @@
(list target) (list target)
`((assign ,target (const ,exp)))))) `((assign ,target (const ,exp))))))
(: compile-quoted (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-quoted exp cenv target linkage) (define (compile-quoted exp cenv target linkage)
(end-with-linkage linkage (end-with-linkage linkage
(make-instruction-sequence (make-instruction-sequence
@ -114,11 +109,11 @@
(list target) (list target)
`((assign ,target (const ,(Quote-text exp))))))) `((assign ,target (const ,(Quote-text exp)))))))
(: compile-variable (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-variable exp cenv target linkage) (define (compile-variable exp cenv target linkage)
(let ([lexical-pos (find-variable exp cenv)]) (let ([lexical-pos (find-variable (Var-id exp) cenv)])
(cond (cond
[(global-lexical-address? lexical-pos) [(eq? lexical-pos 'not-found)
(end-with-linkage linkage (end-with-linkage linkage
(make-instruction-sequence (make-instruction-sequence
'(env) '(env)
@ -126,11 +121,11 @@
;; Slight modification: explicitly testing for ;; Slight modification: explicitly testing for
;; global variable binding before lookup. ;; global variable binding before lookup.
`((perform (op check-bound-global!) `((perform (op check-bound-global!)
(const ,exp) (const ,(Var-id exp))
(reg env)) (reg env))
(assign ,target (assign ,target
(op lookup-variable-value) (op lookup-variable-value)
(const ,exp) (const ,(Var-id exp))
(reg env)))))] (reg env)))))]
[else [else
(end-with-linkage linkage (end-with-linkage linkage
@ -144,7 +139,7 @@
(reg env)))))]))) (reg env)))))])))
(: compile-assignment (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-assignment exp cenv target linkage) (define (compile-assignment exp cenv target linkage)
(let* ([var (Assign-variable exp)] (let* ([var (Assign-variable exp)]
[get-value-code [get-value-code
@ -152,7 +147,7 @@
[lexical-address [lexical-address
(find-variable var cenv)]) (find-variable var cenv)])
(cond (cond
[(global-lexical-address? lexical-address) [(eq? lexical-address 'not-found)
(end-with-linkage (end-with-linkage
linkage linkage
(preserving '(env) (preserving '(env)
@ -182,7 +177,7 @@
;; FIXME: exercise 5.43 ;; FIXME: exercise 5.43
(: compile-definition (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-definition exp cenv target linkage) (define (compile-definition exp cenv target linkage)
(let ([var (Def-variable exp)] (let ([var (Def-variable exp)]
[get-value-code [get-value-code
@ -202,7 +197,7 @@
(assign ,target (const ok)))))))) (assign ,target (const ok))))))))
(: compile-if (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-if exp cenv target linkage) (define (compile-if exp cenv target linkage)
(let ([t-branch (make-label 'trueBranch)] (let ([t-branch (make-label 'trueBranch)]
[f-branch (make-label 'falseBranch)] [f-branch (make-label 'falseBranch)]
@ -237,7 +232,7 @@
(compile-sequence (rest-exps seq) cenv target linkage)))) (compile-sequence (rest-exps seq) cenv target linkage))))
(: compile-lambda (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-lambda exp cenv target linkage) (define (compile-lambda exp cenv target linkage)
(let ([proc-entry (make-label 'entry)] (let ([proc-entry (make-label 'entry)]
[after-lambda (make-label 'afterLambda)]) [after-lambda (make-label 'afterLambda)])
@ -265,7 +260,7 @@
proc-entry)) proc-entry))
after-lambda)))) after-lambda))))
(: compile-lambda-body (Expression CompileTimeEnvironment Linkage -> InstructionSequence)) (: compile-lambda-body (Lam CompileTimeEnvironment Linkage -> InstructionSequence))
(define (compile-lambda-body exp cenv proc-entry) (define (compile-lambda-body exp cenv proc-entry)
(let* ([formals (Lam-parameters exp)] (let* ([formals (Lam-parameters exp)]
[extended-cenv (extend-lexical-environment cenv formals)]) [extended-cenv (extend-lexical-environment cenv formals)])
@ -281,10 +276,10 @@
(reg env)))) (reg env))))
(compile-sequence (Lam-body exp) extended-cenv 'val 'return)))) (compile-sequence (Lam-body exp) extended-cenv 'val 'return))))
(: compile-application (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-application exp cenv target linkage) (define (compile-application exp cenv target linkage)
(let ([proc-code (compile (App-operator exp) cenv 'proc 'next)] (let ([proc-code (compile (App-operator exp) cenv 'proc 'next)]
[operand-codes (map (lambda (operand) [operand-codes (map (lambda: ([operand : Expression])
(compile operand cenv 'val 'next)) (compile operand cenv 'val 'next))
(App-operands exp))]) (App-operands exp))])
(preserving '(env cont) (preserving '(env cont)
@ -399,11 +394,11 @@
(: needs-register? (InstructionSequence Symbol -> Boolean)) (: needs-register? (InstructionSequence Symbol -> Boolean))
(define (needs-register? seq reg) (define (needs-register? seq reg)
(memq reg (registers-needed seq))) (and (memq reg (registers-needed seq)) #t))
(: modifies-register? (InstructionSequence Symbol -> Boolean)) (: modifies-register? (InstructionSequence Symbol -> Boolean))
(define (modifies-register? seq reg) (define (modifies-register? seq reg)
(memq reg (registers-modified seq))) (and (memq reg (registers-modified seq)) #t))
(: preserving ((Listof Symbol) InstructionSequence InstructionSequence -> InstructionSequence)) (: preserving ((Listof Symbol) InstructionSequence InstructionSequence -> InstructionSequence))
(define (preserving regs seq1 seq2) (define (preserving regs seq1 seq2)
@ -426,7 +421,7 @@
(: append-instruction-sequence (InstructionSequence * -> InstructionSequence)) (: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
(define (append-instruction-sequences . seqs) (define (append-instruction-sequences . seqs)
(append-seq-list seqs)) (append-seq-list seqs))