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

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

@ -32,11 +32,13 @@
(parse (syntax/loc stx (quote b))))] (parse (syntax/loc stx (quote b))))]
[(quote vec) [(quote vec)
(vector? (syntax-e #'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)))))] (parse (quasisyntax/loc stx (quote #,e)))))]
[(quote vec) [(quote bx)
(vector? (syntax-e #'vec)) (box? (syntax-e #'bx))
(make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'vec)))))] (make-Box (parse (quasisyntax/loc
stx
(quote #,(unbox (syntax-e #'bx))))))]
[(quote v) [(quote v)
(or (parse-literal (syntax-e #'v)) (or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "non-literal in quote pattern" stx #'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)] [(mcons a b) (+ a b)]
[_ 'no])) [_ '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 ;; raises error
(comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]) (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)])
(expand (quote-syntax (match '(1 x 2 y 3 z) (expand (quote-syntax (match '(1 x 2 y 3 z)
[(list-no-order 1 2 3 rest ... e) rest] [(list-no-order 1 2 3 rest ... e) rest]
[_ 'no]))) [_ 'no])))
'no)) 'no))
)) ))