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