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

checking closures

Browse Source
This commit is contained in:
Danny Yoo 2011-03-07 21:46:13 -05:00
parent 0a7f12375f
commit 4a2f30b4f2
6 changed files with 55 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
compile.rkt
View File

@ -228,6 +228,7 @@
(make-instruction-sequence
`(,(make-AssignPrimOpStatement target
(make-MakeCompiledProcedure proc-entry
(length (Lam-parameters exp))
lexical-references)))))
(compile-lambda-body exp cenv
lexical-references
@ -341,6 +342,8 @@
primitive-branch)))
compiled-branch
(make-instruction-sequence
`(,(make-PerformStatement (make-CheckClosureArity! n))))
(end-with-compiled-application-linkage
compiled-linkage
cenv

11
il-structs.rkt
View File

@ -113,9 +113,11 @@
(define-struct: GetCompiledProcedureEntry ()
#:transparent)
;; Constructs a closure, given the label and the set of lexical references
;; into the environment that the closure needs to close over.
;; Constructs a closure, given the label, # of expected arguments,
;; and the set of lexical references into the environment that the
;; closure needs to close over.
(define-struct: MakeCompiledProcedure ([label : Symbol]
[arity : Natural]
[closed-vals : (Listof EnvReference)])
#:transparent)
@ -169,6 +171,10 @@
[name : Symbol])
#:transparent)
;; Check the closure procedure value in 'proc and make sure it can accept n values.
(define-struct: CheckClosureArity! ([arity : Natural])
#:transparent)
;; Extends the environment with a prefix that holds
;; lookups to the namespace.
(define-struct: ExtendEnvironment/Prefix! ([names : (Listof Symbol)])
@ -182,6 +188,7 @@
(define-type PrimitiveCommand (U
SetToplevel!
CheckToplevelBound!
CheckClosureArity!
ExtendEnvironment/Prefix!
InstallClosureValues!))

1
simulator-structs.rkt
View File

@ -44,6 +44,7 @@
;; Compiled procedure closures
(define-struct: closure ([label : Symbol]
[arity : Natural]
[vals : (Listof SlotValue)])
#:transparent)

17
simulator.rkt
View File

@ -152,18 +152,32 @@
(toplevel-mutate (ensure-toplevel (env-ref m (SetToplevel!-depth op)))
(SetToplevel!-pos op)
(ensure-primitive-value (machine-val m))))]
[(CheckToplevelBound!? op)
(let: ([a-top : toplevel (ensure-toplevel (env-ref m (CheckToplevelBound!-depth op)))])
(cond
[(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op)))
(error 'check-toplevel-bound! "Unbound identifier ~s" (CheckToplevelBound!-name op))]
(error 'check-toplevel-bound! "Unbound identifier ~s"
(CheckToplevelBound!-name op))]
[else
m]))]
[(CheckClosureArity!? op)
(let: ([clos : SlotValue (machine-proc m)])
(cond
[(closure? clos)
(if (= (closure-arity clos)
(CheckClosureArity!-arity op))
m
(error 'check-closure-arity "arity mismatch"))]
[else
(error 'check-closure-arity "not a closure")]))]
[(ExtendEnvironment/Prefix!? op)
(env-push m
(make-toplevel (map lookup-primitive
(ExtendEnvironment/Prefix!-names op))))]
[(InstallClosureValues!? op)
(let: ([a-proc : SlotValue (machine-proc m)])
(cond
@ -202,6 +216,7 @@
[(MakeCompiledProcedure? op)
(target-updater m (make-closure (MakeCompiledProcedure-label op)
(MakeCompiledProcedure-arity op)
(map (lambda: ([r : EnvReference])
(lookup-env-reference m r))
(MakeCompiledProcedure-closed-vals op))))]

3
test-compiler.rkt
View File

@ -108,8 +108,11 @@
;; We should see an error here, since the arity is wrong
(test/exn ((lambda (x y z) x) 3))
(test/exn ((lambda (x y z) z) 3))
(test/exn ((lambda (x y z) x) 3 4 5 6))
;; And this should fail because it's not a lambda
(test/exn (not-a-procedure 5))

37
test-simulator.rkt
View File

@ -276,6 +276,7 @@
;; install-closure-values
(let ([m
(make-machine (make-undefined) (make-closure 'procedure-entry
0
(list 1 2 3))
(list true false) ;; existing environment holds true, false
'()
@ -291,7 +292,7 @@
;; get-compiled-procedure-entry
(let ([m
(make-machine (make-undefined)
(make-closure 'procedure-entry (list 1 2 3))
(make-closure 'procedure-entry 0 (list 1 2 3))
(list true false) ;; existing environment holds true, false
'()
0
@ -303,13 +304,13 @@
;; make-compiled-procedure, with empty closure set
(let ([m (new-machine `(,(make-AssignPrimOpStatement
'val
(make-MakeCompiledProcedure 'procedure-entry (list)))
(make-MakeCompiledProcedure 'procedure-entry 0 (list)))
,(make-GotoStatement (make-Label 'end))
procedure-entry
end
))])
(test (machine-val (run m))
(make-closure 'procedure-entry (list))))
(make-closure 'procedure-entry 0 (list))))
;; make-compiled-procedure: Capturing a few variables.
(let ([m (new-machine `(,(make-PushEnvironment 3)
@ -318,14 +319,16 @@
,(make-AssignImmediateStatement (make-EnvLexicalReference 2) (make-Const 'moe))
,(make-AssignPrimOpStatement
'val
(make-MakeCompiledProcedure 'procedure-entry (list (make-EnvLexicalReference 0)
(make-EnvLexicalReference 2))))
(make-MakeCompiledProcedure 'procedure-entry
0
(list (make-EnvLexicalReference 0)
(make-EnvLexicalReference 2))))
,(make-GotoStatement (make-Label 'end))
procedure-entry
end
))])
(test (machine-val (run m))
(make-closure 'procedure-entry (list 'larry 'moe))))
(make-closure 'procedure-entry 0 (list 'larry 'moe))))
;; make-compiled-procedure: Capturing a toplevel.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
@ -337,13 +340,15 @@
,(make-PerformStatement (make-SetToplevel! 0 2 'z))
,(make-AssignPrimOpStatement
'val
(make-MakeCompiledProcedure 'procedure-entry (list (make-EnvWholePrefixReference 0))))
(make-MakeCompiledProcedure 'procedure-entry
0
(list (make-EnvWholePrefixReference 0))))
,(make-GotoStatement (make-Label 'end))
procedure-entry
end
))])
(test (machine-val (run m))
(make-closure 'procedure-entry (list (make-toplevel (list "x" "y" "z"))))))
(make-closure 'procedure-entry 0 (list (make-toplevel (list "x" "y" "z"))))))
;; make-compiled-procedure: Capturing both a toplevel and some lexical values
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
@ -360,18 +365,22 @@
,(make-AssignImmediateStatement (make-EnvLexicalReference 2) (make-Const 'moe))
,(make-AssignPrimOpStatement
'val
(make-MakeCompiledProcedure 'procedure-entry (list (make-EnvWholePrefixReference 3)
(make-EnvLexicalReference 0)
(make-EnvLexicalReference 2))))
(make-MakeCompiledProcedure 'procedure-entry
0
(list (make-EnvWholePrefixReference 3)
(make-EnvLexicalReference 0)
(make-EnvLexicalReference 2))))
,(make-PopEnvironment 3 0)
,(make-GotoStatement (make-Label 'end))
procedure-entry
end
))])
(test (machine-val (run m))
(make-closure 'procedure-entry (list (make-toplevel (list "x" "y" "z"))
'larry
'moe))))
(make-closure 'procedure-entry
0
(list (make-toplevel (list "x" "y" "z"))
'larry
'moe))))
;; Test toplevel lookup