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

working out type errors

Browse Source
This commit is contained in:
Danny Yoo 2011-03-20 22:04:32 -04:00
parent 15c6822816
commit b1384b71dd
1 changed files with 16 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
compile.rkt
View File

@ -162,14 +162,14 @@
(ToplevelSet-name exp))]) (ToplevelSet-name exp))])
(let ([get-value-code (let ([get-value-code
(parameterize ([current-defined-name var]) (parameterize ([current-defined-name var])
(compile (Def-value exp) cenv lexical-pos (compile (ToplevelSet-value exp) cenv lexical-pos
'next))]) 'next))])
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
get-value-code get-value-code
(make-instruction-sequence `(,(make-AssignImmediateStatement target (make-Const 'ok))))))))) (make-instruction-sequence `(,(make-AssignImmediateStatement target (make-Const (void))))))))))
(: compile-branch (Branch Natural Target Linkage -> InstructionSequence)) (: compile-branch (Branch Natural Target Linkage -> InstructionSequence))
@ -391,8 +391,7 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement 'val `(,(make-AssignPrimOpStatement 'val
(make-GetCompiledProcedureEntry)) (make-GetCompiledProcedureEntry))
,(make-PopEnvironment (ensure-natural (- (lexical-environment-pop-depth cenv linkage) ,(make-PopEnvironment (ensure-natural (- cenv n))
n))
n) n)
,(make-GotoStatement (make-Reg 'val))))] ,(make-GotoStatement (make-Reg 'val))))]
@ -404,18 +403,17 @@
(error 'compile "return linkage, target not val: ~s" target)])) (error 'compile "return linkage, target not val: ~s" target)]))
(: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-let1 (Let1 Natural Target Linkage -> InstructionSequence))
(define (compile-let1 exp cenv target linkage) (define (compile-let1 exp cenv target linkage)
(let*: ([rhs-code : InstructionSequence (let*: ([rhs-code : InstructionSequence
(parameterize ([current-defined-name (Let1-name exp)]) (compile (Let1-rhs exp)
(compile (Let1-rhs exp) (add1 cenv)
(extend-lexical-environment/placeholders cenv 1)
(make-EnvLexicalReference 0 #f) (make-EnvLexicalReference 0 #f)
'next))] 'next)
#;(parameterize ([current-defined-name (Let1-name exp)]) ...)]
[after-let1 : Symbol (make-label 'afterLetOne)] [after-let1 : Symbol (make-label 'afterLetOne)]
[after-body-code : Symbol (make-label 'afterLetBody)] [after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment [extended-cenv : Natural (add1 cenv)]
(extend-lexical-environment/names cenv (list (Let1-name exp)))]
[let-linkage : Linkage [let-linkage : Linkage
(cond (cond
[(eq? linkage 'next) [(eq? linkage 'next)
@ -442,23 +440,10 @@
(: compile-let-void (LetVoid CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-let-void (LetVoid CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-let-void exp cenv target linkage) (define (compile-let-void exp cenv target linkage)
(let*: ([n : Natural (length (Let-rhss exp))] (let*: ([n : Natural (LetVoid-count exp)]
[rhs-codes : (Listof InstructionSequence)
(map (lambda: ([rhs : ExpressionCore]
[i : Natural]
[name : Symbol])
(parameterize ([current-defined-name name])
(compile rhs
(extend-lexical-environment/placeholders cenv n)
(make-EnvLexicalReference i #f)
'next)))
(Let-rhss exp)
(build-list n (lambda: ([i : Natural]) i))
(Let-names exp))]
[after-let : Symbol (make-label 'afterLet)] [after-let : Symbol (make-label 'afterLet)]
[after-body-code : Symbol (make-label 'afterLetBody)] [after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment [extended-cenv : Natural (+ cenv (LetVoid-count exp))]
(extend-lexical-environment/names cenv (Let-names exp))]
[let-linkage : Linkage [let-linkage : Linkage
(cond (cond
[(eq? linkage 'next) [(eq? linkage 'next)
@ -469,20 +454,19 @@
after-body-code])] after-body-code])]
[body-target : Target (adjust-target-depth target n)] [body-target : Target (adjust-target-depth target n)]
[body-code : InstructionSequence [body-code : InstructionSequence
(compile (Let-body exp) extended-cenv body-target let-linkage)]) (compile (LetVoid-body exp) extended-cenv body-target let-linkage)])
(end-with-linkage (end-with-linkage
linkage linkage
extended-cenv extended-cenv
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence `(,(make-PushEnvironment n #f))) (make-instruction-sequence `(,(make-PushEnvironment n (LetVoid-boxes? exp))))
(apply append-instruction-sequences rhs-codes)
body-code body-code
after-body-code after-body-code
(make-instruction-sequence `(,(make-PopEnvironment n 0))) (make-instruction-sequence `(,(make-PopEnvironment n 0)))
after-let)))) after-let))))
(: compile-letrec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence)) #;(: compile-letrec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-letrec exp cenv target linkage) #;(define (compile-letrec exp cenv target linkage)
(let*: ([n : Natural (length (LetRec-rhss exp))] (let*: ([n : Natural (length (LetRec-rhss exp))]
[rhs-codes : (Listof InstructionSequence) [rhs-codes : (Listof InstructionSequence)
(map (lambda: ([rhs : ExpressionCore] (map (lambda: ([rhs : ExpressionCore]
@ -573,7 +557,6 @@
(EnvLexicalReference-unbox? target))] (EnvLexicalReference-unbox? target))]
[(EnvPrefixReference? target) [(EnvPrefixReference? target)
(make-EnvPrefixReference (+ n (EnvPrefixReference-depth target)) (make-EnvPrefixReference (+ n (EnvPrefixReference-depth target))
(EnvPrefixReference-pos target) (EnvPrefixReference-pos target))]
(EnvPrefixReference-name target))]
[(PrimitivesReference? target) [(PrimitivesReference? target)
target])) target]))