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

Fix PR 9286.

Browse Source 
svn: r9219
This commit is contained in:
Sam Tobin-Hochstadt 2008-04-09 13:21:46 +00:00
parent 03f299b652
commit 6a4414c82b
3 changed files with 45 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/scheme/match/compiler.ss
View File

@ -403,9 +403,12 @@
(if (stx-null? clauses)
body
(quasisyntax (let* #,clauses #,body))))
(if (null? vars)
(cond
;; if there are no rows, then just call the esc continuation
[(null? rows) #`(#,esc)]
;; if we have no variables, there are no more patterns to match
;; so we just pick the first RHS
[(null? vars)
(let ([fns
(let loop ([blocks (reverse rows)] [esc esc] [acc null])
(if (null? blocks)
@ -428,10 +431,10 @@
;; then compile the rest, with our name as the esc
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
(let/wrap #'(fns ...) #'body)))
(let/wrap #'(fns ...) #'body)))]
;; otherwise, we split the matrix into blocks
;; and compile each block with a reference to its continuation
[else
(let*-values
([(rows vars) (reorder-columns rows vars)]
[(fns)
@ -452,7 +455,7 @@
'typechecker:called-in-tail-position #t)]
acc)))))])
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
(let/wrap #'(fns ...) #'body)))))
(let/wrap #'(fns ...) #'body)))]))
;; (require mzlib/trace)
;; (trace compile* compile-one)

10
collects/scheme/match/parse-helper.ss
View File

@ -32,11 +32,13 @@
(parse (syntax/loc stx (quote b))))]
[(quote vec)
(vector? (syntax-e #'vec))
(make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
(make-Vector (for/list ([e (syntax-e #'vec)])
(parse (quasisyntax/loc stx (quote #,e)))))]
[(quote vec)
(vector? (syntax-e #'vec))
(make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'vec)))))]
[(quote bx)
(box? (syntax-e #'bx))
(make-Box (parse (quasisyntax/loc
stx
(quote #,(unbox (syntax-e #'bx))))))]
[(quote v)
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]

14
collects/tests/match/examples.ss
View File

@ -516,10 +516,24 @@
[(mcons a b) (+ a b)]
[_ 'no]))
(comp 1
(match (box 'x) ('#&x 1) (else #f)))
(comp 2
(match (vector 1 2) ('#(1 2) 2) (else #f)))
(comp 'yes
(with-handlers ([exn:fail? (lambda _ 'yes)]
[values (lambda _ 'no)])
(match 1)
'no))
;; raises error
(comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)])
(expand (quote-syntax (match '(1 x 2 y 3 z)
[(list-no-order 1 2 3 rest ... e) rest]
[_ 'no])))
'no))
))