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

Changes redex-match to suppress ..._x bindings

Browse Source
This commit is contained in:
Casey Klein 2011-04-15 13:52:57 -05:00
parent 24d697e83c
commit 362a6d75a5
2 changed files with 18 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1053,19 +1053,19 @@
(define-syntax (test-match stx)
(syntax-case stx ()
[(_ lang-exp pattern)
[(form-name lang-exp pattern)
(identifier? #'lang-exp)
(with-syntax ([side-condition-rewritten (rewrite-side-conditions/check-errs
(language-id-nts #'lang-exp 'redex-match)
'redex-match
#t
(syntax pattern))])
(syntax
(do-test-match lang-exp `side-condition-rewritten)))]
[(_ lang-exp pattern expression)
(let*-values ([(what) (syntax-e #'form-name)]
[(nts) (language-id-nts #'lang-exp what)]
[(ids/depths _) (extract-names nts what #t #'pattern)])
(with-syntax ([side-condition-rewritten (rewrite-side-conditions/check-errs nts what #t #'pattern)]
[binders (map syntax-e ids/depths)])
(syntax
(do-test-match lang-exp `side-condition-rewritten 'binders))))]
[(form-name lang-exp pattern expression)
(identifier? #'lang-exp)
(syntax
((test-match lang-exp pattern) expression))]
((form-name lang-exp pattern) expression))]
[(_ a b c)
(raise-syntax-error 'redex-match "expected an identifier (bound to a language) as first argument" stx #'a)]
[(_ a b)
@ -1073,14 +1073,16 @@
(define-struct match (bindings) #:inspector #f)
(define (do-test-match lang pat)
(define (do-test-match lang pat binders)
(unless (compiled-lang? lang)
(error 'redex-match "expected first argument to be a language, got ~e" lang))
(let ([cpat (compile-pattern lang pat #t)])
(λ (exp)
(let ([ans (match-pattern cpat exp)])
(and ans
(map (λ (m) (make-match (sort-bindings (bindings-table (mtch-bindings m)))))
(map (λ (m) (make-match (sort-bindings
(filter (λ (x) (memq (bind-name x) binders))
(bindings-table (mtch-bindings m))))))
ans))))))
(define (sort-bindings bnds)

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

@ -288,6 +288,10 @@
;; not a syntax error since first e is not a binder
(test (pair? (redex-match L ((cross e) e ...) (term ((hole 2) 1)))) #t))
;; match structures do not report ..._x bindings
(test (map match-bindings (redex-match grammar (a ..._1) (term (a a a))))
'(()))
(define-syntax (test-match stx)
(syntax-case stx ()
[(_ actual (((var val) ...) ...))