syntax/parse: changed minimatch to use make, catch struct errors
unstable: added syntax-local-eval, internal-definition-context-apply svn: r17144
This commit is contained in:
Ryan Culpepper
parent
4495620f3b
commit
f8e22d4cad
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
(require unstable/struct
|
||||
(for-syntax scheme/base unstable/struct))
|
||||
(provide match)
|
||||
(for-syntax scheme/base scheme/struct-info unstable/struct))
|
||||
(provide match make)
|
||||
|
||||
(define-syntax (match stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -25,7 +25,7 @@
|
|||
|
||||
;; (match-p id Pattern SuccessExpr FailureExpr)
|
||||
(define-syntax (match-p stx)
|
||||
(syntax-case stx (quote cons list)
|
||||
(syntax-case stx (quote cons list make struct)
|
||||
[(match-p x wildcard success failure)
|
||||
(and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_))
|
||||
#'success]
|
||||
|
|
@ -46,6 +46,27 @@
|
|||
[(match-p x var success failure)
|
||||
(identifier? #'var)
|
||||
#'(let ([var x]) success)]
|
||||
[(match-p x (make S p ...) success failure)
|
||||
#'(match-p x (struct S (p ...)) success failure)]
|
||||
[(match-p x (struct S (p ...)) success failure)
|
||||
(identifier? #'S)
|
||||
(let ()
|
||||
(define (not-a-struct)
|
||||
(raise-syntax-error #f "expected struct name" #'S))
|
||||
(define si (syntax-local-value #'S not-a-struct))
|
||||
(unless (struct-info? si)
|
||||
(not-a-struct))
|
||||
(let* ([si (extract-struct-info si)]
|
||||
[predicate (list-ref si 2)]
|
||||
[accessors (reverse (list-ref si 3))])
|
||||
(unless (andmap identifier? accessors)
|
||||
(raise-syntax-error #f "struct has incomplete information" #'S))
|
||||
(with-syntax ([predicate predicate]
|
||||
[(accessor ...) accessors])
|
||||
#'(if (predicate x)
|
||||
(let ([y (list (accessor x) ...)])
|
||||
(match-p y (list p ...) success failure))
|
||||
failure))))]
|
||||
[(match-p x s success failure)
|
||||
(prefab-struct-key (syntax-e #'s))
|
||||
(with-syntax ([key (prefab-struct-key (syntax-e #'s))]
|
||||
|
|
@ -55,3 +76,7 @@
|
|||
(let ([xps (cdr (vector->list (struct->vector x)))])
|
||||
(match-p xps (list p ...) success failure))
|
||||
failure)))]))
|
||||
|
||||
(define-syntax struct
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "illegal use of keyword" stx)))
|
||||
|
|
|
|||
|
|
@ -693,13 +693,13 @@
|
|||
|
||||
(define (check-list-pattern pattern stx)
|
||||
(match pattern
|
||||
[#s(pat:datum _base '())
|
||||
[(make pat:datum _base '())
|
||||
#t]
|
||||
[#s(pat:head _base _head tail)
|
||||
[(make pat:head _base _head tail)
|
||||
(check-list-pattern tail stx)]
|
||||
[#s(pat:dots _base _head tail)
|
||||
[(make pat:dots _base _head tail)
|
||||
(check-list-pattern tail stx)]
|
||||
[#s(pat:compound _base '#:pair (list _head tail))
|
||||
[(make pat:compound _base '#:pair (list _head tail))
|
||||
(check-list-pattern tail stx)]
|
||||
[_
|
||||
(wrong-syntax stx "expected proper list pattern")]))
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
|
||||
(define (default-failure-handler stx0 f)
|
||||
(match (simplify-failure f)
|
||||
[#s(failure x frontier expectation)
|
||||
[(make failure x frontier expectation)
|
||||
(report-failure stx0 x (dfc->index frontier) (dfc->stx frontier) expectation)]))
|
||||
|
||||
(define current-failure-handler
|
||||
|
|
@ -68,14 +68,14 @@
|
|||
;; simplify* : Failure -> SimpleFailure
|
||||
(define (simplify* f)
|
||||
(match f
|
||||
[#s(join-failures f1 f2)
|
||||
[(make join-failures f1 f2)
|
||||
(choose-error (simplify* f1) (simplify* f2))]
|
||||
[#s(failure x frontier expectation)
|
||||
[(make failure x frontier expectation)
|
||||
(match expectation
|
||||
[#s(expect:thing description '#t chained)
|
||||
[(make expect:thing description '#t chained)
|
||||
(let ([chained* (simplify* chained)])
|
||||
(match chained*
|
||||
[#s(failure _ chained*-frontier chained*-expectation)
|
||||
[(make failure _ chained*-frontier chained*-expectation)
|
||||
(cond [(ineffable? chained*-expectation)
|
||||
;; If simplified chained failure is ineffable,
|
||||
;; keep (& adjust) its frontier
|
||||
|
|
@ -93,14 +93,14 @@
|
|||
;; FIXME: try different selection/simplification algorithms/heuristics
|
||||
(define (simplify-failure0 f)
|
||||
(match f
|
||||
[#s(join-failures f1 f2)
|
||||
[(make join-failures f1 f2)
|
||||
(choose-error (simplify-failure0 f1) (simplify-failure0 f2))]
|
||||
[#s(failure x frontier expectation)
|
||||
[(make failure x frontier expectation)
|
||||
(match expectation
|
||||
[#s(expect:thing description '#t chained)
|
||||
[(make expect:thing description '#t chained)
|
||||
(let ([chained* (simplify-failure0 chained)])
|
||||
(match chained*
|
||||
[#s(failure _ _ chained*-expectation)
|
||||
[(make failure _ _ chained*-expectation)
|
||||
(cond [(ineffable? chained*-expectation)
|
||||
;; If simplified chained failure is ineffable, ignore it
|
||||
;; and stick to the one with the description
|
||||
|
|
@ -113,7 +113,7 @@
|
|||
|
||||
(define (adjust-failure f base-frontier)
|
||||
(match f
|
||||
[#s(failure x frontier expectation)
|
||||
[(make failure x frontier expectation)
|
||||
(let ([frontier (dfc-append base-frontier frontier)])
|
||||
(make-failure x frontier expectation))]))
|
||||
|
||||
|
|
@ -147,15 +147,15 @@
|
|||
|
||||
(define (for-alternative e index stx)
|
||||
(match e
|
||||
[#s(expect:thing description transparent? chained)
|
||||
[(make expect:thing description transparent? chained)
|
||||
(format "expected ~a" description)]
|
||||
[#s(expect:atom atom)
|
||||
[(make expect:atom atom)
|
||||
(format "expected the literal ~s" atom)]
|
||||
[#s(expect:literal literal)
|
||||
[(make expect:literal literal)
|
||||
(format "expected the literal identifier ~s" (syntax-e literal))]
|
||||
[#s(expect:message message)
|
||||
[(make expect:message message)
|
||||
(format "~a" message)]
|
||||
[#s(expect:pair)
|
||||
[(make expect:pair)
|
||||
(cond [(= index 0)
|
||||
"expected sequence of terms"]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require scheme/contract/base
|
||||
scheme/stxparam
|
||||
scheme/list
|
||||
unstable/struct
|
||||
"minimatch.ss"
|
||||
(for-syntax scheme/base
|
||||
syntax/stx
|
||||
|
|
@ -159,18 +160,18 @@ A Dynamic Frontier Context (DFC) is one of
|
|||
(define-struct dfc:pre (parent stx) #:prefab)
|
||||
(define-struct dfc:post (parent stx) #:prefab)
|
||||
|
||||
(define (dfc-empty x) (make-dfc:empty x))
|
||||
(define (dfc-empty x) (make dfc:empty x))
|
||||
(define (dfc-add-car parent stx)
|
||||
(make-dfc:car parent stx))
|
||||
(make dfc:car parent stx))
|
||||
(define (dfc-add-cdr parent _)
|
||||
(match parent
|
||||
[#s(dfc:cdr uberparent n)
|
||||
(make-dfc:cdr uberparent (add1 n))]
|
||||
[_ (make-dfc:cdr parent 1)]))
|
||||
[(make dfc:cdr uberparent n)
|
||||
(make dfc:cdr uberparent (add1 n))]
|
||||
[_ (make dfc:cdr parent 1)]))
|
||||
(define (dfc-add-pre parent stx)
|
||||
(make-dfc:pre parent stx))
|
||||
(make dfc:pre parent stx))
|
||||
(define (dfc-add-post parent stx)
|
||||
(make-dfc:post parent stx))
|
||||
(make dfc:post parent stx))
|
||||
|
||||
(define (dfc-add-unbox parent stx)
|
||||
(dfc-add-car parent stx))
|
||||
|
|
@ -181,16 +182,16 @@ A Dynamic Frontier Context (DFC) is one of
|
|||
|
||||
(define (dfc->index dfc)
|
||||
(match dfc
|
||||
[#s(dfc:cdr parent n) n]
|
||||
[(make dfc:cdr parent n) n]
|
||||
[_ 0]))
|
||||
|
||||
(define (dfc->stx dfc)
|
||||
(match dfc
|
||||
[#s(dfc:empty stx) stx]
|
||||
[#s(dfc:car parent stx) stx]
|
||||
[#s(dfc:cdr parent n) (dfc->stx parent)]
|
||||
[#s(dfc:pre parent stx) stx]
|
||||
[#s(dfc:post parent stx) stx]))
|
||||
[(make dfc:empty stx) stx]
|
||||
[(make dfc:car parent stx) stx]
|
||||
[(make dfc:cdr parent n) (dfc->stx parent)]
|
||||
[(make dfc:pre parent stx) stx]
|
||||
[(make dfc:post parent stx) stx]))
|
||||
|
||||
;; dfc-difference : DFC DFC -> nat
|
||||
;; Returns N s.t. B = (dfc-add-cdr^N A)
|
||||
|
|
@ -199,10 +200,10 @@ A Dynamic Frontier Context (DFC) is one of
|
|||
(error 'dfc-difference "~e is not an extension of ~e"
|
||||
(frontier->sexpr b) (frontier->sexpr a)))
|
||||
(match (list a b)
|
||||
[(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
|
||||
[(list (make dfc:cdr pa na) (make dfc:cdr pb nb))
|
||||
(unless (equal? pa pb) (whoops))
|
||||
(- nb na)]
|
||||
[(list pa #s(dfc:cdr pb nb))
|
||||
[(list pa (make dfc:cdr pb nb))
|
||||
(unless (equal? pa pb) (whoops))
|
||||
nb]
|
||||
[_
|
||||
|
|
@ -213,16 +214,16 @@ A Dynamic Frontier Context (DFC) is one of
|
|||
;; puts A at the base, B on top
|
||||
(define (dfc-append a b)
|
||||
(match b
|
||||
[#s(dfc:empty stx) a]
|
||||
[#s(dfc:car pb stx) (make-dfc:car (dfc-append a pb) stx)]
|
||||
[#s(dfc:cdr #s(dfc:empty _) nb)
|
||||
[(make dfc:empty stx) a]
|
||||
[(make dfc:car pb stx) (make dfc:car (dfc-append a pb) stx)]
|
||||
[(make dfc:cdr (make dfc:empty _) nb)
|
||||
;; Special case to merge "consecutive" cdr frames
|
||||
(match a
|
||||
[#s(dfc:cdr pa na) (make-dfc:cdr pa (+ na nb))]
|
||||
[_ (make-dfc:cdr a nb)])]
|
||||
[#s(dfc:cdr pb nb) (make-dfc:cdr (dfc-append a pb) nb)]
|
||||
[#s(dfc:pre pb stx) (make-dfc:pre (dfc-append a pb) stx)]
|
||||
[#s(dfc:post pb stx) (make-dfc:post (dfc-append a pb) stx)]))
|
||||
[(make dfc:cdr pa na) (make dfc:cdr pa (+ na nb))]
|
||||
[_ (make dfc:cdr a nb)])]
|
||||
[(make dfc:cdr pb nb) (make dfc:cdr (dfc-append a pb) nb)]
|
||||
[(make dfc:pre pb stx) (make dfc:pre (dfc-append a pb) stx)]
|
||||
[(make dfc:post pb stx) (make dfc:post (dfc-append a pb) stx)]))
|
||||
|
||||
|
||||
;; An Inverted DFC (IDFC) is a DFC inverted for easy comparison.
|
||||
|
|
@ -230,15 +231,15 @@ A Dynamic Frontier Context (DFC) is one of
|
|||
(define (invert-dfc dfc)
|
||||
(define (invert dfc acc)
|
||||
(match dfc
|
||||
[#s(dfc:empty _) acc]
|
||||
[#s(dfc:car parent stx)
|
||||
(invert parent (make-dfc:car acc stx))]
|
||||
[#s(dfc:cdr parent n)
|
||||
(invert parent (make-dfc:cdr acc n))]
|
||||
[#s(dfc:pre parent stx)
|
||||
(invert parent (make-dfc:pre acc stx))]
|
||||
[#s(dfc:post parent stx)
|
||||
(invert parent (make-dfc:post acc stx))]))
|
||||
[(make dfc:empty _) acc]
|
||||
[(make dfc:car parent stx)
|
||||
(invert parent (make dfc:car acc stx))]
|
||||
[(make dfc:cdr parent n)
|
||||
(invert parent (make dfc:cdr acc n))]
|
||||
[(make dfc:pre parent stx)
|
||||
(invert parent (make dfc:pre acc stx))]
|
||||
[(make dfc:post parent stx)
|
||||
(invert parent (make dfc:post acc stx))]))
|
||||
(invert dfc (dfc-empty 'dummy)))
|
||||
|
||||
;; compare-idfcs : IDFC IDFC -> (one-of '< '= '>)
|
||||
|
|
@ -247,28 +248,28 @@ A Dynamic Frontier Context (DFC) is one of
|
|||
(define (compare-idfcs a b)
|
||||
(match (list a b)
|
||||
;; Same constructors
|
||||
[(list #s(dfc:empty _) #s(dfc:empty _)) '=]
|
||||
[(list #s(dfc:car pa _) #s(dfc:car pb _))
|
||||
[(list (make dfc:empty _) (make dfc:empty _)) '=]
|
||||
[(list (make dfc:car pa _) (make dfc:car pb _))
|
||||
(compare-idfcs pa pb)]
|
||||
[(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
|
||||
[(list (make dfc:cdr pa na) (make dfc:cdr pb nb))
|
||||
(cond [(< na nb) '<]
|
||||
[(> na nb) '>]
|
||||
[(= na nb) (compare-idfcs pa pb)])]
|
||||
[(list #s(dfc:pre pa _) #s(dfc:pre pb _))
|
||||
[(list (make dfc:pre pa _) (make dfc:pre pb _))
|
||||
;; FIXME: possibly just '= here, treat all sides as equiv
|
||||
(compare-idfcs pa pb)]
|
||||
[(list #s(dfc:post pa _) #s(dfc:post pb _))
|
||||
[(list (make dfc:post pa _) (make dfc:post pb _))
|
||||
;; FIXME: possibly just '= here, treat all sides as equiv
|
||||
(compare-idfcs pa pb)]
|
||||
;; Different constructors
|
||||
[(list #s(dfc:empty _) _) '<]
|
||||
[(list _ #s(dfc:empty _)) '>]
|
||||
[(list #s(dfc:pre _ _) _) '<]
|
||||
[(list _ #s(dfc:pre _ _)) '>]
|
||||
[(list #s(dfc:car _ _) _) '<]
|
||||
[(list _ #s(dfc:car _ _)) '>]
|
||||
[(list #s(dfc:cdr _ _) _) '<]
|
||||
[(list _ #s(dfc:cdr _ _)) '>]))
|
||||
[(list (make dfc:empty _) _) '<]
|
||||
[(list _ (make dfc:empty _)) '>]
|
||||
[(list (make dfc:pre _ _) _) '<]
|
||||
[(list _ (make dfc:pre _ _)) '>]
|
||||
[(list (make dfc:car _ _) _) '<]
|
||||
[(list _ (make dfc:car _ _)) '>]
|
||||
[(list (make dfc:cdr _ _) _) '<]
|
||||
[(list _ (make dfc:cdr _ _)) '>]))
|
||||
|
||||
(define (idfc>? a b)
|
||||
(eq? (compare-idfcs a b) '>))
|
||||
|
|
@ -344,7 +345,7 @@ A Dynamic Frontier Context (DFC) is one of
|
|||
(lambda (f1)
|
||||
(let ([combining-fail
|
||||
(lambda (f2)
|
||||
(fail (make-join-failures f1 f2)))])
|
||||
(fail (make join-failures f1 f2)))])
|
||||
(try* rest-attempts combining-fail)))])
|
||||
(first-attempt next-fail)))))
|
||||
|
||||
|
|
@ -380,7 +381,7 @@ An Expectation is one of
|
|||
(or/c expect? (symbols 'ineffable)))
|
||||
|
||||
(define (merge-expectations a b)
|
||||
(make-expect:disj a b))
|
||||
(make expect:disj a b))
|
||||
|
||||
;; expect->alternatives : Expectation -> (listof Expectation)/#f
|
||||
;; #f indicates 'ineffable somewhere in expectation
|
||||
|
|
@ -541,7 +542,7 @@ An Expectation is one of
|
|||
(define fs
|
||||
(let loop ([f f])
|
||||
(match f
|
||||
[#s(join-failures f1 f2)
|
||||
[(make join-failures f1 f2)
|
||||
(append (loop f1) (loop f2))]
|
||||
[_ (list f)])))
|
||||
(case (length fs)
|
||||
|
|
@ -550,20 +551,21 @@ An Expectation is one of
|
|||
|
||||
(define (one-failure->sexpr f)
|
||||
(match f
|
||||
[#s(failure x frontier expectation)
|
||||
[(make failure x frontier expectation)
|
||||
`(failure ,(frontier->sexpr frontier)
|
||||
#:term ,(syntax->datum x)
|
||||
#:expected ,(expectation->sexpr expectation))]))
|
||||
|
||||
(define (frontier->sexpr dfc)
|
||||
(match (invert-dfc dfc)
|
||||
[#s(dfc:empty _) '()]
|
||||
[#s(dfc:car p _) (cons 0 (frontier->sexpr p))]
|
||||
[#s(dfc:cdr p n) (cons n (frontier->sexpr p))]
|
||||
[#s(dfc:side p _) (cons 'side (frontier->sexpr p))]))
|
||||
[(make dfc:empty _) '()]
|
||||
[(make dfc:car p _) (cons 0 (frontier->sexpr p))]
|
||||
[(make dfc:cdr p n) (cons n (frontier->sexpr p))]
|
||||
[(make dfc:pre p _) (cons 'pre (frontier->sexpr p))]
|
||||
[(make dfc:post p _) (cons 'post (frontier->sexpr p))]))
|
||||
|
||||
(define (expectation->sexpr expectation)
|
||||
(match expectation
|
||||
[#s(expect:thing thing '#t chained)
|
||||
(make-expect:thing thing #t (failure->sexpr chained))]
|
||||
[(make expect:thing thing '#t chained)
|
||||
(make expect:thing thing #t (failure->sexpr chained))]
|
||||
[_ expectation]))
|
||||
|
|
|
|||
|
|
@ -88,6 +88,20 @@ expression.
|
|||
|
||||
@;{----}
|
||||
|
||||
@defform[(define/with-syntax pattern expr)]{
|
||||
|
||||
Definition form of @scheme[with-syntax]. That is, it matches the
|
||||
syntax object result of @scheme[expr] against @scheme[pattern] and
|
||||
creates pattern variable definitions for the pattern variables of
|
||||
@scheme[pattern].
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(define/with-syntax (px ...) #'(a b c))
|
||||
(define/with-syntax (tmp ...) (generate-temporaries #'(px ...)))
|
||||
#'([tmp px] ...)
|
||||
]
|
||||
}
|
||||
|
||||
@defform[(define-pattern-variable id expr)]{
|
||||
|
||||
Evaluates @scheme[expr] and binds it to @scheme[id] as a pattern
|
||||
|
|
@ -234,6 +248,50 @@ in the argument list are automatically converted to symbols.
|
|||
the second error but not of the first.)
|
||||
}
|
||||
|
||||
@defproc[(internal-definition-context-apply [intdef-ctx internal-definition-context?]
|
||||
[stx syntax?])
|
||||
syntax?]{
|
||||
|
||||
Applies the renamings of @scheme[intdef-ctx] to @scheme[stx].
|
||||
|
||||
}
|
||||
|
||||
@defproc[(syntax-local-eval [stx syntax?]
|
||||
[intdef-ctx (or/c internal-definition-context? #f) #f])
|
||||
any]{
|
||||
|
||||
Evaluates @scheme[stx] as an expression in the current transformer
|
||||
environment (that is, at phase level 1), optionally extended with
|
||||
@scheme[intdef-ctx].
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(define-syntax (show-me stx)
|
||||
(syntax-case stx ()
|
||||
[(show-me expr)
|
||||
(begin
|
||||
(printf "at compile time produces ~s\n"
|
||||
(syntax-local-eval #'expr))
|
||||
#'(printf "at run time produes ~s\n"
|
||||
expr))]))
|
||||
(show-me (+ 2 5))
|
||||
(define-for-syntax fruit 'apple)
|
||||
(define fruit 'pear)
|
||||
(show-me fruit)
|
||||
#|
|
||||
(define-syntax (show-me* stx)
|
||||
(syntax-case stx ()
|
||||
[(show-me expr1)
|
||||
(call-with-values (lambda () (syntax-local-eval #'expr1))
|
||||
(lambda vals
|
||||
(with-syntax ([vals vals])
|
||||
#'(quote vals))))]))
|
||||
(define-for-syntax (sum-and-difference a b)
|
||||
(values (+ a b) (- a b)))
|
||||
(show-me* (sum-and-difference 12 9))
|
||||
|#
|
||||
]
|
||||
}
|
||||
|
||||
@addition{Sam Tobin-Hochstadt}
|
||||
|
||||
@defform[(with-syntax* ([pattern stx-expr] ...)
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
(provide unwrap-syntax
|
||||
|
||||
define-pattern-variable
|
||||
define/with-syntax
|
||||
|
||||
with-temporaries
|
||||
generate-temporary
|
||||
|
|
@ -25,7 +26,10 @@
|
|||
|
||||
current-syntax-context
|
||||
wrong-syntax
|
||||
|
||||
|
||||
internal-definition-context-apply
|
||||
syntax-local-eval
|
||||
|
||||
with-syntax*
|
||||
syntax-map)
|
||||
|
||||
|
|
@ -182,6 +186,57 @@
|
|||
extras)))
|
||||
;; Eli: The `report-error-as' thing seems arbitrary to me.
|
||||
|
||||
(define (internal-definition-context-apply intdefs stx)
|
||||
(let ([qastx (local-expand #`(quote #,stx) 'expression (list #'quote) intdefs)])
|
||||
(with-syntax ([(q astx) qastx]) #'astx)))
|
||||
|
||||
(define (syntax-local-eval stx [intdef0 #f])
|
||||
(let* ([name (generate-temporary)]
|
||||
[intdefs (syntax-local-make-definition-context intdef0)])
|
||||
(syntax-local-bind-syntaxes (list name)
|
||||
#`(call-with-values (lambda () #,stx) list)
|
||||
intdefs)
|
||||
(internal-definition-context-seal intdefs)
|
||||
(apply values
|
||||
(syntax-local-value (internal-definition-context-apply intdefs name)
|
||||
#f intdefs))))
|
||||
|
||||
(define-syntax (define/with-syntax stx)
|
||||
(syntax-case stx ()
|
||||
[(define/with-syntax pattern rhs)
|
||||
(let* ([pvar-env (get-match-vars #'define/with-syntax
|
||||
stx
|
||||
#'pattern
|
||||
'())]
|
||||
[depthmap (for/list ([x pvar-env])
|
||||
(let loop ([x x] [d 0])
|
||||
(if (pair? x)
|
||||
(loop (car x) (add1 d))
|
||||
(cons x d))))]
|
||||
[pvars (map car depthmap)]
|
||||
[depths (map cdr depthmap)]
|
||||
[mark (make-syntax-introducer)])
|
||||
(with-syntax ([(pvar ...) pvars]
|
||||
[(depth ...) depths]
|
||||
[(valvar ...) (generate-temporaries pvars)])
|
||||
#'(begin (define-values (valvar ...)
|
||||
(with-syntax ([pattern rhs])
|
||||
(values (pvar-value pvar) ...)))
|
||||
(define-syntax pvar
|
||||
(make-syntax-mapping 'depth (quote-syntax valvar)))
|
||||
...)))]))
|
||||
|
||||
;; auxiliary macro
|
||||
(define-syntax (pvar-value stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pvar)
|
||||
(identifier? #'pvar)
|
||||
(let ([mapping (syntax-local-value #'pvar)])
|
||||
(unless (syntax-pattern-variable? mapping)
|
||||
(raise-syntax-error #f "not a pattern variable" #'pvar))
|
||||
(syntax-mapping-valvar mapping))]))
|
||||
|
||||
|
||||
(define-syntax (with-syntax* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (cl) body ...) #'(with-syntax (cl) body ...)]
|
||||
|
|
@ -189,4 +244,4 @@
|
|||
#'(with-syntax (cl) (with-syntax* (cls ...) body ...))]))
|
||||
|
||||
(define (syntax-map f . stxls)
|
||||
(apply map f (map syntax->list stxls)))
|
||||
(apply map f (map syntax->list stxls)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user