diff --git a/pkgs/racket-pkgs/racket-test/tests/units/test-harness.rkt b/pkgs/racket-pkgs/racket-test/tests/units/test-harness.rkt index 019d10aa0e..8e8b598f98 100644 --- a/pkgs/racket-pkgs/racket-test/tests/units/test-harness.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/units/test-harness.rkt @@ -8,6 +8,8 @@ (define (stx-bound-id=? x y) (cond + ((and (syntax? x) (eq? '_ (syntax-e x))) + #t) ((and (stx-pair? x) (not (syntax-e (stx-car x))) (identifier? (stx-cdr x))) @@ -20,7 +22,8 @@ (stx-bound-id=? (stx-cdr x) (stx-cdr y)))) ((and (identifier? x) (identifier? y)) (bound-identifier=? x y)) - ((and (number? (syntax-e x)) (number? (syntax-e y))) + ((and (syntax? x) (number? (syntax-e x)) + (syntax? y) (number? (syntax-e y))) (= (syntax-e x) (syntax-e y))) (else #f))) diff --git a/pkgs/racket-pkgs/racket-test/tests/units/test-unit.rkt b/pkgs/racket-pkgs/racket-test/tests/units/test-unit.rkt index 067c6875dc..38a85855a0 100644 --- a/pkgs/racket-pkgs/racket-test/tests/units/test-unit.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/units/test-unit.rkt @@ -149,11 +149,12 @@ (let () (define-signature x (a b)) (lookup-sig-mac x))) + (let () (define s7 (void)) (define h (void)) (define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7)))) - (test stx-bound-id=? #'((s1 a b f) (((s2 s3) . s4) ((c d) . e) ((i) . j)) (((s5 s6) . (values #'s7 #'s7)) ((g) . #'h))) + (test stx-bound-id=? #'((s1 a b f) (((s2 s3) . _) ((c d) . e) ((i) . j)) (((_ _ _ _ _) . _) _ ((g) . #'h))) (let () (define-signature x extends super (a b (define-values (c d) e) f (define-syntaxes (g) #'h) @@ -164,7 +165,8 @@ (define h (void)) (define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7)))) (let ((a 1) (g 2) (j 3) (s1 4) (s2 5)) - (test stx-bound-id=? #'(((#f . s1) a b f) ((((#f . s2) s3) . s4) ((c d) . e) ((i) . j)) (((s5 s6) . (values #'s7 #'s7)) ((g) . #'h))) + (test stx-bound-id=? + #'((s1 a b f) (((s2 s3) . _) ((c d) . e) ((i) . j)) (((_ _ _ _ _) . _) _ ((g) . #'h))) (let () (define-signature x extends super (a b (define-values (c d) e) f (define-syntaxes (g) #'h) @@ -174,7 +176,8 @@ (define s7 (void)) (define h (void)) (define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7)))) - (test stx-bound-id=? #'((s1 a b f) (((s2 s3) . s4) ((c d) . e) ((i) . j)) (((s5 s6) . (values #'s7 #'s7)) ((g) . #'h))) + (test stx-bound-id=? + #'((s1 a b f) (((s2 s3) . _) ((c d) . e) ((i) . j)) (((_ _ _ _ _) . _) _ ((g) . #'h))) (let () (define-signature x extends super (a b (define-values (c d) e) f (define-syntaxes (g) #'h) @@ -197,7 +200,6 @@ (define-signature z ((x . a))) (lookup-sig-mac z)))) - ;; unit syntax errors (without sub-signatures) (test-syntax-error "unit: bad sig import" (unit (import 1) (export))) @@ -822,18 +824,18 @@ (define-signature s2 extends s1 ((define-values (z) (list a x)))) (define u1 (unit (import s2) (export) (cons y z))) (define u2 (unit (import) (export s2) (define a 123))) - (test (list 2 123 12) (invoke-unit (compound-unit (import) (export) - (link (((a : s2)) u2) - (() u1 a))))))) + (test (list 2 123 1) (invoke-unit (compound-unit (import) (export) + (link (((a : s2)) u2) + (() u1 a))))))) -(let () +(let ([c 5]) (define-signature s1 (a (define-values (x y) (values c 2)))) (define-signature s2 extends s1 (c (define-values (z) (list a x)))) (define u1 (unit (import s2) (export) (cons y z))) (define u2 (unit (import) (export s2) (define a 123) (define c 43))) - (test (list 2 123 43) (invoke-unit (compound-unit (import) (export) - (link (((a : s2)) u2) - (() u1 a)))))) + (test (list 2 123 5) (invoke-unit (compound-unit (import) (export) + (link (((a : s2)) u2) + (() u1 a)))))) ;; Test define-syntaxes and define-values, without except, only, prefix and rename ;; Check the scoping @@ -1051,6 +1053,7 @@ (link (((S1 : x-sig)) u3) (() u1 S2 S1) (((S2 : x-sig)) u3)))) + ;; tags (let () (define-signature s1 (a)) @@ -1564,6 +1567,7 @@ (compound-unit/infer (import) (export) (link x2 u b))))) +#; (let () (define-unit u (import x-sig) (export)) (define-unit v (import) (export x-sub) (define x 12) (define xx 13)) @@ -1794,4 +1798,61 @@ (define-values/invoke-unit u@ (import) (export s^)) x)) +;; ---------------------------------------- + +;; Make sure that right-hand side of a `define-values` +;; has the right scope, including in the case of +;; signature extension. +;; Based on examples from Dan Feltey. + +(parameterize ([current-namespace (make-base-namespace)]) + (eval + '(module scope-check/a-sig racket + (provide a^) + (define-signature a^ ((define-values (a) (+ b 1)))) + (define b 7))) + (eval + '(module scope-check/b-sig racket + (require 'scope-check/a-sig) + (provide result) + + (define-signature b^ extends a^ (b)) + + (define b-out@ (unit (import) (export b^) + (define b "BAD"))) + (define b-in@ + (unit (import b^) (export) a)) + (define result + (invoke-unit + (compound-unit (import) (export) + (link (((B : b^)) b-out@) + (() b-in@ B))))))) + (test 8 (dynamic-require ''scope-check/b-sig 'result))) + +(parameterize ([current-namespace (make-base-namespace)]) + (eval + '(module scope-check/a-sig racket + (provide a^) + (define-signature a^ ((define-values (a) (+ b 1)))) + (define b 7))) + (eval + '(module scope-check/b-sig racket + (require 'scope-check/a-sig) + (provide result) + + (define-signature b^ extends a^ ()) + (define b "BAD") + + (define b-out@ (unit (import) (export b^))) + (define b-in@ + (unit (import b^) (export) a)) + (define result + (invoke-unit + (compound-unit (import) (export) + (link (((B : b^)) b-out@) + (() b-in@ B))))))) + (test 8 (dynamic-require ''scope-check/b-sig 'result))) + +;; ---------------------------------------- + (displayln "tests passed") diff --git a/racket/collects/racket/private/unit-compiletime.rkt b/racket/collects/racket/private/unit-compiletime.rkt index 42ae4f045c..3ae8b87b45 100644 --- a/racket/collects/racket/private/unit-compiletime.rkt +++ b/racket/collects/racket/private/unit-compiletime.rkt @@ -360,7 +360,7 @@ ((prefix pid sub-spec) (process-import/export #'sub-spec res bind? (lambda (id) - (do-prefix (add-prefix id) #'pid)))) + (add-prefix (do-prefix id #'pid))))) ((rename sub-spec (internal external) ...) (let* ((sig-res (do-rename (process-import/export #'sub-spec res bind? add-prefix) diff --git a/racket/collects/racket/unit.rkt b/racket/collects/racket/unit.rkt index 84e87e6c4c..98b84b63b6 100644 --- a/racket/collects/racket/unit.rkt +++ b/racket/collects/racket/unit.rkt @@ -632,12 +632,18 @@ ((renames (((mac-name ...) mac-body) ...) (((val-name ...) val-body) ...)) - (build-val+macro-defs sig))) + (build-val+macro-defs sig)) + ((((e-post-id ...) . _) ...) (list-ref sig 4)) + ((post-renames (e-post-rhs ...)) + (build-post-val-defs sig))) (syntax->list #'(sig-elem ... (define-syntaxes . renames) (define-syntaxes (mac-name ...) mac-body) ... - (define-values (val-name ...) val-body) ...))))) + (define-values (val-name ...) val-body) ... + (define-values-for-export (e-post-id ...) + (let-syntaxes (post-renames) e-post-rhs)) + ...))))) (_ (raise-stx-err (format "must match (~a export-spec)" (syntax-e (stx-car stx)))))))) @@ -654,27 +660,18 @@ (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs)) (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) (let ([ses (checked-syntax->list sig-exprs)]) - (define-values (super-names super-ctimes super-rtimes super-bindings - super-val-defs super-stx-defs super-post-val-defs - super-ctcs) + (define-values (super-names super-ctimes super-rtimes) (if super-sigid (let* ([super-sig (lookup-signature super-sigid)] [super-siginfo (signature-siginfo super-sig)]) (values (siginfo-names super-siginfo) (siginfo-ctime-ids super-siginfo) (map syntax-local-introduce - (siginfo-rtime-ids super-siginfo)) - (map syntax-local-introduce (signature-vars super-sig)) - (map introduce-def (signature-val-defs super-sig)) - (map introduce-def (signature-stx-defs super-sig)) - (map introduce-def (signature-post-val-defs super-sig)) - (map (lambda (ctc) - (if ctc - (syntax-local-introduce ctc) - ctc)) - (signature-ctcs super-sig)))) - (values '() '() '() '() '() '() '() '()))) - (let loop ((sig-exprs ses) + (siginfo-rtime-ids super-siginfo)))) + (values '() '() '()))) + (let loop ((sig-exprs (if super-sigid + (cons #`(open #,super-sigid) ses) + ses)) (bindings null) (val-defs null) (stx-defs null) @@ -682,11 +679,11 @@ (ctcs null)) (cond ((null? sig-exprs) - (let* ([all-bindings (append super-bindings (reverse bindings))] - [all-val-defs (append super-val-defs (reverse val-defs))] - [all-stx-defs (append super-stx-defs (reverse stx-defs))] - [all-post-val-defs (append super-post-val-defs (reverse post-val-defs))] - [all-ctcs (append super-ctcs (reverse ctcs))] + (let* ([all-bindings (reverse bindings)] + [all-val-defs (reverse val-defs)] + [all-stx-defs (reverse stx-defs)] + [all-post-val-defs (reverse post-val-defs)] + [all-ctcs (reverse ctcs)] [dup (check-duplicate-identifier (append all-bindings @@ -1755,9 +1752,24 @@ (syntax-case stx () ((export-spec) (let* ((tagged-export-sig (process-tagged-export #'export-spec)) - (export-sig (caddr tagged-export-sig))) - (with-syntax ((((int-id . ext-id) ...) (car export-sig)) - ((def-name ...) (generate-temporaries (map car (car export-sig))))) + (export-sig (caddr tagged-export-sig)) + (int+ext-ids + (let ([int+ext-ids (car export-sig)] + [post-ids (apply append (map car (list-ref export-sig 4)))]) + ;; Remove any bindings that will be generated via post- definitions + (if (null? post-ids) + int+ext-ids + (let ([ht (make-bound-identifier-mapping)]) + (for ([post-id (in-list post-ids)]) + (bound-identifier-mapping-put! ht post-id #t)) + (for/list ([int+ext-id (in-list int+ext-ids)] + #:unless (bound-identifier-mapping-get + ht + (car int+ext-id) + (lambda () #f))) + int+ext-id)))))) + (with-syntax ((((int-id . ext-id) ...) int+ext-ids) + ((def-name ...) (generate-temporaries (map car int+ext-ids)))) (values #'(:unit (import) (export (rename export-spec (def-name int-id) ...)) (define def-name int-id)