diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index 4326ef2f68..8bcc01915e 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -82,22 +82,74 @@ '()))) cps rhss)) -(define ((term-match/single/proc form-name lang ps cps rhss) term) - (let loop ([ps ps] [cps cps] [rhss rhss]) +(define ((term-match/single/proc form-name lang ps0 cps rhss) term) + (let loop ([ps ps0] [cps cps] [rhss rhss]) (if (null? ps) - (redex-error form-name "no patterns matched ~e" term) + (redex-error form-name + (if (null? (cdr ps0)) + (format "term ~s does not match pattern ~s" term (car ps0)) + (format "no patterns matched ~s" term))) (let ([match (match-pattern (car cps) term)]) (if match (begin (unless (null? (cdr match)) (redex-error form-name - "pattern ~s matched term ~e multiple ways" + "pattern ~s matched term ~s multiple ways" (car ps) term)) ((car rhss) (car match))) (loop (cdr ps) (cdr cps) (cdr rhss))))))) +(define-syntaxes (redex-let redex-let*) + (let () + (define-syntax-class binding + #:description "binding clause" + (pattern (lhs:expr rhs:expr))) + (define-syntax-class (bindings extract) + #:description (if extract + "sequence of disjoint binding clauses" + "sequence of binding clauses") + (pattern (b:binding ...) + #:fail-when (and extract + (check-duplicate-identifier + (apply append (map extract (syntax->list #'(b.lhs ...)))))) + "duplicate pattern variable" + #:with (lhs ...) #'(b.lhs ...) + #:with (rhs ...) #'(b.rhs ...))) + + (define (redex-let stx) + (define-values (form-name nts) + (syntax-case stx () + [(name lang . _) + (values (syntax-e #'name) + (language-id-nts #'lang (syntax-e #'name)))])) + (define (pattern-variables pattern) + (let-values ([(names _) (extract-names nts form-name #t pattern)]) + names)) + (syntax-parse stx + [(name lang (~var bs (bindings pattern-variables)) body ...+) + (with-syntax ([(t ...) (generate-temporaries #'bs)]) + #`(let ([t bs.rhs] ...) + #,(nested-lets #'lang #'([bs.lhs t] ...) #'(body ...) #'name)))])) + + (define (redex-let* stx) + (syntax-parse stx + [(name lang (~var bs (bindings #f)) body ...+) + (nested-lets #'lang #'bs #'(body ...) #'name)])) + + (define (nested-lets lang bindings bodies name) + (syntax-case bindings () + [() + #`(let () #,@bodies)] + [([lhs rhs] . bindings) + (with-syntax ([rest-lets (nested-lets lang #'bindings bodies name)]) + #`(#,(term-matcher #`(#,name #,lang [lhs rest-lets]) + #'term-match/single/proc) + rhs))])) + + (values redex-let redex-let*))) + (define-syntax (compatible-closure stx) (syntax-case stx () [(_ red lang nt) @@ -2340,6 +2392,8 @@ (provide test-match term-match term-match/single + redex-let + redex-let* make-bindings bindings-table bindings? match? match-bindings make-bind bind? bind-name bind-exp diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 2b49d14a4e..54d0ace93c 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -508,10 +508,26 @@ present, the pattern before the ellipses may match multiple adjacent elements in the list value (possibly none). This form is a lower-level form in Redex, and not really designed to -be used directly. If you want a @racket[let]-like form that uses -Redex's full pattern matching facilities, see @racket[term-match] and -@racket[term-match/single]. +be used directly. For @racket[let]-like forms that use +Redex's full pattern matching facilities, see @racket[redex-let], +@racket[redex-let*], @racket[term-match], @racket[term-match/single]. +} +@defform[(redex-let language ([@#,ttpattern expression] ...) body ...+)]{ +Like @racket[term-let] but the left-hand sides are Redex patterns, +interpreted according to the specified language. It is a syntax +error for two left-hand sides to bind the same pattern variable. + +This form raises an exception recognized by @racket[exn:fail:redex?] +if any right-hand side does not match its left-hand side in exactly one +way. + +In some contexts, it may be more efficient to use @racket[term-match/single] +(lifted out of the context). +} + +@defform[(redex-let* language ([@#,ttpattern expression] ...) body ...+)]{ +The @racket[let*] analog of @racket[redex-let]. } @defform[(term-match language [@#,ttpattern expression] ...)]{ diff --git a/collects/redex/reduction-semantics.rkt b/collects/redex/reduction-semantics.rkt index 3d2b4c3b1d..3848edc218 100644 --- a/collects/redex/reduction-semantics.rkt +++ b/collects/redex/reduction-semantics.rkt @@ -37,6 +37,8 @@ (provide (rename-out [test-match redex-match]) term-match term-match/single + redex-let + redex-let* match? match-bindings make-bind bind? bind-name bind-exp diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 30f2524748..48d48191cf 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -1933,6 +1933,58 @@ (--> r p x)))) '(a b c z y x)) + + ; + ; + ; ;; ;; + ; ; ; ; + ; ;; ;; ;;; ;; ; ;;; ;; ;; ; ;;; ;;;;; + ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; + ; ; ;;;;; ; ; ;;;;; ;; ;;;;; ; ;;;;; ; + ; ; ; ; ; ; ;; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;;; ;;;; ;;;;; ;;;; ;; ;; ;;;;; ;;;; ;;; + ; + ; + ; + ; + + (let () + (define-language L + (n number) + (x variable)) + + (test (redex-let L ([(n_1 n_2) '(1 2)]) + (term (n_2 n_1))) + (term (2 1))) + (test (redex-let L ([(x_i ([x_0 n_0] ... [x_i n_i] [x_i+1 n_i+1] ...)) + '(b ([a 1] [b 2] [c 3]))]) + (term n_i)) + 2) + (test (with-handlers ([exn:fail:redex? exn-message]) + (redex-let L ([(n) 1]) 'no-exn)) + "redex-let: term 1 does not match pattern (n)") + (test (with-handlers ([exn:fail:redex? exn-message]) + (redex-let L ([(n_1 ... n_i n_i+1 ...) '(1 2 3)]) 'no-exn)) + "redex-let: pattern (n_1 ... n_i n_i+1 ...) matched term (1 2 3) multiple ways") + (test (redex-let L ([n_1 1]) + (redex-let L ([n_1 2] [n_2 (term n_1)]) + (term (n_1 n_2)))) + (term (2 1))) + (test (redex-let L ([n_1 1]) + (redex-let* L ([n_1 2] [n_2 (term n_1)]) + (term (n_1 n_2)))) + (term (2 2))) + + (test (redex-let L ([(n_1 n_1) '(1 1)]) (term n_1)) + 1) + (test-syn-err + (redex-let grammar ([(number) 1] [number 1]) (term number)) + #rx"redex-let: duplicate pattern variable" 1) + (test + (redex-let* L ([(n_1) '(1)] [n_1 1]) (term n_1)) + 1)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; examples from doc.txt