Support => within case, and improve error messages for cond and case

* module/ice-9/boot-9.scm (cond, case): Reimplement using syntax-case,
  with improved error messages and support for '=>' within 'case' as
  mandated by the R7RS.  Add warnings for duplicate case datums and
  case datums that cannot be meaningfully compared using 'eqv?'.

* module/system/base/message.scm (%warning-types): Add 'bad-case-datum'
  and 'duplicate-case-datum' warning types.

* test-suite/tests/syntax.test (cond, case): Update tests to reflect
  improved error reporting.  Add tests for '=>' within 'case'.

* test-suite/tests/tree-il.test (partial evaluation): Update tests to
  reflect changes in how 'case' is expanded.

* doc/ref/api-control.texi (Conditionals): Document '=>' within 'case'.

5 files changed, 234 insertions, 84 deletions

diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index fc5935070..ca7ad4af6 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -212,18 +212,30 @@ result of the @code{cond}-expression.
 @end deffn
 
 @deffn syntax case key clause1 clause2 @dots{}
-@var{key} may be any expression, the @var{clause}s must have the form
+@var{key} may be any expression, and the @var{clause}s must have the form
 
 @lisp
 ((@var{datum1} @dots{}) @var{expr1} @var{expr2} @dots{})
 @end lisp
 
+or
+
+@lisp
+((@var{datum1} @dots{}) => @var{expression})
+@end lisp
+
 and the last @var{clause} may have the form
 
 @lisp
 (else @var{expr1} @var{expr2} @dots{})
 @end lisp
 
+or
+
+@lisp
+(else => @var{expression})
+@end lisp
+
 All @var{datum}s must be distinct.  First, @var{key} is evaluated.  The
 result of this evaluation is compared against all @var{datum} values using
 @code{eqv?}.  When this comparison succeeds, the expression(s) following
@@ -234,6 +246,11 @@ If the @var{key} matches no @var{datum} and there is an
 @code{else}-clause, the expressions following the @code{else} are
 evaluated.  If there is no such clause, the result of the expression is
 unspecified.
+
+For the @code{=>} clause types, @var{expression} is evaluated and the
+resulting procedure is applied to the value of @var{key}.  The result of
+this procedure application is then the result of the
+@code{case}-expression.
 @end deffn
 
 
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d1bbd95ff..41ce92483 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -411,70 +411,150 @@ If there is no handler at all, Guile prints an error and then exits."
     ((_ x) x)
     ((_ x y ...) (let ((t x)) (if t t (or y ...))))))
 
+(include-from-path "ice-9/quasisyntax")
+
 (define-syntax-rule (when test stmt stmt* ...)
   (if test (begin stmt stmt* ...)))
 
 (define-syntax-rule (unless test stmt stmt* ...)
   (if (not test) (begin stmt stmt* ...)))
 
-;; The "maybe-more" bits are something of a hack, so that we can support
-;; SRFI-61. Rewrites into a standalone syntax-case macro would be
-;; appreciated.
 (define-syntax cond
-  (syntax-rules (=> else)
-    ((_ "maybe-more" test consequent)
-     (if test consequent))
-
-    ((_ "maybe-more" test consequent clause ...)
-     (if test consequent (cond clause ...)))
-
-    ((_ (else else1 else2 ...))
-     (begin else1 else2 ...))
-
-    ((_ (test => receiver) more-clause ...)
-     (let ((t test))
-       (cond "maybe-more" t (receiver t) more-clause ...)))
-
-    ((_ (generator guard => receiver) more-clause ...)
-     (call-with-values (lambda () generator)
-       (lambda t
-         (cond "maybe-more"
-               (apply guard t) (apply receiver t) more-clause ...))))
-
-    ((_ (test => receiver ...) more-clause ...)
-     (syntax-violation 'cond "wrong number of receiver expressions"
-                       '(test => receiver ...)))
-    ((_ (generator guard => receiver ...) more-clause ...)
-     (syntax-violation 'cond "wrong number of receiver expressions"
-                       '(generator guard => receiver ...)))
-    
-    ((_ (test) more-clause ...)
-     (let ((t test))
-       (cond "maybe-more" t t more-clause ...)))
-
-    ((_ (test body1 body2 ...) more-clause ...)
-     (cond "maybe-more"
-           test (begin body1 body2 ...) more-clause ...))))
+  (lambda (whole-expr)
+    (define (fold f seed xs)
+      (let loop ((xs xs) (seed seed))
+        (if (null? xs) seed
+            (loop (cdr xs) (f (car xs) seed)))))
+    (define (reverse-map f xs)
+      (fold (lambda (x seed) (cons (f x) seed))
+            '() xs))
+    (syntax-case whole-expr ()
+      ((_ clause clauses ...)
+       #`(begin
+           #,@(fold (lambda (clause-builder tail)
+                      (clause-builder tail))
+                    #'()
+                    (reverse-map
+                     (lambda (clause)
+                       (define* (bad-clause #:optional (msg "invalid clause"))
+                         (syntax-violation 'cond msg whole-expr clause))
+                       (syntax-case clause (=> else)
+                         ((else e e* ...)
+                          (lambda (tail)
+                            (if (null? tail)
+                                #'((begin e e* ...))
+                                (bad-clause "else must be the last clause"))))
+                         ((else . _) (bad-clause))
+                         ((test => receiver)
+                          (lambda (tail)
+                            #`((let ((t test))
+                                 (if t
+                                     (receiver t)
+                                     #,@tail)))))
+                         ((test => receiver ...)
+                          (bad-clause "wrong number of receiver expressions"))
+                         ((generator guard => receiver)
+                          (lambda (tail)
+                            #`((call-with-values (lambda () generator)
+                                 (lambda vals
+                                   (if (apply guard vals)
+                                       (apply receiver vals)
+                                       #,@tail))))))
+                         ((generator guard => receiver ...)
+                          (bad-clause "wrong number of receiver expressions"))
+                         ((test)
+                          (lambda (tail)
+                            #`((let ((t test))
+                                 (if t t #,@tail)))))
+                         ((test e e* ...)
+                          (lambda (tail)
+                            #`((if test
+                                   (begin e e* ...)
+                                   #,@tail))))
+                         (_ (bad-clause))))
+                     #'(clause clauses ...))))))))
 
 (define-syntax case
-  (syntax-rules (else)
-    ((case (key ...)
-       clauses ...)
-     (let ((atom-key (key ...)))
-       (case atom-key clauses ...)))
-    ((case key
-       (else result1 result2 ...))
-     (begin result1 result2 ...))
-    ((case key
-       ((atoms ...) result1 result2 ...))
-     (if (memv key '(atoms ...))
-         (begin result1 result2 ...)))
-    ((case key
-       ((atoms ...) result1 result2 ...)
-       clause clauses ...)
-     (if (memv key '(atoms ...))
-         (begin result1 result2 ...)
-         (case key clause clauses ...)))))
+  (lambda (whole-expr)
+    (define (fold f seed xs)
+      (let loop ((xs xs) (seed seed))
+        (if (null? xs) seed
+            (loop (cdr xs) (f (car xs) seed)))))
+    (define (fold2 f a b xs)
+      (let loop ((xs xs) (a a) (b b))
+        (if (null? xs) (values a b)
+            (call-with-values
+                (lambda () (f (car xs) a b))
+              (lambda (a b)
+                (loop (cdr xs) a b))))))
+    (define (reverse-map-with-seed f seed xs)
+      (fold2 (lambda (x ys seed)
+               (call-with-values
+                   (lambda () (f x seed))
+                 (lambda (y seed)
+                   (values (cons y ys) seed))))
+             '() seed xs))
+    (syntax-case whole-expr ()
+      ((_ expr clause clauses ...)
+       (with-syntax ((key #'key))
+         #`(let ((key expr))
+             #,@(fold
+                 (lambda (clause-builder tail)
+                   (clause-builder tail))
+                 #'()
+                 (reverse-map-with-seed
+                  (lambda (clause seen)
+                    (define* (bad-clause #:optional (msg "invalid clause"))
+                      (syntax-violation 'case msg whole-expr clause))
+                    (syntax-case clause ()
+                      ((test . rest)
+                       (with-syntax
+                           ((clause-expr
+                             (syntax-case #'rest (=>)
+                               ((=> receiver) #'(receiver key))
+                               ((=> receiver ...)
+                                (bad-clause
+                                 "wrong number of receiver expressions"))
+                               ((e e* ...) #'(begin e e* ...))
+                               (_ (bad-clause)))))
+                         (syntax-case #'test (else)
+                           ((datums ...)
+                            (let ((seen
+                                   (fold
+                                    (lambda (datum seen)
+                                      (define (warn-datum type)
+                                        ((@ (system base message)
+                                            warning)
+                                         type
+                                         (append (source-properties datum)
+                                                 (source-properties
+                                                  (syntax->datum #'test)))
+                                         datum
+                                         (syntax->datum clause)
+                                         (syntax->datum whole-expr)))
+                                      (if (memv datum seen)
+                                          (warn-datum 'duplicate-case-datum))
+                                      (if (or (pair? datum)
+                                              (array? datum)
+                                              (generalized-vector? datum))
+                                          (warn-datum 'bad-case-datum))
+                                      (cons datum seen))
+                                    seen
+                                    (map syntax->datum #'(datums ...)))))
+                              (values (lambda (tail)
+                                        #`((if (memv key '(datums ...))
+                                               clause-expr
+                                               #,@tail)))
+                                      seen)))
+                           (else (values (lambda (tail)
+                                           (if (null? tail)
+                                               #'(clause-expr)
+                                               (bad-clause
+                                                "else must be the last clause")))
+                                         seen))
+                           (_ (bad-clause)))))
+                      (_ (bad-clause))))
+                  '() #'(clause clauses ...)))))))))
 
 (define-syntax do
   (syntax-rules ()
@@ -502,8 +582,6 @@ If there is no handler at all, Guile prints an error and then exits."
 (define-syntax-rule (delay exp)
   (make-promise (lambda () exp)))
 
-(include-from-path "ice-9/quasisyntax")
-
 (define-syntax current-source-location
   (lambda (x)
     (syntax-case x ()
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 8cf285afd..9accf712a 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -126,6 +126,20 @@
                          "~A: warning: possibly wrong number of arguments to `~A'~%"
                          loc name))))
 
+           (duplicate-case-datum
+            "report a duplicate datum in a case expression"
+            ,(lambda (port loc datum clause case-expr)
+               (emit port
+                     "~A: warning: duplicate datum ~S in clause ~S of case expression ~S~%"
+                     loc datum clause case-expr)))
+
+           (bad-case-datum
+            "report a case datum that cannot be meaningfully compared using `eqv?'"
+            ,(lambda (port loc datum clause case-expr)
+               (emit port
+                     "~A: warning: datum ~S cannot be meaningfully compared using `eqv?' in clause ~S of case expression ~S~%"
+                     loc datum clause case-expr)))
+
            (format
             "report wrong number of arguments to `format'"
             ,(lambda (port loc . rest)
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index fcc0349ba..cdaee716b 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -648,11 +648,13 @@
 
     (pass-if-syntax-error "missing recipient"
       '(cond . "wrong number of receiver expressions")
-      (cond (#t identity =>)))
+      (eval '(cond (#t identity =>))
+            (interaction-environment)))
 
     (pass-if-syntax-error "extra recipient"
       '(cond . "wrong number of receiver expressions")
-      (cond (#t identity => identity identity))))
+      (eval '(cond (#t identity => identity identity))
+            (interaction-environment))))
 
   (with-test-prefix "bad or missing clauses"
 
@@ -662,43 +664,48 @@
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond #t)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond #t)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond 1)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond 1)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond 1 2)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond 1 2)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond 1 2 3)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond 1 2 3)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond 1 2 3 4)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond 1 2 3 4)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond ())"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond ())
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond () 1)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond () 1)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond (1) 1)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond (1) 1)
+	    (interaction-environment)))
+
+    (pass-if-syntax-error "(cond (else #f) (#t #t))"
+      '(cond . "else must be the last clause")
+      (eval '(cond (else #f) (#t #t))
 	    (interaction-environment))))
 
   (with-test-prefix "wrong number of arguments"
@@ -712,10 +719,46 @@
   (pass-if "clause with empty labels list"
     (case 1 (() #f) (else #t)))
 
+  (with-test-prefix "case handles '=> correctly"
+
+    (pass-if "(1 2 3) => list"
+      (equal? (case 1 ((1 2 3) => list))
+              '(1)))
+
+    (pass-if "else => list"
+      (equal? (case 6
+                ((1 2 3) 'wrong)
+                (else => list))
+              '(6)))
+
+    (with-test-prefix "bound '=> is handled correctly"
+
+      (pass-if "(1) => 'ok"
+        (let ((=> 'foo))
+          (eq? (case 1 ((1) => 'ok)) 'ok)))
+
+      (pass-if "else =>"
+        (let ((=> 'foo))
+          (eq? (case 1 (else =>)) 'foo)))
+
+      (pass-if "else => list"
+        (let ((=> 'foo))
+          (eq? (case 1 (else => identity)) identity))))
+
+    (pass-if-syntax-error "missing recipient"
+      '(case . "wrong number of receiver expressions")
+      (eval '(case 1 ((1) =>))
+            (interaction-environment)))
+
+    (pass-if-syntax-error "extra recipient"
+      '(case . "wrong number of receiver expressions")
+      (eval '(case 1 ((1) => identity identity))
+            (interaction-environment))))
+
   (with-test-prefix "case is hygienic"
 
     (pass-if-syntax-error "bound 'else is handled correctly"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(let ((else #f)) (case 1 (else #f)))
             (interaction-environment))))
 
@@ -742,22 +785,22 @@
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 \"foo\")"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 "foo")
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 ())"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 ())
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 (\"foo\"))"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 ("foo"))
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 ("foo" "bar"))
 	    (interaction-environment)))
 
@@ -767,7 +810,7 @@
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 ((2) \"bar\") (else))"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 ((2) "bar") (else))
 	    (interaction-environment)))
 
@@ -777,7 +820,7 @@
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 (else #f) ((1) #t))"
-      exception:generic-syncase-error
+      '(case . "else must be the last clause")
       (eval '(case 1 (else #f) ((1) #t))
 	    (interaction-environment)))))
 
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 8e294a748..68827a870 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1156,14 +1156,14 @@
     (case foo
       ((3 2 1) 'a)
       (else 'b))
-    (if (let (t) (_) ((toplevel foo))
-             (if (apply (primitive eqv?) (lexical t _) (const 3))
+    (let (key) (_) ((toplevel foo))
+         (if (if (apply (primitive eqv?) (lexical key _) (const 3))
                  (const #t)
-                 (if (apply (primitive eqv?) (lexical t _) (const 2))
+                 (if (apply (primitive eqv?) (lexical key _) (const 2))
                      (const #t)
-                     (apply (primitive eqv?) (lexical t _) (const 1)))))
-        (const a)
-        (const b)))
+                     (apply (primitive eqv?) (lexical key _) (const 1))))
+             (const a)
+             (const b))))
 
   (pass-if-peval
     ;; Memv with non-constant key, empty list, test context.  Currently
@@ -1171,9 +1171,7 @@
     (case foo
       (() 'a)
       (else 'b))
-    (if (begin (toplevel foo) (const #f))
-        (const a)
-        (const b)))
+    (begin (toplevel foo) (const b)))
 
   ;;
   ;; Below are cases where constant propagation should bail out.