suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adds a form like term-let but using Redex patterns

Browse Source
This commit is contained in:
Casey Klein 2011-04-26 11:12:49 -05:00
parent b3f45d3c84
commit 1d1cdd03f5
4 changed files with 131 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/redex/private/reduction-semantics.rkt
View File

@ -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

22
collects/redex/redex.scrbl
View File

@ -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] ...)]{

2
collects/redex/reduction-semantics.rkt
View File

@ -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

52
collects/redex/tests/tl-test.rkt
View File

@ -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