diff --git a/racket/collects/syntax/parse/debug.rkt b/racket/collects/syntax/parse/debug.rkt index 59b390056a..a101d3a0d5 100644 --- a/racket/collects/syntax/parse/debug.rkt +++ b/racket/collects/syntax/parse/debug.rkt @@ -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)] diff --git a/racket/collects/syntax/parse/experimental/provide.rkt b/racket/collects/syntax/parse/experimental/provide.rkt index 25829ec138..18b4815c75 100644 --- a/racket/collects/syntax/parse/experimental/provide.rkt +++ b/racket/collects/syntax/parse/experimental/provide.rkt @@ -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 diff --git a/racket/collects/syntax/parse/experimental/reflect.rkt b/racket/collects/syntax/parse/experimental/reflect.rkt index 6d16e87522..3125422508 100644 --- a/racket/collects/syntax/parse/experimental/reflect.rkt +++ b/racket/collects/syntax/parse/experimental/reflect.rkt @@ -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) diff --git a/racket/collects/syntax/parse/experimental/specialize.rkt b/racket/collects/syntax/parse/experimental/specialize.rkt index 490c8f9ecc..f7609a6fb2 100644 --- a/racket/collects/syntax/parse/experimental/specialize.rkt +++ b/racket/collects/syntax/parse/experimental/specialize.rkt @@ -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))))))))]))) diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index 1a658139c6..c2faee01f6 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -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) ...)))))))))))])) ;; ============================================================