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

fix broken earlier commit

Browse Source
This commit is contained in:
Robby Findler 2011-05-25 14:42:37 -05:00
parent e3c552b785
commit d74810a08b
1 changed files with 16 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1120,19 +1120,24 @@
(define-struct match (bindings) #:inspector #f)
(define (do-test-match lang pat binders name)
(define (do-test-match lang pat binders context-name)
(unless (compiled-lang? lang)
(error 'redex-match "expected first argument to be a language, got ~e" lang))
(let ([cpat (compile-pattern lang pat #t)])
(procedure-rename
(λ (exp)
(let ([ans (match-pattern cpat exp)])
(and ans
(map (λ (m) (make-match (sort-bindings
(filter (λ (x) (memq (bind-name x) binders))
(bindings-table (mtch-bindings m))))))
ans))))
name)))
(define name (or context-name
(and (symbol? pat)
pat)))
(define cpat (compile-pattern lang pat #t))
(define redex-match-proc
(λ (exp)
(let ([ans (match-pattern cpat exp)])
(and ans
(map (λ (m) (make-match (sort-bindings
(filter (λ (x) (memq (bind-name x) binders))
(bindings-table (mtch-bindings m))))))
ans)))))
(if name
(procedure-rename redex-match-proc name)
redex-match-proc))
(define (sort-bindings bnds)
(sort