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

Changed convert-pat to use syntax/loc.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2006-09-15 12:12:10 -04:00
parent ee63e4e80d
commit b42e317e0c
1 changed files with 21 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/mzlib/private/match/convert-pat.ss
View File

@ -98,8 +98,8 @@
(dot-dot-k? (syntax-object->datum #'p)) (dot-dot-k? (syntax-object->datum #'p))
stx] stx]
[_ stx] [_ stx]
[() #'(list)] [() (syntax/loc stx (list))]
['() #'(list)] ['() (syntax/loc stx (list))]
['item stx] ['item stx]
[p [p
(let ((old-pat (syntax-e #'p))) (let ((old-pat (syntax-e #'p)))
@ -108,40 +108,43 @@
(char? old-pat) (char? old-pat)
(number? old-pat))) (number? old-pat)))
stx] stx]
[(? pred) #`(? #,(cert #'pred))] [(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))]
[(? pred . a) [(? pred . a)
(with-syntax ([pred (cert #'pred)] (with-syntax ([pred (cert #'pred)]
[pats (syntax-map convert-pat #'a)]) [pats (syntax-map convert-pat #'a)])
#'(? pred . pats))] (syntax/loc stx (? pred . pats)))]
[`pat #``#,(convert-quasi #'pat)] [`pat (quasisyntax/loc stx `#,(convert-quasi #'pat))]
[(= op pat) #`(app #,(cert #'op) #,(convert-pat #'pat))] [(= op pat) (quasisyntax/loc stx (app #,(cert #'op) #,(convert-pat #'pat)))]
[(and . pats) [(and . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)]) (with-syntax ([new-pats (syntax-map convert-pat #'pats)])
#'(and . new-pats))] (syntax/loc stx (and . new-pats)))]
[(or . pats) [(or . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)]) (with-syntax ([new-pats (syntax-map convert-pat #'pats)])
#'(or . new-pats))] (syntax/loc stx (or . new-pats)))]
[(not pat) #`(not #,(convert-pat #'pat))] [(not . pats)
(with-syntax ([new-pats (syntax-map convert-pat #'pats)])
(syntax/loc stx (not . new-pats)))]
[($ struct-name . fields) [($ struct-name . fields)
(with-syntax ([struct-name (cert #'struct-name)] (with-syntax ([struct-name (cert #'struct-name)]
[new-fields (syntax-map convert-pat #'fields)]) [new-fields (syntax-map convert-pat #'fields)])
#'(struct struct-name new-fields))] (syntax/loc stx (struct struct-name new-fields)))]
[(get! id) (with-syntax ([id (cert #'id)]) [(get! id) (with-syntax ([id (cert #'id)])
#'(get! id))] (syntax/loc stx (get! id)))]
[(set! id) (with-syntax ([id (cert #'id)]) [(set! id) (with-syntax ([id (cert #'id)])
#'(set! id))] (syntax/loc stx (set! id)))]
[(quote p) stx] [(quote p) stx]
[(car-pat . cdr-pat) ;; FIXME
(let ([l (imp-list? (syntax-e stx) stx)]) [(elems ...) (quasisyntax/loc stx (list . #,(syntax-map convert-pat stx)))]
(if l #`(list-rest #,@(map convert-pat l)) [(e elems ... . rest)
#`(list #,@(map convert-pat (syntax-e stx)))))] (quasisyntax/loc stx (list-rest #,@(syntax-map convert-pat #'(e elems ...))
#,(convert-pat #'rest)))]
[pt [pt
(vector? (syntax-e stx)) (vector? (syntax-e stx))
(with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))]) (with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))])
#'(vector . new-pats))] (syntax/loc stx (vector . new-pats)))]
[pt [pt
(box? (syntax-e stx)) (box? (syntax-e stx))
#`(box #,(convert-pat (unbox (syntax-e stx))))] (quasisyntax/loc stx (box #,(convert-pat (unbox (syntax-e stx)))))]
[pt [pt
(identifier? stx) (identifier? stx)
(cert stx)] (cert stx)]