racket/unit: repairs related to signature extension
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
parent
8ed5a32d5d
commit
bcafba989f
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user