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

Wrap various syntax/parse forms in with-disappeared-uses (#1397)

Browse Source 
fixes #1396
This commit is contained in:
Alexis King 2016-07-29 10:11:49 -07:00 committed by Ryan Culpepper
parent ba8b848f94
commit 169472487e
5 changed files with 100 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
racket/collects/syntax/parse/debug.rkt
View File

@ -30,6 +30,7 @@
(syntax-case stx () (syntax-case stx ()
[(_ s x arg ...) [(_ s x arg ...)
(parameterize ((current-syntax-context stx)) (parameterize ((current-syntax-context stx))
(with-disappeared-uses
(let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)] (let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
[stxclass [stxclass
(get-stxclass/check-arity #'s stx (get-stxclass/check-arity #'s stx
@ -44,7 +45,7 @@
(app-argu parser x x (ps-empty x x) #f fh fh #f (app-argu parser x x (ps-empty x x) #f fh fh #f
(lambda (fh . attr-values) (lambda (fh . attr-values)
(map vector '(name ...) '(depth ...) attr-values)) (map vector '(name ...) '(depth ...) attr-values))
argu)))))])) argu))))))]))
(define-syntaxes (syntax-class-attributes (define-syntaxes (syntax-class-attributes
syntax-class-arity syntax-class-arity
@ -54,7 +55,8 @@
(syntax-case stx () (syntax-case stx ()
[(_ s) [(_ s)
(parameterize ((current-syntax-context stx)) (parameterize ((current-syntax-context stx))
(handler (get-stxclass #'s)))])) (with-disappeared-uses
(handler (get-stxclass #'s))))]))
(values (mk (lambda (s) (values (mk (lambda (s)
(let ([attrs (stxclass-attrs s)]) (let ([attrs (stxclass-attrs s)])
(with-syntax ([(a ...) (map attr-name attrs)] (with-syntax ([(a ...) (map attr-name attrs)]

3
racket/collects/syntax/parse/experimental/provide.rkt
View File

@ -134,11 +134,12 @@
[(_ [scname c:stxclass-ctc] ...) [(_ [scname c:stxclass-ctc] ...)
#:declare scname (static stxclass? "syntax class") #:declare scname (static stxclass? "syntax class")
(parameterize ((current-syntax-context stx)) (parameterize ((current-syntax-context stx))
(with-disappeared-uses
#`(begin (define pos-module-source (quote-module-name)) #`(begin (define pos-module-source (quote-module-name))
#,@(for/list ([scname (in-list (syntax->list #'(scname ...)))] #,@(for/list ([scname (in-list (syntax->list #'(scname ...)))]
[stxclass (in-list (attribute scname.value))] [stxclass (in-list (attribute scname.value))]
[rec (in-list (attribute c.rec))]) [rec (in-list (attribute c.rec))])
(do-one-contract stx scname stxclass rec #'pos-module-source))))])) (do-one-contract stx scname stxclass rec #'pos-module-source)))))]))
;; Copied from unstable/contract, ;; Copied from unstable/contract,
;; which requires racket/contract, not racket/contract/base ;; which requires racket/contract, not racket/contract/base

4
racket/collects/syntax/parse/experimental/reflect.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base (require (for-syntax racket/base
racket/lazy-require racket/lazy-require
racket/syntax
syntax/parse/private/residual-ct) ;; keep abs.path syntax/parse/private/residual-ct) ;; keep abs.path
racket/contract/base racket/contract/base
racket/contract/combinator racket/contract/combinator
@ -22,6 +23,7 @@
(if (eq? (syntax-local-context) 'expression) (if (eq? (syntax-local-context) 'expression)
(syntax-case stx () (syntax-case stx ()
[(rsc sc) [(rsc sc)
(with-disappeared-uses
(let* ([stxclass (get-stxclass #'sc)] (let* ([stxclass (get-stxclass #'sc)]
[splicing? (stxclass-splicing? stxclass)]) [splicing? (stxclass-splicing? stxclass)])
(unless (stxclass-delimit-cut? stxclass) (unless (stxclass-delimit-cut? stxclass)
@ -35,7 +37,7 @@
(if splicing? (if splicing?
#'reified-splicing-syntax-class #'reified-splicing-syntax-class
#'reified-syntax-class)]) #'reified-syntax-class)])
#'(ctor 'name parser 'arity '((aname adepth) ...))))]) #'(ctor 'name parser 'arity '((aname adepth) ...)))))])
#`(#%expression #,stx))) #`(#%expression #,stx)))
(define (reified-syntax-class-arity r) (define (reified-syntax-class-arity r)

3
racket/collects/syntax/parse/experimental/specialize.rkt
View File

@ -11,6 +11,7 @@
(parameterize ((current-syntax-context stx)) (parameterize ((current-syntax-context stx))
(syntax-case stx () (syntax-case stx ()
[(dscs header sc-expr) [(dscs header sc-expr)
(with-disappeared-uses
(let-values ([(name formals arity) (let-values ([(name formals arity)
(let ([p (check-stxclass-header #'header stx)]) (let ([p (check-stxclass-header #'header stx)])
(values (car p) (cadr p) (caddr p)))] (values (car p) (cadr p) (caddr p)))]
@ -37,4 +38,4 @@
#f)) #f))
(define-values (parser) (define-values (parser)
(lambda (x cx pr es fh0 cp0 rl success . formals) (lambda (x cx pr es fh0 cp0 rl success . formals)
(app-argu target-parser x cx pr es fh0 cp0 rl success argu)))))))]))) (app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))

3
racket/collects/syntax/parse/private/parse.rkt
View File

@ -185,6 +185,7 @@
(define-syntax (define/syntax-parse stx) (define-syntax (define/syntax-parse stx)
(syntax-case stx () (syntax-case stx ()
[(define/syntax-parse pattern . rest) [(define/syntax-parse pattern . rest)
(with-disappeared-uses
(let-values ([(rest pattern defs) (let-values ([(rest pattern defs)
(parse-pattern+sides #'pattern (parse-pattern+sides #'pattern
#'rest #'rest
@ -213,7 +214,7 @@
(with ([fail-handler fh0] (with ([fail-handler fh0]
[cut-prompt fh0]) [cut-prompt fh0])
(parse:S x cx pattern pr es (parse:S x cx pattern pr es
(list (attribute name) ...))))))))))])) (list (attribute name) ...)))))))))))]))
;; ============================================================ ;; ============================================================