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

reqprov: fix disappeared-use

Browse Source 
This PR fixes two issues regarding disappeared-use in reqprov.rkt

1. Copy/preserve disappeared-use for all provide subforms instead
of only the first one. The following program doesn't have an arrow from
`struct-out` to `#lang racket` prior this PR, but it does after this PR.

    #lang racket
    (provide a? (struct-out a))
    (struct a ())

2. Fix incorrect `disappeared-use` for `struct-out`: it is inappropriate
to check if an identifier is bound to a struct info in provide
pre-transformer because it would not be able to handle backlinks.
This PR moves the attachment from provide pre-transformer to provide
transformer, allowing Check Syntax to draw an arrow for the identifier
`abc` in:

   #lang racket
   (provide (struct-out abc))
   (struct abc ())
This commit is contained in:
sorawee 2020-10-05 09:13:43 -07:00 committed by GitHub
parent 93e280c042
commit 812339a04b
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 49 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -1658,7 +1658,7 @@ case of module-leve bindings; it doesn't cover local bindings.
(require (rename-in racket/base [lib racket-base:lib]))
(let ()
(define (find-disappeared stx id)
(define (find-disappeared stx pred)
(let loop ([s stx])
(cond
[(syntax? s)
@ -1666,8 +1666,7 @@ case of module-leve bindings; it doesn't cover local bindings.
(syntax-property s 'origin)))
(or (let loop ([p p])
(cond
[(identifier? p) (and (free-identifier=? p id)
(eq? (syntax-e p) (syntax-e id)))]
[(identifier? p) (pred p)]
[(pair? p) (or (loop (car p))
(loop (cdr p)))]
[else #f]))
@ -1676,17 +1675,22 @@ case of module-leve bindings; it doesn't cover local bindings.
(or (loop (car s))
(loop (cdr s)))]
[else #f])))
(let ([form (expand `(module m racket/base
(provide (struct-out s))
(struct s ())))])
(test #t find-disappeared form #'struct-out))
(define ((id=? a) b)
(and (free-identifier=? a b)
(eq? (syntax-e a) (syntax-e b))))
(let ([form (expand #'(module m racket/base
(provide a (struct-out abc))
(struct abc ())
(define a 1)))])
(test #t find-disappeared form (id=? #'struct-out))
(test #t find-disappeared form (λ (id) (eq? (syntax-e id) 'abc))))
(let ([form (expand `(module m racket/base
(require (only-in racket/base car))))])
(test #t find-disappeared form #'only-in))
(test #t find-disappeared form (id=? #'only-in)))
(let ([form (expand `(module m racket/base
(require (rename-in racket/base [lib racket-base:lib])
(racket-base:lib "racket/base"))))])
(test #t find-disappeared form #'racket-base:lib))
(test #t find-disappeared form (id=? #'racket-base:lib)))
;; Check case where the provide transformer also sets disappeared-use
(let ([form (expand `(module m racket/base
(require (for-syntax racket/base racket/provide-transform))
@ -1700,7 +1704,7 @@ case of module-leve bindings; it doesn't cover local bindings.
'disappeared-use
(syntax-local-introduce #'id))]))))
(provide (my-out map))))])
(test #t find-disappeared form #'map)))
(test #t find-disappeared form (id=? #'map))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

68
racket/collects/racket/private/reqprov.rkt
View File

@ -725,7 +725,7 @@
(raise-syntax-error #f
"not at module level"
stx)]))
(define-syntax (provide-trampoline stx)
(syntax-case stx ()
[(_ out ...)
@ -758,25 +758,30 @@
(syntax/loc stx
(begin new-out ...)))))]))]))
(define-for-syntax (combine-prop b a)
(if a (if b (cons a b) a) b))
(define-for-syntax (copy-disappeared-uses outs r)
(cond
[(null? outs) r]
[else
(let ([p (syntax-property (car outs) 'disappeared-use)]
[name (if (identifier? (car outs))
#f
(syntax-local-introduce (car (syntax-e (car outs)))))]
[combine (lambda (b a)
(if a
(if b
(cons a b)
a)
b))])
(syntax-property r 'disappeared-use
(combine p
(combine
name
(syntax-property r 'disappeared-use)))))]))
[(null? outs) r]
[else
(syntax-property
r
'disappeared-use
(let loop ([outs outs]
[disappeared-uses (syntax-property r 'disappeared-use)])
(cond
[(null? outs) disappeared-uses]
[else
(let ([p (syntax-property (car outs) 'disappeared-use)]
[name (if (identifier? (car outs))
#f
(syntax-local-introduce (car (syntax-e (car outs)))))])
(loop
(cdr outs)
(combine-prop p (combine-prop name disappeared-uses))))])))]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; provide transformers
@ -794,7 +799,7 @@
(make-provide-transformer
(lambda (stx modes)
(syntax-case stx ()
[(_)
[(_)
(let* ([ht (syntax-local-module-defined-identifiers)]
[same-ctx? (lambda (free-identifier=?)
(lambda (id)
@ -986,7 +991,8 @@
stx))
(syntax-case stx ()
[(_ id)
(let ([id #'id])
(let ([id #'id]
[s-id #'id])
(unless (identifier? id)
(raise-syntax-error
#f
@ -1056,7 +1062,14 @@
(map (lambda (id)
(and id
(let ([id (find-imported/defined id)])
(make-export id
(make-export (syntax-property
id
'disappeared-use
(combine-prop
(syntax-local-introduce s-id)
(syntax-property
id
'disappeared-use)))
(syntax-e id)
0
#f
@ -1076,18 +1089,7 @@
#f
"identifier is not bound to struct type information"
stx
id))))]))
(λ (stx modes)
(syntax-case stx ()
[(_ id)
(and (identifier? #'id)
(struct-info? (syntax-local-value #'id (lambda () #f))))
(syntax-local-lift-expression
(syntax-property #'(void)
'disappeared-use
(syntax-local-introduce #'id)))]
[whatevs (void)])
stx)))
id))))]))))
(define-syntax combine-out
(make-provide-transformer