From 812339a04bc9abd76b71c135ea06298cbc958e64 Mon Sep 17 00:00:00 2001 From: sorawee Date: Mon, 5 Oct 2020 09:13:43 -0700 Subject: [PATCH] reqprov: fix disappeared-use 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 ()) --- .../racket-test-core/tests/racket/module.rktl | 24 ++++--- racket/collects/racket/private/reqprov.rkt | 68 ++++++++++--------- 2 files changed, 49 insertions(+), 43 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index aefb3e31a4..c07fb6838d 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -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)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/racket/collects/racket/private/reqprov.rkt b/racket/collects/racket/private/reqprov.rkt index ea4b4d1e75..e83e8f514e 100644 --- a/racket/collects/racket/private/reqprov.rkt +++ b/racket/collects/racket/private/reqprov.rkt @@ -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