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

case-lambda tests

Browse Source
This commit is contained in:
Danny Yoo 2011-05-04 15:38:49 -04:00
parent 484d3dae6d
commit 42ca09b260
2 changed files with 34 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
compiler.rkt
View File

@ -504,7 +504,7 @@
;; Make the case lambda as a regular compiled procedure. Its closed values are the lambdas. ;; Make the case lambda as a regular compiled procedure. Its closed values are the lambdas.
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement `(,(make-AssignPrimOpStatement
target (adjust-target-depth target n)
(make-MakeCompiledProcedure (CaseLam-entry-label exp) (make-MakeCompiledProcedure (CaseLam-entry-label exp)
(merge-arities (map Lam-arity (CaseLam-clauses exp))) (merge-arities (map Lam-arity (CaseLam-clauses exp)))
(build-list n (lambda: ([i : Natural]) i)) (build-list n (lambda: ([i : Natural]) i))
@ -604,8 +604,7 @@
(: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence)) (: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence))
(define (compile-case-lambda-body exp cenv) (define (compile-case-lambda-body exp cenv)
empty-instruction-sequence (append-instruction-sequences
#;(append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(CaseLam-entry-label exp))) `(,(CaseLam-entry-label exp)))
@ -613,21 +612,25 @@
(apply append-instruction-sequences (apply append-instruction-sequences
(map (lambda: ([lam : Lam] (map (lambda: ([lam : Lam]
[i : Natural]) [i : Natural])
(let ([not-match (make-label)]) (let ([not-match (make-label 'notMatch)])
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndBranchStatement arity-mismatch? `(,(make-TestAndBranchStatement
(make-Const (Lam-arity lam)) (make-TestClosureArityMismatch
(make-CompiledProcedureClosureReference
(make-Reg 'proc)
i)
(make-Reg 'argcount)) (make-Reg 'argcount))
not-match)
;; Set the procedure register to the lam ;; Set the procedure register to the lam
,(make-AssignImmediateStatement ,(make-AssignImmediateStatement
'proc 'proc
(make-CaseLamRef (make-Reg 'proc) (make-Const i))) (make-CompiledProcedureClosureReference (make-Reg 'proc) i))
,(make-GotoStatement (make-Label (Lam-entry-point lam))) ,(make-GotoStatement (make-Label (Lam-entry-label lam)))
,not-match)))) ,not-match))))
(CaseLam-clauses exp) (CaseLam-clauses exp)
(build-list (length (CaseLam-clauses)) (lambda: ([i : Natural]) i)))))) (build-list (length (CaseLam-clauses exp)) (lambda: ([i : Natural]) i))))))
(: compile-lambda-bodies ((Listof lam+cenv) -> InstructionSequence)) (: compile-lambda-bodies ((Listof lam+cenv) -> InstructionSequence))

20
test-compiler.rkt
View File

@ -1220,6 +1220,26 @@
(test '((case-lambda [(x) x]) 42) (test '((case-lambda [(x) x]) 42)
42) 42)
(test '(let ([v (case-lambda [(x) x]
[(x y) (+ x y)])])
(list (v 0)
(v 1 2)))
(list 0 3))
(test '(let* ([y 42]
[f (case-lambda [(x) (list x y)]
[(x y) (list x y)])])
(list (f 3)
(f 4 5)))
(list (list 3 42)
(list 4 5)))
(test '(let ([f (case-lambda [(x) (list x)]
[(x . y) (cons y x)])])
(list (f 3)
(f 4 5 6)))
(list (list 3)
(cons '(5 6) 4)))