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

PR 10278

Browse Source 
svn: r15097
This commit is contained in:
Robby Findler 2009-06-05 19:51:06 +00:00
parent e8866b4020
commit 74cb273fb7
2 changed files with 24 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/redex/private/reduction-semantics.ss
View File

@ -38,21 +38,22 @@
#'(let ([lang-x lang])
(let ([cp-x (compile-pattern lang-x `side-conditions-rewritten #t)] ...)
(λ (exp)
(let/ec k
(let ([match (match-pattern cp-x exp)])
(when match
(unless (null? (cdr match))
(redex-error
'term-match/single
"pattern ~s matched term ~e multiple ways"
'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))))))))]))
((let/ec k
(let ([match (match-pattern cp-x exp)])
(when match
(unless (null? (cdr match))
(redex-error
'term-match/single
"pattern ~s matched term ~e multiple ways"
'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 stx)
(syntax-case stx ()

8
collects/redex/private/tl-test.ss
View File

@ -1344,6 +1344,14 @@
'(1 1))
1)
(test (call-with-values
(λ ()
((term-match/single empty-language
[() (values 1 2)])
'()))
list)
'(1 2))
(test (let ([x 0])
(cons ((term-match empty-language
[(any_a ... number_1 any_b ...)