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

racket/unit: repairs related to signature extension

Browse Source 
Fix signature extension so that the scope of identifiers in the
extended signature behaves the same as `open`.

Also, fix `struct` (or generally `define-values-for-export`)
in its interaction with `open` and `unit-from-context` (two
different bugs).
This commit is contained in:
Matthew Flatt 2014-05-23 18:37:51 +01:00
parent 8ed5a32d5d
commit bcafba989f
4 changed files with 114 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/racket-pkgs/racket-test/tests/units/test-harness.rkt
View File

@ -8,6 +8,8 @@
(define (stx-bound-id=? x y) (define (stx-bound-id=? x y)
(cond (cond
((and (syntax? x) (eq? '_ (syntax-e x)))
#t)
((and (stx-pair? x) ((and (stx-pair? x)
(not (syntax-e (stx-car x))) (not (syntax-e (stx-car x)))
(identifier? (stx-cdr x))) (identifier? (stx-cdr x)))
@ -20,7 +22,8 @@
(stx-bound-id=? (stx-cdr x) (stx-cdr y)))) (stx-bound-id=? (stx-cdr x) (stx-cdr y))))
((and (identifier? x) (identifier? y)) ((and (identifier? x) (identifier? y))
(bound-identifier=? x 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))) (= (syntax-e x) (syntax-e y)))
(else #f))) (else #f)))

83
pkgs/racket-pkgs/racket-test/tests/units/test-unit.rkt
View File

@ -149,11 +149,12 @@
(let () (let ()
(define-signature x (a b)) (define-signature x (a b))
(lookup-sig-mac x))) (lookup-sig-mac x)))
(let () (let ()
(define s7 (void)) (define s7 (void))
(define h (void)) (define h (void))
(define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7)))) (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 () (let ()
(define-signature x extends super (a b (define-values (c d) e) f (define-signature x extends super (a b (define-values (c d) e) f
(define-syntaxes (g) #'h) (define-syntaxes (g) #'h)
@ -164,7 +165,8 @@
(define h (void)) (define h (void))
(define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7)))) (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)) (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 () (let ()
(define-signature x extends super (a b (define-values (c d) e) f (define-signature x extends super (a b (define-values (c d) e) f
(define-syntaxes (g) #'h) (define-syntaxes (g) #'h)
@ -174,7 +176,8 @@
(define s7 (void)) (define s7 (void))
(define h (void)) (define h (void))
(define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7)))) (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 () (let ()
(define-signature x extends super (a b (define-values (c d) e) f (define-signature x extends super (a b (define-values (c d) e) f
(define-syntaxes (g) #'h) (define-syntaxes (g) #'h)
@ -197,7 +200,6 @@
(define-signature z ((x . a))) (define-signature z ((x . a)))
(lookup-sig-mac z)))) (lookup-sig-mac z))))
;; unit syntax errors (without sub-signatures) ;; unit syntax errors (without sub-signatures)
(test-syntax-error "unit: bad sig import" (test-syntax-error "unit: bad sig import"
(unit (import 1) (export))) (unit (import 1) (export)))
@ -822,18 +824,18 @@
(define-signature s2 extends s1 ((define-values (z) (list a x)))) (define-signature s2 extends s1 ((define-values (z) (list a x))))
(define u1 (unit (import s2) (export) (cons y z))) (define u1 (unit (import s2) (export) (cons y z)))
(define u2 (unit (import) (export s2) (define a 123))) (define u2 (unit (import) (export s2) (define a 123)))
(test (list 2 123 12) (invoke-unit (compound-unit (import) (export) (test (list 2 123 1) (invoke-unit (compound-unit (import) (export)
(link (((a : s2)) u2) (link (((a : s2)) u2)
(() u1 a))))))) (() u1 a)))))))
(let () (let ([c 5])
(define-signature s1 (a (define-values (x y) (values c 2)))) (define-signature s1 (a (define-values (x y) (values c 2))))
(define-signature s2 extends s1 (c (define-values (z) (list a x)))) (define-signature s2 extends s1 (c (define-values (z) (list a x))))
(define u1 (unit (import s2) (export) (cons y z))) (define u1 (unit (import s2) (export) (cons y z)))
(define u2 (unit (import) (export s2) (define a 123) (define c 43))) (define u2 (unit (import) (export s2) (define a 123) (define c 43)))
(test (list 2 123 43) (invoke-unit (compound-unit (import) (export) (test (list 2 123 5) (invoke-unit (compound-unit (import) (export)
(link (((a : s2)) u2) (link (((a : s2)) u2)
(() u1 a)))))) (() u1 a))))))
;; Test define-syntaxes and define-values, without except, only, prefix and rename ;; Test define-syntaxes and define-values, without except, only, prefix and rename
;; Check the scoping ;; Check the scoping
@ -1051,6 +1053,7 @@
(link (((S1 : x-sig)) u3) (link (((S1 : x-sig)) u3)
(() u1 S2 S1) (() u1 S2 S1)
(((S2 : x-sig)) u3)))) (((S2 : x-sig)) u3))))
;; tags ;; tags
(let () (let ()
(define-signature s1 (a)) (define-signature s1 (a))
@ -1564,6 +1567,7 @@
(compound-unit/infer (import) (export) (compound-unit/infer (import) (export)
(link x2 u b))))) (link x2 u b)))))
#;
(let () (let ()
(define-unit u (import x-sig) (export)) (define-unit u (import x-sig) (export))
(define-unit v (import) (export x-sub) (define x 12) (define xx 13)) (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^)) (define-values/invoke-unit u@ (import) (export s^))
x)) 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") (displayln "tests passed")

2
racket/collects/racket/private/unit-compiletime.rkt
View File

@ -360,7 +360,7 @@
((prefix pid sub-spec) ((prefix pid sub-spec)
(process-import/export #'sub-spec res bind? (process-import/export #'sub-spec res bind?
(lambda (id) (lambda (id)
(do-prefix (add-prefix id) #'pid)))) (add-prefix (do-prefix id #'pid)))))
((rename sub-spec (internal external) ...) ((rename sub-spec (internal external) ...)
(let* ((sig-res (let* ((sig-res
(do-rename (process-import/export #'sub-spec res bind? add-prefix) (do-rename (process-import/export #'sub-spec res bind? add-prefix)

62
racket/collects/racket/unit.rkt
View File

@ -632,12 +632,18 @@
((renames ((renames
(((mac-name ...) mac-body) ...) (((mac-name ...) mac-body) ...)
(((val-name ...) val-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 (syntax->list
#'(sig-elem ... #'(sig-elem ...
(define-syntaxes . renames) (define-syntaxes . renames)
(define-syntaxes (mac-name ...) mac-body) ... (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)" (raise-stx-err (format "must match (~a export-spec)"
(syntax-e (stx-car stx)))))))) (syntax-e (stx-car stx))))))))
@ -654,27 +660,18 @@
(unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs)) (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs))
(raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs))
(let ([ses (checked-syntax->list sig-exprs)]) (let ([ses (checked-syntax->list sig-exprs)])
(define-values (super-names super-ctimes super-rtimes super-bindings (define-values (super-names super-ctimes super-rtimes)
super-val-defs super-stx-defs super-post-val-defs
super-ctcs)
(if super-sigid (if super-sigid
(let* ([super-sig (lookup-signature super-sigid)] (let* ([super-sig (lookup-signature super-sigid)]
[super-siginfo (signature-siginfo super-sig)]) [super-siginfo (signature-siginfo super-sig)])
(values (siginfo-names super-siginfo) (values (siginfo-names super-siginfo)
(siginfo-ctime-ids super-siginfo) (siginfo-ctime-ids super-siginfo)
(map syntax-local-introduce (map syntax-local-introduce
(siginfo-rtime-ids super-siginfo)) (siginfo-rtime-ids super-siginfo))))
(map syntax-local-introduce (signature-vars super-sig)) (values '() '() '())))
(map introduce-def (signature-val-defs super-sig)) (let loop ((sig-exprs (if super-sigid
(map introduce-def (signature-stx-defs super-sig)) (cons #`(open #,super-sigid) ses)
(map introduce-def (signature-post-val-defs super-sig)) ses))
(map (lambda (ctc)
(if ctc
(syntax-local-introduce ctc)
ctc))
(signature-ctcs super-sig))))
(values '() '() '() '() '() '() '() '())))
(let loop ((sig-exprs ses)
(bindings null) (bindings null)
(val-defs null) (val-defs null)
(stx-defs null) (stx-defs null)
@ -682,11 +679,11 @@
(ctcs null)) (ctcs null))
(cond (cond
((null? sig-exprs) ((null? sig-exprs)
(let* ([all-bindings (append super-bindings (reverse bindings))] (let* ([all-bindings (reverse bindings)]
[all-val-defs (append super-val-defs (reverse val-defs))] [all-val-defs (reverse val-defs)]
[all-stx-defs (append super-stx-defs (reverse stx-defs))] [all-stx-defs (reverse stx-defs)]
[all-post-val-defs (append super-post-val-defs (reverse post-val-defs))] [all-post-val-defs (reverse post-val-defs)]
[all-ctcs (append super-ctcs (reverse ctcs))] [all-ctcs (reverse ctcs)]
[dup [dup
(check-duplicate-identifier (check-duplicate-identifier
(append all-bindings (append all-bindings
@ -1755,9 +1752,24 @@
(syntax-case stx () (syntax-case stx ()
((export-spec) ((export-spec)
(let* ((tagged-export-sig (process-tagged-export #'export-spec)) (let* ((tagged-export-sig (process-tagged-export #'export-spec))
(export-sig (caddr tagged-export-sig))) (export-sig (caddr tagged-export-sig))
(with-syntax ((((int-id . ext-id) ...) (car export-sig)) (int+ext-ids
((def-name ...) (generate-temporaries (map car (car export-sig))))) (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 (values
#'(:unit (import) (export (rename export-spec (def-name int-id) ...)) #'(:unit (import) (export (rename export-spec (def-name int-id) ...))
(define def-name int-id) (define def-name int-id)