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

25
compiler.rkt
View File

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

20
test-compiler.rkt
View File

@ -1220,6 +1220,26 @@
(test '((case-lambda [(x) x]) 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)))