diff --git a/collects/r5rs/main.rkt b/collects/r5rs/main.rkt index c7f175edfa..b8523e64f2 100644 --- a/collects/r5rs/main.rkt +++ b/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 diff --git a/collects/rnrs/base-6.rkt b/collects/rnrs/base-6.rkt index 16fa9895eb..275c181909 100644 --- a/collects/rnrs/base-6.rkt +++ b/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 diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 79c703f2e9..06e3917b23 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/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) diff --git a/collects/tests/r6rs/base.sls b/collects/tests/r6rs/base.sls index 39525229fb..e5bb04199d 100644 --- a/collects/tests/r6rs/base.sls +++ b/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) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 352405c07c..3f1020e750 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/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