Merge pull request #828 from dpk/better-case-lambda-tests

Better case-lambda tests
This commit is contained in:
Alex Shinn 2022-04-20 21:10:55 +09:00 committed by GitHub
commit b0735b3ca7
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23

View file

@ -354,32 +354,42 @@
(test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) ) (test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) )
(test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4))) (test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4)))
(define plus (define any-arity
(case-lambda (case-lambda
(() 0) (() 'zero)
((x) x) ((x) x)
((x y) (+ x y)) ((x y) (cons x y))
((x y z) (+ (+ x y) z)) ((x y z) (list x y z))
(args (apply + args)))) (args (cons 'many args))))
(test 0 (plus)) (test 'zero (any-arity))
(test 1 (plus 1)) (test 1 (any-arity 1))
(test 3 (plus 1 2)) (test '(1 . 2) (any-arity 1 2))
(test 6 (plus 1 2 3)) (test '(1 2 3) (any-arity 1 2 3))
(test 10 (plus 1 2 3 4)) (test '(many 1 2 3 4) (any-arity 1 2 3 4))
(define mult (define rest-arity
(case-lambda (case-lambda
(() 1) (() '(zero))
((x) x) ((x) (list 'one x))
((x y) (* x y)) ((x y) (list 'two x y))
((x y . z) (apply mult (* x y) z)))) ((x y . z) (list 'more x y z))))
(test 1 (mult)) (test '(zero) (rest-arity))
(test 1 (mult 1)) (test '(one 1) (rest-arity 1))
(test 2 (mult 1 2)) (test '(two 1 2) (rest-arity 1 2))
(test 6 (mult 1 2 3)) (test '(more 1 2 (3)) (rest-arity 1 2 3))
(test 24 (mult 1 2 3 4))
(define dead-clause
(case-lambda
((x . y) 'many)
(() 'none)
(foo 'unreachable)))
(test 'none (dead-clause))
(test 'many (dead-clause 1))
(test 'many (dead-clause 1 2))
(test 'many (dead-clause 1 2 3))
(test-end) (test-end)