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

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

@ -30,21 +30,22 @@
(syntax-case stx () (syntax-case stx ()
[(_ s x arg ...) [(_ s x arg ...)
(parameterize ((current-syntax-context stx)) (parameterize ((current-syntax-context stx))
(let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)] (with-disappeared-uses
[stxclass (let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
(get-stxclass/check-arity #'s stx [stxclass
(length (arguments-pargs argu)) (get-stxclass/check-arity #'s stx
(arguments-kws argu))] (length (arguments-pargs argu))
[attrs (stxclass-attrs stxclass)]) (arguments-kws argu))]
(with-syntax ([parser (stxclass-parser stxclass)] [attrs (stxclass-attrs stxclass)])
[argu argu] (with-syntax ([parser (stxclass-parser stxclass)]
[(name ...) (map attr-name attrs)] [argu argu]
[(depth ...) (map attr-depth attrs)]) [(name ...) (map attr-name attrs)]
#'(let ([fh (lambda (fs) fs)]) [(depth ...) (map attr-depth attrs)])
(app-argu parser x x (ps-empty x x) #f fh fh #f #'(let ([fh (lambda (fs) fs)])
(lambda (fh . attr-values) (app-argu parser x x (ps-empty x x) #f fh fh #f
(map vector '(name ...) '(depth ...) attr-values)) (lambda (fh . attr-values)
argu)))))])) (map vector '(name ...) '(depth ...) attr-values))
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)]

11
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))
#`(begin (define pos-module-source (quote-module-name)) (with-disappeared-uses
#,@(for/list ([scname (in-list (syntax->list #'(scname ...)))] #`(begin (define pos-module-source (quote-module-name))
[stxclass (in-list (attribute scname.value))] #,@(for/list ([scname (in-list (syntax->list #'(scname ...)))]
[rec (in-list (attribute c.rec))]) [stxclass (in-list (attribute scname.value))]
(do-one-contract stx scname stxclass rec #'pos-module-source))))])) [rec (in-list (attribute c.rec))])
(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

30
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,20 +23,21 @@
(if (eq? (syntax-local-context) 'expression) (if (eq? (syntax-local-context) 'expression)
(syntax-case stx () (syntax-case stx ()
[(rsc sc) [(rsc sc)
(let* ([stxclass (get-stxclass #'sc)] (with-disappeared-uses
[splicing? (stxclass-splicing? stxclass)]) (let* ([stxclass (get-stxclass #'sc)]
(unless (stxclass-delimit-cut? stxclass) [splicing? (stxclass-splicing? stxclass)])
(raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option" (unless (stxclass-delimit-cut? stxclass)
stx #'sc)) (raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
(with-syntax ([name (stxclass-name stxclass)] stx #'sc))
[parser (stxclass-parser stxclass)] (with-syntax ([name (stxclass-name stxclass)]
[arity (stxclass-arity stxclass)] [parser (stxclass-parser stxclass)]
[(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)] [arity (stxclass-arity stxclass)]
[ctor [(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
(if splicing? [ctor
#'reified-splicing-syntax-class (if splicing?
#'reified-syntax-class)]) #'reified-splicing-syntax-class
#'(ctor 'name parser 'arity '((aname adepth) ...))))]) #'reified-syntax-class)])
#'(ctor 'name parser 'arity '((aname adepth) ...)))))])
#`(#%expression #,stx))) #`(#%expression #,stx)))
(define (reified-syntax-class-arity r) (define (reified-syntax-class-arity r)

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

@ -9,32 +9,33 @@
(define-syntax (define-syntax-class/specialize stx) (define-syntax (define-syntax-class/specialize stx)
(parameterize ((current-syntax-context stx)) (parameterize ((current-syntax-context stx))
(syntax-case stx () (syntax-case stx ()
[(dscs header sc-expr) [(dscs header sc-expr)
(let-values ([(name formals arity) (with-disappeared-uses
(let ([p (check-stxclass-header #'header stx)]) (let-values ([(name formals arity)
(values (car p) (cadr p) (caddr p)))] (let ([p (check-stxclass-header #'header stx)])
[(target-scname argu) (values (car p) (cadr p) (caddr p)))]
(let ([p (check-stxclass-application #'sc-expr stx)]) [(target-scname argu)
(values (car p) (cdr p)))]) (let ([p (check-stxclass-application #'sc-expr stx)])
(let* ([pos-count (length (arguments-pargs argu))] (values (car p) (cdr p)))])
[kws (arguments-kws argu)] (let* ([pos-count (length (arguments-pargs argu))]
[target (get-stxclass/check-arity target-scname target-scname pos-count kws)]) [kws (arguments-kws argu)]
(with-syntax ([name name] [target (get-stxclass/check-arity target-scname target-scname pos-count kws)])
[formals formals] (with-syntax ([name name]
[parser (generate-temporary (format-symbol "parser-~a" #'name))] [formals formals]
[splicing? (stxclass-splicing? target)] [parser (generate-temporary (format-symbol "parser-~a" #'name))]
[arity arity] [splicing? (stxclass-splicing? target)]
[attrs (stxclass-attrs target)] [arity arity]
[options (stxclass-options target)] [attrs (stxclass-attrs target)]
[target-parser (stxclass-parser target)] [options (stxclass-options target)]
[argu argu]) [target-parser (stxclass-parser target)]
#`(begin (define-syntax name [argu argu])
(stxclass 'name 'arity 'attrs #`(begin (define-syntax name
(quote-syntax parser) (stxclass 'name 'arity 'attrs
'splicing? (quote-syntax parser)
options 'splicing?
#f)) options
(define-values (parser) #f))
(lambda (x cx pr es fh0 cp0 rl success . formals) (define-values (parser)
(app-argu target-parser x cx pr es fh0 cp0 rl success argu)))))))]))) (lambda (x cx pr es fh0 cp0 rl success . formals)
(app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))

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

@ -185,35 +185,36 @@
(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)
(let-values ([(rest pattern defs) (with-disappeared-uses
(parse-pattern+sides #'pattern (let-values ([(rest pattern defs)
#'rest (parse-pattern+sides #'pattern
#:splicing? #f #'rest
#:decls (new-declenv null) #:splicing? #f
#:context stx)]) #:decls (new-declenv null)
(let ([expr #:context stx)])
(syntax-case rest () (let ([expr
[( expr ) #'expr] (syntax-case rest ()
[_ (raise-syntax-error #f "bad syntax" stx)])] [( expr ) #'expr]
[attrs (pattern-attrs pattern)]) [_ (raise-syntax-error #f "bad syntax" stx)])]
(with-syntax ([(a ...) attrs] [attrs (pattern-attrs pattern)])
[(#s(attr name _ _) ...) attrs] (with-syntax ([(a ...) attrs]
[pattern pattern] [(#s(attr name _ _) ...) attrs]
[(def ...) defs] [pattern pattern]
[expr expr]) [(def ...) defs]
#'(defattrs/unpack (a ...) [expr expr])
(let* ([x (datum->syntax #f expr)] #'(defattrs/unpack (a ...)
[cx x] (let* ([x (datum->syntax #f expr)]
[pr (ps-empty x x)] [cx x]
[es #f] [pr (ps-empty x x)]
[fh0 (syntax-patterns-fail x)]) [es #f]
(parameterize ((current-syntax-context x)) [fh0 (syntax-patterns-fail x)])
def ... (parameterize ((current-syntax-context x))
(#%expression def ...
(with ([fail-handler fh0] (#%expression
[cut-prompt fh0]) (with ([fail-handler fh0]
(parse:S x cx pattern pr es [cut-prompt fh0])
(list (attribute name) ...))))))))))])) (parse:S x cx pattern pr es
(list (attribute name) ...)))))))))))]))
;; ============================================================ ;; ============================================================