Remove the extra use-site scope on the body of define-?-expander.
This commit is contained in:
parent
4df442f59f
commit
c45b0c3c3a
|
@ -7,6 +7,13 @@
|
||||||
|
|
||||||
(provide define-expander-type)
|
(provide define-expander-type)
|
||||||
|
|
||||||
|
(define-for-syntax (remove-use-site-scope stx)
|
||||||
|
(define bd
|
||||||
|
(syntax-local-identifier-as-binding (syntax-local-introduce #'here)))
|
||||||
|
(define delta
|
||||||
|
(make-syntax-delta-introducer (syntax-local-introduce #'here) bd))
|
||||||
|
(delta stx 'remove))
|
||||||
|
|
||||||
(define-syntax define-expander-type
|
(define-syntax define-expander-type
|
||||||
(syntax-parser
|
(syntax-parser
|
||||||
[(_ name:id)
|
[(_ name:id)
|
||||||
|
@ -14,14 +21,18 @@
|
||||||
[make-?-expander "make-~a-expander"]
|
[make-?-expander "make-~a-expander"]
|
||||||
[?-expander? "~a-expander?"]
|
[?-expander? "~a-expander?"]
|
||||||
[define-?-expander "define-~a-expander"]
|
[define-?-expander "define-~a-expander"]
|
||||||
|
[define-?-expander-bug "define-~a-expander-bug"]
|
||||||
[expand-all-?-expanders "expand-all-~a-expanders"])
|
[expand-all-?-expanders "expand-all-~a-expanders"])
|
||||||
#'(begin
|
#`(begin
|
||||||
(define-for-syntax ?-expander-type (make-expander-type))
|
(define-for-syntax ?-expander-type (make-expander-type))
|
||||||
(define-for-syntax (make-?-expander transformer)
|
(define-for-syntax (make-?-expander transformer)
|
||||||
(expander ?-expander-type transformer))
|
(expander ?-expander-type transformer))
|
||||||
(define-for-syntax (?-expander? v)
|
(define-for-syntax (?-expander? v)
|
||||||
(expander-of-type? ?-expander-type v))
|
(expander-of-type? ?-expander-type v))
|
||||||
(define-syntax-rule (define-?-expander expander-name transformer)
|
(define-syntax (define-?-expander stx)
|
||||||
(define-syntax expander-name (make-?-expander transformer)))
|
(syntax-case stx ()
|
||||||
|
[(_ expander-name transformer)
|
||||||
|
(remove-use-site-scope
|
||||||
|
#'(define-syntax expander-name (make-?-expander transformer)))]))
|
||||||
(define-for-syntax (expand-all-?-expanders stx)
|
(define-for-syntax (expand-all-?-expanders stx)
|
||||||
(expand-syntax-tree-with-expanders-of-type ?-expander-type stx))))]))
|
(expand-syntax-tree-with-expanders-of-type ?-expander-type stx))))]))
|
||||||
|
|
73
test/test-define-x-expander-use-site-scope.rkt
Normal file
73
test/test-define-x-expander-use-site-scope.rkt
Normal file
|
@ -0,0 +1,73 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(require syntax/parse
|
||||||
|
syntax/parse/experimental/eh
|
||||||
|
generic-syntax-expanders
|
||||||
|
syntax/stx
|
||||||
|
(for-syntax syntax/parse
|
||||||
|
racket/syntax)
|
||||||
|
rackunit)
|
||||||
|
|
||||||
|
(define-expander-type eh-mixin)
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(define eh-post-accumulate (make-parameter #f)))
|
||||||
|
|
||||||
|
(define-for-syntax (strip-use-site stx)
|
||||||
|
(define bd
|
||||||
|
(syntax-local-identifier-as-binding (syntax-local-introduce #'here)))
|
||||||
|
(define delta
|
||||||
|
(make-syntax-delta-introducer (syntax-local-introduce #'here) bd))
|
||||||
|
(delta stx 'remove))
|
||||||
|
|
||||||
|
(define-syntax define-eh-alternative-mixin
|
||||||
|
(syntax-parser
|
||||||
|
[(_ name ((~literal pattern) pat) ... (~optional (~seq #:post post)))
|
||||||
|
(let ()
|
||||||
|
#`(define-eh-mixin-expander name
|
||||||
|
(λ (_)
|
||||||
|
#,@(if (attribute post)
|
||||||
|
#`(((eh-post-accumulate) (quote-syntax post)))
|
||||||
|
#'())
|
||||||
|
(quote-syntax (~or . #,(strip-use-site #'(pat ...)))))))]))
|
||||||
|
|
||||||
|
(define-syntax ~no-order
|
||||||
|
(pattern-expander
|
||||||
|
(λ (stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(self pat ...)
|
||||||
|
(let ()
|
||||||
|
(define acc '())
|
||||||
|
(define (add-to-acc p)
|
||||||
|
(set! acc (cons p acc)))
|
||||||
|
(define alts
|
||||||
|
(parameterize ([eh-post-accumulate add-to-acc])
|
||||||
|
(expand-all-eh-mixin-expanders
|
||||||
|
#'(pat ...))))
|
||||||
|
#`(~and (~seq (~or . #,alts) (... ...))
|
||||||
|
#,@acc))]))))
|
||||||
|
|
||||||
|
;; Test:
|
||||||
|
|
||||||
|
(define-eh-alternative-mixin aa
|
||||||
|
(pattern (~optional (~and some-pat #:some))))
|
||||||
|
|
||||||
|
(define-eh-alternative-mixin bb
|
||||||
|
(pattern (~optional (~and other-pat #:other)))
|
||||||
|
;; Without the fix in PR #8, the following line gives the error
|
||||||
|
;; attribute: not bound as a pattern variable in: some-pat
|
||||||
|
#:post (~fail #:when (and (attribute some-pat)
|
||||||
|
(attribute other-pat))))
|
||||||
|
|
||||||
|
(check-equal? (syntax-parse #'(#:some)
|
||||||
|
[((~no-order (aa) (bb))) 'ok])
|
||||||
|
'ok)
|
||||||
|
|
||||||
|
(check-equal? (syntax-parse #'(#:other)
|
||||||
|
[((~no-order (aa) (bb))) 'ok])
|
||||||
|
'ok)
|
||||||
|
|
||||||
|
(check-equal? (syntax-parse #'(#:some #:other)
|
||||||
|
[((~no-order (aa) (bb))) 'wrong]
|
||||||
|
[_ 'ok])
|
||||||
|
'ok)
|
Loading…
Reference in New Issue
Block a user