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

Refactors to eliminate copied code

Browse Source
This commit is contained in:
Casey Klein 2011-04-24 14:40:48 -05:00
parent 604960f5f5
commit b3f45d3c84
2 changed files with 52 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8,7 +8,7 @@
"error.ss" "error.ss"
racket/trace racket/trace
racket/contract racket/contract
(lib "list.ss") racket/list
(lib "etc.ss") (lib "etc.ss")
(for-syntax syntax/parse (for-syntax syntax/parse
syntax/parse/experimental/contract)) syntax/parse/experimental/contract))
@ -41,69 +41,62 @@
[_ (datum->syntax (identifier-prune-lexical-context #'whatever '(#%datum)) [_ (datum->syntax (identifier-prune-lexical-context #'whatever '(#%datum))
(syntax->datum stx) stx)])))) (syntax->datum stx) stx)]))))
(define-syntax (term-match/single stx) (define-for-syntax (term-matcher orig-stx make-matcher)
(syntax-case stx () (syntax-case orig-stx ()
[(_ lang [pattern rhs] ...) [(form-name lang [pattern rhs] ...)
(begin (begin
(unless (identifier? #'lang) (unless (identifier? #'lang)
(raise-syntax-error 'term-match/single "expected an identifier in the language position" stx #'lang)) (raise-syntax-error (syntax-e #'form-name) "expected an identifier in the language position" orig-stx #'lang))
(let ([lang-nts (language-id-nts #'lang 'term-match/single)]) (let ([lang-nts (language-id-nts #'lang (syntax-e #'form-name))])
(with-syntax ([(((names ...) (names/ellipses ...)) ...) (with-syntax ([(((names ...) (names/ellipses ...)) ...)
(map (λ (x) (let-values ([(names names/ellipses) (extract-names lang-nts 'term-match/single #t x)]) (map (λ (x) (call-with-values
(list names names/ellipses))) (λ () (extract-names lang-nts (syntax-e #'form-name) #t x))
list))
(syntax->list (syntax (pattern ...))))] (syntax->list (syntax (pattern ...))))]
[(side-conditions-rewritten ...) [(side-conditions-rewritten ...)
(map (λ (x) (rewrite-side-conditions/check-errs lang-nts 'term-match #t x)) (map (λ (x) (rewrite-side-conditions/check-errs lang-nts (syntax-e #'form-name) #t x))
(syntax->list (syntax (pattern ...))))] (syntax->list (syntax (pattern ...))))]
[(cp-x ...) (generate-temporaries #'(pattern ...))]) [(cp-x ...) (generate-temporaries #'(pattern ...))]
#'(let ([lang-x lang]) [make-matcher make-matcher])
(let ([cp-x (compile-pattern lang-x `side-conditions-rewritten #t)] ...) #'(make-matcher
(λ (exp) 'form-name lang
((let/ec k (list 'pattern ...)
(let ([match (match-pattern cp-x exp)]) (list (compile-pattern lang `side-conditions-rewritten #t) ...)
(when match (list (λ (match)
(unless (null? (cdr match)) (term-let/error-name
(redex-error form-name
'term-match/single ([names/ellipses (lookup-binding (mtch-bindings match) 'names)] ...)
"pattern ~s matched term ~e multiple ways" rhs)) ...)))))]))
'pattern
exp))
(k (λ ()
(term-let/error-name
term-match/single
([names/ellipses (lookup-binding (mtch-bindings (car match)) 'names)] ...)
rhs)))))
...
(redex-error 'term-match/single "no patterns matched ~e" exp)))))))))]))
(define-syntax (term-match/single stx)
(term-matcher stx #'term-match/single/proc))
(define-syntax (term-match stx) (define-syntax (term-match stx)
(syntax-case stx () (term-matcher stx #'term-match/proc))
[(_ lang [pattern rhs] ...)
(begin (define ((term-match/proc form-name lang ps cps rhss) term)
(unless (identifier? #'lang) (append-map
(raise-syntax-error 'term-match "expected an identifier" stx #'lang)) (λ (cp rhs)
(let ([lang-nts (language-id-nts #'lang 'term-match)]) (let ([matches (match-pattern cp term)])
(with-syntax ([(((names ...) (names/ellipses ...)) ...) (if matches
(map (λ (x) (let-values ([(names names/ellipses) (extract-names lang-nts 'term-match #t x)]) (map rhs matches)
(list names names/ellipses))) '())))
(syntax->list (syntax (pattern ...))))] cps rhss))
[(side-conditions-rewritten ...)
(map (λ (x) (rewrite-side-conditions/check-errs lang-nts 'term-match #t x)) (define ((term-match/single/proc form-name lang ps cps rhss) term)
(syntax->list (syntax (pattern ...))))] (let loop ([ps ps] [cps cps] [rhss rhss])
[(cp-x ...) (generate-temporaries #'(pattern ...))]) (if (null? ps)
#'(let ([lang-x lang]) (redex-error form-name "no patterns matched ~e" term)
(let ([cp-x (compile-pattern lang-x `side-conditions-rewritten #t)] ...) (let ([match (match-pattern (car cps) term)])
(λ (exp) (if match
(append (begin
(let ([matches (match-pattern cp-x exp)]) (unless (null? (cdr match))
(if matches (redex-error
(map (λ (match) form-name
(term-let/error-name "pattern ~s matched term ~e multiple ways"
term-match (car ps)
([names/ellipses (lookup-binding (mtch-bindings match) 'names)] ...) term))
rhs)) ((car rhss) (car match)))
matches) (loop (cdr ps) (cdr cps) (cdr rhss)))))))
'())) ...)))))))]))
(define-syntax (compatible-closure stx) (define-syntax (compatible-closure stx)
(syntax-case stx () (syntax-case stx ()

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

@ -2036,6 +2036,9 @@
'(x y)) '(x y))
'(x . y)) '(x . y))
(test ((term-match/single empty-language [() 'a] [() 'b])
'())
'a)
(test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn)) (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
((λ (x) #t) (λ (x) 'wrong-exn))) ((λ (x) #t) (λ (x) 'wrong-exn)))