Wrap various syntax/parse forms in with-disappeared-uses (#1397)
fixes #1396
This commit is contained in:
Alexis King
Ryan Culpepper
parent
ba8b848f94
commit
169472487e
|
|
@ -30,21 +30,22 @@
|
|||
(syntax-case stx ()
|
||||
[(_ s x arg ...)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
|
||||
[stxclass
|
||||
(get-stxclass/check-arity #'s stx
|
||||
(length (arguments-pargs argu))
|
||||
(arguments-kws argu))]
|
||||
[attrs (stxclass-attrs stxclass)])
|
||||
(with-syntax ([parser (stxclass-parser stxclass)]
|
||||
[argu argu]
|
||||
[(name ...) (map attr-name attrs)]
|
||||
[(depth ...) (map attr-depth attrs)])
|
||||
#'(let ([fh (lambda (fs) fs)])
|
||||
(app-argu parser x x (ps-empty x x) #f fh fh #f
|
||||
(lambda (fh . attr-values)
|
||||
(map vector '(name ...) '(depth ...) attr-values))
|
||||
argu)))))]))
|
||||
(with-disappeared-uses
|
||||
(let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
|
||||
[stxclass
|
||||
(get-stxclass/check-arity #'s stx
|
||||
(length (arguments-pargs argu))
|
||||
(arguments-kws argu))]
|
||||
[attrs (stxclass-attrs stxclass)])
|
||||
(with-syntax ([parser (stxclass-parser stxclass)]
|
||||
[argu argu]
|
||||
[(name ...) (map attr-name attrs)]
|
||||
[(depth ...) (map attr-depth attrs)])
|
||||
#'(let ([fh (lambda (fs) fs)])
|
||||
(app-argu parser x x (ps-empty x x) #f fh fh #f
|
||||
(lambda (fh . attr-values)
|
||||
(map vector '(name ...) '(depth ...) attr-values))
|
||||
argu))))))]))
|
||||
|
||||
(define-syntaxes (syntax-class-attributes
|
||||
syntax-class-arity
|
||||
|
|
@ -54,7 +55,8 @@
|
|||
(syntax-case stx ()
|
||||
[(_ s)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(handler (get-stxclass #'s)))]))
|
||||
(with-disappeared-uses
|
||||
(handler (get-stxclass #'s))))]))
|
||||
(values (mk (lambda (s)
|
||||
(let ([attrs (stxclass-attrs s)])
|
||||
(with-syntax ([(a ...) (map attr-name attrs)]
|
||||
|
|
|
|||
|
|
@ -134,11 +134,12 @@
|
|||
[(_ [scname c:stxclass-ctc] ...)
|
||||
#:declare scname (static stxclass? "syntax class")
|
||||
(parameterize ((current-syntax-context stx))
|
||||
#`(begin (define pos-module-source (quote-module-name))
|
||||
#,@(for/list ([scname (in-list (syntax->list #'(scname ...)))]
|
||||
[stxclass (in-list (attribute scname.value))]
|
||||
[rec (in-list (attribute c.rec))])
|
||||
(do-one-contract stx scname stxclass rec #'pos-module-source))))]))
|
||||
(with-disappeared-uses
|
||||
#`(begin (define pos-module-source (quote-module-name))
|
||||
#,@(for/list ([scname (in-list (syntax->list #'(scname ...)))]
|
||||
[stxclass (in-list (attribute scname.value))]
|
||||
[rec (in-list (attribute c.rec))])
|
||||
(do-one-contract stx scname stxclass rec #'pos-module-source)))))]))
|
||||
|
||||
;; Copied from unstable/contract,
|
||||
;; which requires racket/contract, not racket/contract/base
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/lazy-require
|
||||
racket/syntax
|
||||
syntax/parse/private/residual-ct) ;; keep abs.path
|
||||
racket/contract/base
|
||||
racket/contract/combinator
|
||||
|
|
@ -22,20 +23,21 @@
|
|||
(if (eq? (syntax-local-context) 'expression)
|
||||
(syntax-case stx ()
|
||||
[(rsc sc)
|
||||
(let* ([stxclass (get-stxclass #'sc)]
|
||||
[splicing? (stxclass-splicing? stxclass)])
|
||||
(unless (stxclass-delimit-cut? stxclass)
|
||||
(raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
|
||||
stx #'sc))
|
||||
(with-syntax ([name (stxclass-name stxclass)]
|
||||
[parser (stxclass-parser stxclass)]
|
||||
[arity (stxclass-arity stxclass)]
|
||||
[(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
|
||||
[ctor
|
||||
(if splicing?
|
||||
#'reified-splicing-syntax-class
|
||||
#'reified-syntax-class)])
|
||||
#'(ctor 'name parser 'arity '((aname adepth) ...))))])
|
||||
(with-disappeared-uses
|
||||
(let* ([stxclass (get-stxclass #'sc)]
|
||||
[splicing? (stxclass-splicing? stxclass)])
|
||||
(unless (stxclass-delimit-cut? stxclass)
|
||||
(raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
|
||||
stx #'sc))
|
||||
(with-syntax ([name (stxclass-name stxclass)]
|
||||
[parser (stxclass-parser stxclass)]
|
||||
[arity (stxclass-arity stxclass)]
|
||||
[(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
|
||||
[ctor
|
||||
(if splicing?
|
||||
#'reified-splicing-syntax-class
|
||||
#'reified-syntax-class)])
|
||||
#'(ctor 'name parser 'arity '((aname adepth) ...)))))])
|
||||
#`(#%expression #,stx)))
|
||||
|
||||
(define (reified-syntax-class-arity r)
|
||||
|
|
|
|||
|
|
@ -9,32 +9,33 @@
|
|||
|
||||
(define-syntax (define-syntax-class/specialize stx)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(syntax-case stx ()
|
||||
[(dscs header sc-expr)
|
||||
(let-values ([(name formals arity)
|
||||
(let ([p (check-stxclass-header #'header stx)])
|
||||
(values (car p) (cadr p) (caddr p)))]
|
||||
[(target-scname argu)
|
||||
(let ([p (check-stxclass-application #'sc-expr stx)])
|
||||
(values (car p) (cdr p)))])
|
||||
(let* ([pos-count (length (arguments-pargs argu))]
|
||||
[kws (arguments-kws argu)]
|
||||
[target (get-stxclass/check-arity target-scname target-scname pos-count kws)])
|
||||
(with-syntax ([name name]
|
||||
[formals formals]
|
||||
[parser (generate-temporary (format-symbol "parser-~a" #'name))]
|
||||
[splicing? (stxclass-splicing? target)]
|
||||
[arity arity]
|
||||
[attrs (stxclass-attrs target)]
|
||||
[options (stxclass-options target)]
|
||||
[target-parser (stxclass-parser target)]
|
||||
[argu argu])
|
||||
#`(begin (define-syntax name
|
||||
(stxclass 'name 'arity 'attrs
|
||||
(quote-syntax parser)
|
||||
'splicing?
|
||||
options
|
||||
#f))
|
||||
(define-values (parser)
|
||||
(lambda (x cx pr es fh0 cp0 rl success . formals)
|
||||
(app-argu target-parser x cx pr es fh0 cp0 rl success argu)))))))])))
|
||||
(syntax-case stx ()
|
||||
[(dscs header sc-expr)
|
||||
(with-disappeared-uses
|
||||
(let-values ([(name formals arity)
|
||||
(let ([p (check-stxclass-header #'header stx)])
|
||||
(values (car p) (cadr p) (caddr p)))]
|
||||
[(target-scname argu)
|
||||
(let ([p (check-stxclass-application #'sc-expr stx)])
|
||||
(values (car p) (cdr p)))])
|
||||
(let* ([pos-count (length (arguments-pargs argu))]
|
||||
[kws (arguments-kws argu)]
|
||||
[target (get-stxclass/check-arity target-scname target-scname pos-count kws)])
|
||||
(with-syntax ([name name]
|
||||
[formals formals]
|
||||
[parser (generate-temporary (format-symbol "parser-~a" #'name))]
|
||||
[splicing? (stxclass-splicing? target)]
|
||||
[arity arity]
|
||||
[attrs (stxclass-attrs target)]
|
||||
[options (stxclass-options target)]
|
||||
[target-parser (stxclass-parser target)]
|
||||
[argu argu])
|
||||
#`(begin (define-syntax name
|
||||
(stxclass 'name 'arity 'attrs
|
||||
(quote-syntax parser)
|
||||
'splicing?
|
||||
options
|
||||
#f))
|
||||
(define-values (parser)
|
||||
(lambda (x cx pr es fh0 cp0 rl success . formals)
|
||||
(app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))
|
||||
|
|
|
|||
|
|
@ -185,35 +185,36 @@
|
|||
(define-syntax (define/syntax-parse stx)
|
||||
(syntax-case stx ()
|
||||
[(define/syntax-parse pattern . rest)
|
||||
(let-values ([(rest pattern defs)
|
||||
(parse-pattern+sides #'pattern
|
||||
#'rest
|
||||
#:splicing? #f
|
||||
#:decls (new-declenv null)
|
||||
#:context stx)])
|
||||
(let ([expr
|
||||
(syntax-case rest ()
|
||||
[( expr ) #'expr]
|
||||
[_ (raise-syntax-error #f "bad syntax" stx)])]
|
||||
[attrs (pattern-attrs pattern)])
|
||||
(with-syntax ([(a ...) attrs]
|
||||
[(#s(attr name _ _) ...) attrs]
|
||||
[pattern pattern]
|
||||
[(def ...) defs]
|
||||
[expr expr])
|
||||
#'(defattrs/unpack (a ...)
|
||||
(let* ([x (datum->syntax #f expr)]
|
||||
[cx x]
|
||||
[pr (ps-empty x x)]
|
||||
[es #f]
|
||||
[fh0 (syntax-patterns-fail x)])
|
||||
(parameterize ((current-syntax-context x))
|
||||
def ...
|
||||
(#%expression
|
||||
(with ([fail-handler fh0]
|
||||
[cut-prompt fh0])
|
||||
(parse:S x cx pattern pr es
|
||||
(list (attribute name) ...))))))))))]))
|
||||
(with-disappeared-uses
|
||||
(let-values ([(rest pattern defs)
|
||||
(parse-pattern+sides #'pattern
|
||||
#'rest
|
||||
#:splicing? #f
|
||||
#:decls (new-declenv null)
|
||||
#:context stx)])
|
||||
(let ([expr
|
||||
(syntax-case rest ()
|
||||
[( expr ) #'expr]
|
||||
[_ (raise-syntax-error #f "bad syntax" stx)])]
|
||||
[attrs (pattern-attrs pattern)])
|
||||
(with-syntax ([(a ...) attrs]
|
||||
[(#s(attr name _ _) ...) attrs]
|
||||
[pattern pattern]
|
||||
[(def ...) defs]
|
||||
[expr expr])
|
||||
#'(defattrs/unpack (a ...)
|
||||
(let* ([x (datum->syntax #f expr)]
|
||||
[cx x]
|
||||
[pr (ps-empty x x)]
|
||||
[es #f]
|
||||
[fh0 (syntax-patterns-fail x)])
|
||||
(parameterize ((current-syntax-context x))
|
||||
def ...
|
||||
(#%expression
|
||||
(with ([fail-handler fh0]
|
||||
[cut-prompt fh0])
|
||||
(parse:S x cx pattern pr es
|
||||
(list (attribute name) ...)))))))))))]))
|
||||
|
||||
;; ============================================================
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user