make case' in r5rs' and r6rs' still use eqv?'

Also, make both `case' and `cond' disallow internal definitions,
instead of inheriting the `racket' behavior.

collects/r5rs/main.rkt

@@ -446,6 +446,86 @@
                        (begin (set! id tmp-id) ...) ...
                        . exprs))))))]))
 
+  (define-syntax (r5rs:case stx)
+    ;; Racket's `case' uses `equal?' and allows internal definitions,
+    ;; this one uses `eqv?' and allows only expressions in clauses.
+    (define (convert-case stx)
+      (with-syntax ([(clause ...)
+                     (map (lambda (clause)
+                            (syntax-case clause ()
+                              [[datums rhs ...]
+                               (syntax/loc clause
+                                 [datums (#%expression rhs) ...])]
+                              [else 
+                               ;; bad syntax
+                               clause]))
+                          (cddr (syntax->list stx)))]
+                    [(_ expr . _) stx])
+        (syntax/loc stx
+          (case expr clause ...))))
+    (define (eqv-is-equal-datum? e)
+      (define v (syntax-e e))
+      (or (null? v)
+          (number? v)
+          (char? v)
+          (symbol? v)
+          (boolean? v)))
+    (syntax-case stx (else)
+      [(_ expr [(datum ...) . _] ... [else . _])
+       (andmap eqv-is-equal-datum? (syntax->list #'(datum ... ...)))
+       ;; normal `case' with `else'
+       (convert-case stx)]
+      [(_ expr [(datum ...) . _] ...)
+       ;; normal `case' without `else'
+       (andmap eqv-is-equal-datum? (syntax->list #'(datum ... ...)))
+       (convert-case stx)]
+      [(_ expr [datums rhs ...] ...)
+       ;; weird `case' clause
+       (with-syntax ([(clause ...)
+                      (map (lambda (clause)
+                             (syntax-case clause (else)
+                               [[else rhs ...]
+                                (with-syntax ([(els . _) clause])
+                                  (syntax/loc clause
+                                    [els (#%expression rhs) ...]))]
+                               [[datums rhs ...]
+                                (syntax/loc clause
+                                  [(memv v '(datums)) (#%expression rhs) ...])]))
+                           (cddr (syntax->list stx)))])
+         (syntax/loc stx
+           (let ([v expr])
+             (cond clause ...))))]
+      [else
+       ;; let `case' complain about syntax:
+       (with-syntax ([(_ . rest) stx])
+         (syntax/loc stx (case . rest)))]))
+
+  (define-syntax (r5rs:cond stx)
+    ;; Racket's `cond' allows internal definitions,
+    ;; this one allows only expressions in clauses.
+    (syntax-case stx ()
+      [(_ clause ...)
+       (with-syntax ([(new-clause ...)
+                      (map (lambda (clause)
+                             (syntax-case clause (else =>)
+                               [[else rhs ...]
+                                (with-syntax ([(els . _) clause])
+                                  (syntax/loc clause
+                                    [els (#%expression rhs) ...]))]
+                               [[expr => rhs]
+                                clause]
+                               [[expr rhs ...]
+                                (syntax/loc clause
+                                  [expr (#%expression rhs) ...])]))
+                           (syntax->list #'(clause ...)))])
+         (syntax/loc stx
+           (cond new-clause ...)))]
+      [else
+       ;; let `cond' complain about syntax:
+       (with-syntax ([(_ . rest) stx])
+         (syntax/loc stx (cond . rest)))]))
+
+
   (define-syntax-rule (mk-undefined id) undefined)
     
   (provide unquote unquote-splicing 
@@ -460,8 +540,10 @@
                        [r5rs:let let]
                        [r5rs:let* let*]
                        [r5rs:let-syntax let-syntax]
-                       [r5rs:letrec-syntax letrec-syntax])
-           and or cond case do
+                       [r5rs:letrec-syntax letrec-syntax]
+                       [r5rs:case case]
+                       [r5rs:cond cond])
+           and or do
 	   begin set!
            => else
 

collects/rnrs/base-6.rkt

@@ -32,7 +32,9 @@
  (rename-out [r6rs:set! set!])
 
  ;; 11.4.5
- cond else => case
+ (rename-out [r5rs:cond cond]
+             [r5rs:case case])
+ else => 
  and or
  
  ;; 11.4.6

collects/scribblings/reference/syntax.scrbl

@@ -2136,7 +2136,11 @@ Evaluates @racket[val-expr] and uses the result to select a
 result of @racket[val-expr]. If no such @racket[datum] is present, the
 @racket[else] @racket[case-clause] is selected; if no @racket[else]
 @racket[case-clause] is present, either, then the result of the
-@racket[case] form is @|void-const|.
+@racket[case] form is @|void-const|.@margin-note{The @racket[case]
+form of @racketmodname[racket] differs from that of @other-manual['(lib
+"r6rs/scribblings/r6rs.scrbl")] or @other-manual['(lib
+"r5rs/r5rs.scrbl")] by being based @racket[equal?] instead of
+@racket[eqv?] (in addition to allowing internal definitions).}
 
 For the selected @racket[case-clause], the results of the last
 @racket[then-body], which is in tail position with respect to the
@@ -2152,6 +2156,18 @@ A @racket[case-clause] that starts with @racket[else] must be the last
 (case (- 7 5)
  [(1 2 3) 'small]
  [(10 11 12) 'big])
+(case (string-append "do" "g")
+ [("cat" "dog" "mouse") "animal"]
+ [else "mineral or vegetable"])
+(case (list 'y 'x)
+ [((a b) (x y)) 'forwards]
+ [((b a) (y x)) 'backwards])
+(case 'x
+ [(x) "ex"]
+ [('x) "quoted ex"])
+(case (list 'quote 'x)
+ [(x) "ex"]
+ [('x) "quoted ex"])
 ]
 @def+int[
 (define (classify c)

collects/tests/r6rs/base.sls

@@ -273,6 +273,10 @@
             ((w y) 'semivowel)
             (else 'consonant))
           'consonant)
+    (test (case (list 1 2) ; newly allocated => not `eqv?'
+            (((1 2)) 'two)
+            (else 'other))
+          'other)
 
     (test (and (= 2 2) (> 2 1)) #t)
     (test (and (= 2 2) (< 2 1)) #f)

doc/release-notes/racket/HISTORY.txt

@@ -1,3 +1,8 @@
+Version 5.3.1.9
+Changed case to use equal? instead of eqv?
+r5rs, r6rs: fixed case and cond to disallow internal definitions
+ in clauses
+
 Version 5.3.1.8
 file/untar: added
 file/untgz: added