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

make the two-argument version of redex-match use the right name for the procedure it returns

Browse Source
This commit is contained in:
Robby Findler 2011-05-25 12:44:20 -05:00
parent c888222fb6
commit 33e68022db
1 changed files with 18 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9,9 +9,7 @@
racket/trace racket/trace
racket/contract racket/contract
racket/list racket/list
(lib "etc.ss") (lib "etc.ss"))
(for-syntax syntax/parse
syntax/parse/experimental/contract))
(require (for-syntax (lib "name.ss" "syntax") (require (for-syntax (lib "name.ss" "syntax")
"loc-wrapper-ct.ss" "loc-wrapper-ct.ss"
@ -20,7 +18,10 @@
"underscore-allowed.ss" "underscore-allowed.ss"
(lib "boundmap.ss" "syntax") (lib "boundmap.ss" "syntax")
scheme/base scheme/base
(prefix-in pattern- scheme/match))) (prefix-in pattern- scheme/match)
syntax/parse
syntax/parse/experimental/contract
syntax/name))
(define (language-nts lang) (define (language-nts lang)
(hash-map (compiled-lang-ht lang) (λ (x y) x))) (hash-map (compiled-lang-ht lang) (λ (x y) x)))
@ -1104,9 +1105,10 @@
[(nts) (language-id-nts #'lang-exp what)] [(nts) (language-id-nts #'lang-exp what)]
[(ids/depths _) (extract-names nts what #t #'pattern)]) [(ids/depths _) (extract-names nts what #t #'pattern)])
(with-syntax ([side-condition-rewritten (rewrite-side-conditions/check-errs nts what #t #'pattern)] (with-syntax ([side-condition-rewritten (rewrite-side-conditions/check-errs nts what #t #'pattern)]
[binders (map syntax-e ids/depths)]) [binders (map syntax-e ids/depths)]
[name (syntax-local-infer-name stx)])
(syntax (syntax
(do-test-match lang-exp `side-condition-rewritten 'binders))))] (do-test-match lang-exp `side-condition-rewritten 'binders 'name))))]
[(form-name lang-exp pattern expression) [(form-name lang-exp pattern expression)
(identifier? #'lang-exp) (identifier? #'lang-exp)
(syntax (syntax
@ -1118,17 +1120,19 @@
(define-struct match (bindings) #:inspector #f) (define-struct match (bindings) #:inspector #f)
(define (do-test-match lang pat binders) (define (do-test-match lang pat binders name)
(unless (compiled-lang? lang) (unless (compiled-lang? lang)
(error 'redex-match "expected first argument to be a language, got ~e" lang)) (error 'redex-match "expected first argument to be a language, got ~e" lang))
(let ([cpat (compile-pattern lang pat #t)]) (let ([cpat (compile-pattern lang pat #t)])
(λ (exp) (procedure-rename
(let ([ans (match-pattern cpat exp)]) (λ (exp)
(and ans (let ([ans (match-pattern cpat exp)])
(map (λ (m) (make-match (sort-bindings (and ans
(filter (λ (x) (memq (bind-name x) binders)) (map (λ (m) (make-match (sort-bindings
(bindings-table (mtch-bindings m)))))) (filter (λ (x) (memq (bind-name x) binders))
ans)))))) (bindings-table (mtch-bindings m))))))
ans))))
name)))
(define (sort-bindings bnds) (define (sort-bindings bnds)
(sort (sort