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

Fixes #3236: preserve disappeared-use on local, block, and class

Browse Source
This commit is contained in:
Sorawee Porncharoenwase 2020-06-07 01:34:53 -07:00 committed by Matthew Flatt
parent 79e6d1865a
commit cd996c3b6c
4 changed files with 60 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
racket/collects/racket/block.rkt
View File

@ -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))

33
racket/collects/racket/private/class-internal.rkt
View File

@ -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

28
racket/collects/racket/private/intdef-util.rkt Normal file
View File

@ -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))))))

18
racket/collects/racket/private/local.rkt
View File

@ -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))]))