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

Fix uses of make-Dummy.

Browse Source 
Fix handling of seen vars in ...

svn: r9870
This commit is contained in:
Sam Tobin-Hochstadt 2008-05-16 19:56:07 +00:00
parent 1d67f058fc
commit 61a80e85fb
2 changed files with 13 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -118,6 +118,7 @@
(compile-con-pat accs pred Struct-ps))] (compile-con-pat accs pred Struct-ps))]
[else (error 'compile "bad key: ~a" k)])) [else (error 'compile "bad key: ~a" k)]))
;; produces the syntax for a let clause ;; produces the syntax for a let clause
(define (compile-one vars block esc) (define (compile-one vars block esc)
(define-values (first rest-pats) (Row-split-pats (car block))) (define-values (first rest-pats) (Row-split-pats (car block)))
@ -147,7 +148,7 @@
(lambda (row) (lambda (row)
(define-values (p ps) (Row-split-pats row)) (define-values (p ps) (Row-split-pats row))
(define v (Var-v p)) (define v (Var-v p))
(define seen (Row-vars-seen row)) (define seen (Row-vars-seen row))
;; a new row with the rest of the patterns ;; a new row with the rest of the patterns
(cond (cond
;; if this was a wild-card variable, don't bind ;; if this was a wild-card variable, don't bind
@ -157,10 +158,9 @@
(Row-vars-seen row))] (Row-vars-seen row))]
;; if we've seen this variable before, check that it's equal to ;; if we've seen this variable before, check that it's equal to
;; the one we saw ;; the one we saw
[(ormap (lambda (e) [(for/or ([e seen])
(let ([v* (car e)] [id (cdr e)]) (let ([v* (car e)] [id (cdr e)])
(and (bound-identifier=? v v*) id))) (and (bound-identifier=? v v*) id)))
seen)
=> =>
(lambda (id) (lambda (id)
(make-Row ps (make-Row ps
@ -390,13 +390,15 @@
(make-Row pats (make-Row pats
rhs rhs
(Row-unmatch (car block)) (Row-unmatch (car block))
null)) (Row-vars-seen
(car block))))
(map list heads) (map list heads)
(syntax->list #'(rhs ...))) (syntax->list #'(rhs ...)))
(list (make-Row (list tail) (list (make-Row (list tail)
#`tail-rhs #`tail-rhs
(Row-unmatch (car block)) (Row-unmatch (car block))
null))) (Row-vars-seen
(car block)))))
#'failkv)))] #'failkv)))]
[else (error 'compile "unsupported pattern: ~a~n" first)])) [else (error 'compile "unsupported pattern: ~a~n" first)]))

8
collects/scheme/match/parse.ss
View File

@ -104,7 +104,7 @@
(cons max (map (lambda _ 1) ps)) (cons max (map (lambda _ 1) ps))
;; vars in lp are lists, vars elsewhere are not ;; vars in lp are lists, vars elsewhere are not
(cons #f (map (lambda _ #t) ps)) (cons #f (map (lambda _ #t) ps))
(make-Null (make-Dummy #f)) (make-Null (make-Dummy (syntax/loc stx _)))
#f))] #f))]
[(list-no-order p ...) [(list-no-order p ...)
(ormap ddk? (syntax->list #'(p ...))) (ormap ddk? (syntax->list #'(p ...)))
@ -119,10 +119,10 @@
(map (lambda _ 1) ps) (map (lambda _ 1) ps)
;; all of these patterns get bound to only one thing ;; all of these patterns get bound to only one thing
(map (lambda _ #t) ps) (map (lambda _ #t) ps)
(make-Null (make-Dummy #f)) (make-Null (make-Dummy (syntax/loc stx _)))
#f))] #f))]
[(list) (make-Null (make-Dummy stx))] [(list) (make-Null (make-Dummy (syntax/loc stx _)))]
[(mlist) (make-Null (make-Dummy stx))] [(mlist) (make-Null (make-Dummy (syntax/loc stx _)))]
[(list ..) [(list ..)
(ddk? #'..) (ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)] (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]