From cd996c3b6cbf8eaec10fa3130df7af550e96bf45 Mon Sep 17 00:00:00 2001 From: Sorawee Porncharoenwase Date: Sun, 7 Jun 2020 01:34:53 -0700 Subject: [PATCH] Fixes #3236: preserve disappeared-use on local, block, and class --- racket/collects/racket/block.rkt | 19 ++++++++--- .../racket/private/class-internal.rkt | 33 ++++--------------- .../collects/racket/private/intdef-util.rkt | 28 ++++++++++++++++ racket/collects/racket/private/local.rkt | 18 ++++++---- 4 files changed, 60 insertions(+), 38 deletions(-) create mode 100644 racket/collects/racket/private/intdef-util.rkt diff --git a/racket/collects/racket/block.rkt b/racket/collects/racket/block.rkt index a170e83642..34aee402ee 100644 --- a/racket/collects/racket/block.rkt +++ b/racket/collects/racket/block.rkt @@ -7,7 +7,7 @@ "private/cond.rkt" "private/stxcase-scheme.rkt" "private/qqstx.rkt" - syntax/intdef)) + "private/intdef-util.rkt")) (#%provide block) @@ -46,14 +46,24 @@ #'rhs def-ctx) (with-syntax ([(id ...) (map syntax-local-identifier-as-binding (syntax->list #'(id ...)))]) - (loop todo (cons #'(define-syntaxes (id ...) rhs) r))))] + (loop todo (cons (datum->syntax + expr + (list #'define-syntaxes #'(id ...) #'rhs) + expr + expr) + r))))] [(define-values (id ...) rhs) (andmap identifier? (syntax->list #'(id ...))) (let ([ids (syntax->list #'(id ...))]) (syntax-local-bind-syntaxes ids #f def-ctx) (with-syntax ([(id ...) (map syntax-local-identifier-as-binding (syntax->list #'(id ...)))]) - (loop todo (cons #'(define-values (id ...) rhs) r))))] + (loop todo (cons (datum->syntax + expr + (list #'define-values #'(id ...) #'rhs) + expr + expr) + r))))] [else (loop todo (cons expr r))]))))]) (internal-definition-context-seal def-ctx) (let loop ([exprs exprs] @@ -62,8 +72,9 @@ [prev-exprs null]) (cond [(null? exprs) - (internal-definition-context-track + (add-decl-props def-ctx + (append prev-stx-defns prev-defns) #`(letrec-syntaxes+values #,(map stx-cdr (reverse prev-stx-defns)) #,(map stx-cdr (reverse prev-defns)) diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt index ec4ebb9ef3..cd6ad0e777 100644 --- a/racket/collects/racket/private/class-internal.rkt +++ b/racket/collects/racket/private/class-internal.rkt @@ -20,8 +20,8 @@ syntax/flatten-begin syntax/private/boundmap syntax/parse - syntax/intdef - "classidmap.rkt")) + "classidmap.rkt" + "intdef-util.rkt")) (define insp (current-inspector)) ; for all opaque structures @@ -388,7 +388,7 @@ (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx) (with-syntax ([(id ...) (map syntax-local-identifier-as-binding (syntax->list #'(id ...)))]) - (cons (syntax/loc e (define-syntaxes (id ...) rhs)) + (cons (datum->syntax e (list #'define-syntaxes #'(id ...) #'rhs) e e) (loop (cdr l))))))] [(define-values (id ...) rhs) (andmap identifier? (syntax->list #'(id ...))) @@ -956,30 +956,7 @@ [(rename-inners) (flatten pair (extract* (list (quote-syntax -rename-inner)) decls))]) - ;; this function copies properties from the declarations expressions - ;; that get dropped from a class form (e.g. (public x) from the body - ;; of a class). It doesn't use syntax-track-origin because there is - ;; no residual code that it would make sense to be the result of expanding - ;; those away. So, instead we only look at a few properties (as below). - ;; Also, add 'disappeared-binding properties from `ctx`. - (define (add-decl-props stx) - (internal-definition-context-track - def-ctx - (for/fold ([stx stx]) - ([decl (in-list (append inspect-decls decls))]) - (define (copy-prop src dest stx) - (syntax-property - stx - dest - (cons (syntax-property decl src) - (syntax-property stx dest)))) - (copy-prop - 'origin 'disappeared-use - (copy-prop - 'disappeared-use 'disappeared-use - (copy-prop - 'disappeared-binding 'disappeared-binding - stx)))))) + ;; At most one inspect: (unless (or (null? inspect-decls) (null? (cdr inspect-decls))) @@ -1536,6 +1513,8 @@ [private-field-names private-field-names]) (class-syntax-protect (add-decl-props + def-ctx + (append inspect-decls decls) (quasisyntax/loc stx (detect-field-unsafe-undefined compose-class diff --git a/racket/collects/racket/private/intdef-util.rkt b/racket/collects/racket/private/intdef-util.rkt new file mode 100644 index 0000000000..bcedd25a37 --- /dev/null +++ b/racket/collects/racket/private/intdef-util.rkt @@ -0,0 +1,28 @@ +#lang racket/base + +(provide add-decl-props) +(require syntax/intdef) + +;; this function copies properties from the declarations expressions +;; that get dropped. (e.g. (public x) from the body of a class). +;; It doesn't use syntax-track-origin because there is +;; no residual code that it would make sense to be the result of expanding +;; those away. So, instead we only look at a few properties (as below). +;; Also, add 'disappeared-binding properties from `ctx`. +(define (add-decl-props def-ctx decls stx) + (internal-definition-context-track + def-ctx + (for/fold ([stx stx]) ([decl (in-list decls)]) + (define (copy-prop src dest stx) + (syntax-property + stx + dest + (cons (syntax-property decl src) + (syntax-property stx dest)))) + (copy-prop + 'origin 'disappeared-use + (copy-prop + 'disappeared-use 'disappeared-use + (copy-prop + 'disappeared-binding 'disappeared-binding + stx)))))) diff --git a/racket/collects/racket/private/local.rkt b/racket/collects/racket/private/local.rkt index 6ecc6597b2..8847fe3b28 100644 --- a/racket/collects/racket/private/local.rkt +++ b/racket/collects/racket/private/local.rkt @@ -1,6 +1,7 @@ #lang racket/base (require (for-syntax racket/base) - (for-syntax syntax/kerncase)) + (for-syntax syntax/kerncase + "intdef-util.rkt")) (provide (for-syntax do-local)) (define-for-syntax (do-local stx combine) @@ -52,7 +53,7 @@ 'expression null)]) (syntax-local-bind-syntaxes ids #'rhs def-ctx) - (list (quasisyntax/loc d (define-syntaxes #,ids rhs)))))] + (list (datum->syntax d (list #'define-syntaxes #'(id ...) #'rhs) d d))))] [(define-syntaxes . rest) (raise-syntax-error #f "ill-formed definition" stx d)] @@ -97,10 +98,13 @@ stx 'add)) (syntax->list #'(body1 body ...)))]) - (combine def-ctx - expand-context - #'sbindings - #'vbindings - #'(body ...)))))] + (add-decl-props + def-ctx + defs + (combine def-ctx + expand-context + #'sbindings + #'vbindings + #'(body ...))))))] [(_ x body1 body ...) (raise-syntax-error #f "not a definition sequence" stx (syntax x))]))