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

Use syntax/loc for the definitions of the plt-match forms.

Browse Source 
svn: r8725
This commit is contained in:
Sam Tobin-Hochstadt 2008-02-19 15:25:24 +00:00
parent 8653264868
commit 79bece6c13
1 changed files with 22 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/mzlib/private/match/match-internal-func.ss
View File

@ -16,17 +16,17 @@
(syntax-case stx () (syntax-case stx ()
[(_ exp . clauses) [(_ exp . clauses)
(with-syntax ([body (gen-match #'x #'clauses stx)]) (with-syntax ([body (gen-match #'x #'clauses stx)])
#`(let ([x exp]) body))])) (syntax/loc stx (let ([x exp]) body)))]))
(define-syntax (match-lambda stx) (define-syntax (match-lambda stx)
(syntax-case stx () (syntax-case stx ()
[(k . clauses) [(k . clauses)
#'(lambda (exp) (match exp . clauses))])) (syntax/loc stx (lambda (exp) (match exp . clauses)))]))
(define-syntax (match-lambda* stx) (define-syntax (match-lambda* stx)
(syntax-case stx () (syntax-case stx ()
[(k . clauses) [(k . clauses)
#'(lambda exp (match exp . clauses))])) (syntax/loc stx (lambda exp (match exp . clauses)))]))
;; there's lots of duplication here to handle named let ;; there's lots of duplication here to handle named let
;; some factoring out would do a lot of good ;; some factoring out would do a lot of good
@ -40,34 +40,34 @@
;; with no bindings, there's nothing to do ;; with no bindings, there's nothing to do
[(_ name () body ...) [(_ name () body ...)
(identifier? #'name) (identifier? #'name)
#'(let name () body ...)] (syntax/loc stx (let name () body ...))]
[(_ () body ...) #'(let () body ...)] [(_ () body ...) (syntax/loc stx (let () body ...))]
;; optimize the all-variable case ;; optimize the all-variable case
[(_ ([pat exp]...) body ...) [(_ ([pat exp]...) body ...)
(andmap pattern-var? (syntax->list #'(pat ...))) (andmap pattern-var? (syntax->list #'(pat ...)))
#'(let name ([pat exp] ...) body ...)] (syntax/loc stx (let name ([pat exp] ...) body ...))]
[(_ name ([pat exp]...) body ...) [(_ name ([pat exp]...) body ...)
(and (identifier? (syntax name)) (and (identifier? (syntax name))
(andmap pattern-var? (syntax->list #'(pat ...)))) (andmap pattern-var? (syntax->list #'(pat ...))))
#'(let name ([pat exp] ...) body ...)] (syntax/loc stx (let name ([pat exp] ...) body ...))]
;; now the real cases ;; now the real cases
[(_ name ([pat exp] ...) . body) [(_ name ([pat exp] ...) . body)
#'(letrec ([name (match-lambda* ((list pat ...) . body))]) (syntax/loc stx (letrec ([name (match-lambda* ((list pat ...) . body))])
(name exp ...))] (name exp ...)))]
[(_ ([pat exp] ...) . body) [(_ ([pat exp] ...) . body)
#'(match (list exp ...) [(list pat ...) . body])])) (syntax/loc stx (match (list exp ...) [(list pat ...) . body]))]))
(define-syntax (match-let* stx) (define-syntax (match-let* stx)
(syntax-case stx () (syntax-case stx ()
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
((_ () body ...) ((_ () body ...)
#'(let* () body ...)) (syntax/loc stx (let* () body ...)))
((_ ([pat exp] rest ...) body ...) ((_ ([pat exp] rest ...) body ...)
(if (pattern-var? (syntax pat)) (if (pattern-var? (syntax pat))
#'(let ([pat exp]) (syntax/loc stx (let ([pat exp])
(match-let* (rest ...) body ...)) (match-let* (rest ...) body ...)))
#'(match exp [pat (match-let* (rest ...) body ...)])) (syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)]))))
))) ))
(define-syntax (match-letrec stx) (define-syntax (match-letrec stx)
(syntax-case stx () (syntax-case stx ()
@ -75,17 +75,17 @@
[(_ ([pat exp] ...) . body) [(_ ([pat exp] ...) . body)
(andmap pattern-var? (andmap pattern-var?
(syntax->list #'(pat ...))) (syntax->list #'(pat ...)))
#'(letrec ([pat exp] ...) . body)] (syntax/loc stx (letrec ([pat exp] ...) . body))]
[(_ ([pat exp] ...) . body) [(_ ([pat exp] ...) . body)
#'(let () (syntax/loc stx (let ()
(match-define (list pat ...) (list exp ...)) (match-define (list pat ...) (list exp ...))
. body)])) . body))]))
(define-syntax (match-define stx) (define-syntax (match-define stx)
(syntax-case stx () (syntax-case stx ()
[(_ pat exp) [(_ pat exp)
(identifier? #'pat) (identifier? #'pat)
#'(define pat exp)] (syntax/loc stx (define pat exp))]
[(_ pat exp) [(_ pat exp)
(let ([**match-bound-vars** '()]) (let ([**match-bound-vars** '()])
(with-syntax ([compiled-match (with-syntax ([compiled-match
@ -97,7 +97,8 @@
(with-syntax ([((vars . vals) ...) (reverse bv)]) (with-syntax ([((vars . vals) ...) (reverse bv)])
#'(values vals ...))))] #'(values vals ...))))]
[(vars ...) (map car (reverse **match-bound-vars**))]) [(vars ...) (map car (reverse **match-bound-vars**))])
#'(define-values (vars ...) (syntax/loc stx
(define-values (vars ...)
(let ([the-exp exp]) (let ([the-exp exp])
compiled-match))))])) compiled-match)))))]))
) )