From 92fa73ecab83105f4a20913721549f2d2c4ca80f Mon Sep 17 00:00:00 2001
From: Daphne Preston-Kendal <git@dpk.io>
Date: Mon, 18 Apr 2022 10:05:40 +0200
Subject: [PATCH] Better case-lambda tests
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

The problem with the original `case-lambda` tests is that they could
actually pass if the `+` and `*` procedures were implemented correctly
but `case-lambda` itself wasn’t.

Specifically, an attempted optimized `case-lambda` implementation
which looked at the length of its arguments list and subsequently
erroneously always chose the variadic clause of the `plus` procedure
would still pass the test, because `plus` in this case recreated the
behaviour of the `+` procedure used for the test; it was never
actually observable whether the `args` clause or one of the more
specific clauses had been used to generate the result. Similar applies
to the `mult` test: although in that case an implementation could only
have erroneously chosen the `(x y . z)` clause in the two-argument
case, it would still have been an error invisible to the test cases.

I’ve also added a test which attempts to ensure that a redundant
clause will never match. This may cause a warning on Schemes which
detect such clauses at compile time, but R7RS does not explicitly
define such `case-lambda` expressions as erroneous in any way, so it
would be wrong (and non-conformant) for it to stop the tests running
altogether.

(This patch mainly useful because Chibi’s R7RS tests are sometimes
used by other implementations to ensure conformance. Chibi passed
these tests in any case.)
---
 tests/r7rs-tests.scm | 52 ++++++++++++++++++++++++++------------------
 1 file changed, 31 insertions(+), 21 deletions(-)

diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index 24f6e94f..32f74576 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -354,32 +354,42 @@
 (test '(list 3 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 
-   (() 0)
-   ((x) x)
-   ((x y) (+ x y))
-   ((x y z) (+ (+ x y) z))
-   (args (apply + args))))
+    (() 'zero)
+    ((x) x)
+    ((x y) (cons x y))
+    ((x y z) (list x y z))
+    (args (cons 'many args))))
 
-(test 0 (plus))
-(test 1 (plus 1))
-(test 3 (plus 1 2))
-(test 6 (plus 1 2 3))
-(test 10 (plus 1 2 3 4))
+(test 'zero (any-arity))
+(test 1 (any-arity 1))
+(test '(1 . 2) (any-arity 1 2))
+(test '(1 2 3) (any-arity 1 2 3))
+(test '(many 1 2 3 4) (any-arity 1 2 3 4))
 
-(define mult
+(define rest-arity
   (case-lambda 
-   (() 1)
-   ((x) x)
-   ((x y) (* x y))
-   ((x y . z) (apply mult (* x y) z))))
+    (() '(zero))
+    ((x) (list 'one x))
+    ((x y) (list 'two x y))
+    ((x y . z) (list 'more x y z))))
 
-(test 1 (mult))
-(test 1 (mult 1))
-(test 2 (mult 1 2))
-(test 6 (mult 1 2 3))
-(test 24 (mult 1 2 3 4))
+(test '(zero) (rest-arity))
+(test '(one 1) (rest-arity 1))
+(test '(two 1 2) (rest-arity 1 2))
+(test '(more 1 2 (3)) (rest-arity 1 2 3))
+
+(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)