diff --git a/compile.rkt b/compile.rkt index f4e5378..7e3ead9 100644 --- a/compile.rkt +++ b/compile.rkt @@ -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 diff --git a/il-structs.rkt b/il-structs.rkt index 8e1c977..f1fd03a 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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!)) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 056ae8f..c207343 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -44,6 +44,7 @@ ;; Compiled procedure closures (define-struct: closure ([label : Symbol] + [arity : Natural] [vals : (Listof SlotValue)]) #:transparent) diff --git a/simulator.rkt b/simulator.rkt index a795b56..8bbafa6 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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))))] diff --git a/test-compiler.rkt b/test-compiler.rkt index 821a168..f352343 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -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)) diff --git a/test-simulator.rkt b/test-simulator.rkt index 58f4dfc..592cb7d 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -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