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

Fix handling of the scopes of contracted signature bindings

Browse Source 
fixes #1652
This commit is contained in:
Alexis King 2018-10-16 16:49:38 -05:00
parent 8b22ebbfbe
commit 5fb75e9f82
2 changed files with 74 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2212,3 +2212,32 @@
(define a1 1) (define a1 1)
(define a2 2) (define a2 2)
(test 1 (invoke-unit v (import a2^)))) (test 1 (invoke-unit v (import a2^))))
;; ----------------------------------------
;; Ensure contracted bindings have the right scopes across modules (racket/racket#1652)
(parameterize ([current-namespace (make-base-namespace)])
(eval
'(module sig racket/base
(require racket/contract racket/unit)
(provide foo^)
(define-signature foo^
[foo?
(contracted [make-foo (-> foo?)])])))
(eval
'(module unit racket/base
(require racket/unit 'sig)
(provide foo@)
(define-unit foo@
(import)
(export foo^)
(define (foo? x) #f)
(define (make-foo) #f))))
(eval
'(module use racket/base
(require racket/unit 'unit)
(define-values/invoke-unit/infer foo@)
(make-foo)))
(test-runtime-error exn:fail:contract?
"make-foo: broke its own contract"
(dynamic-require ''use #f)))

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

@ -601,23 +601,31 @@
#'(((int-vid ...) vbody) ...))))) #'(((int-vid ...) vbody) ...)))))
;; build-post-val-defs : sig -> (list syntax-object) ;; build-post-val-defs : sig -> (list syntax-object)
(define-for-syntax (build-post-val-defs sig) (define-for-syntax (build-post-val-defs+ctcs sig)
(define introduced-sig (map-sig (lambda (x) x)
(make-syntax-introducer)
sig))
(with-syntax ([(((int-ivar . ext-ivar) ...) (with-syntax ([(((int-ivar . ext-ivar) ...)
((((int-vid . ext-vid) ...) . _) ...) ((((int-vid . ext-vid) ...) . _) ...)
((((int-sid . ext-sid) ...) . _) ...) ((((int-sid . ext-sid) ...) . _) ...)
_ _
(((post-id ...) . post-rhs) ...)) (((post-id ...) . post-rhs) ...))
(map-sig (lambda (x) x) introduced-sig])
(make-syntax-introducer) (with-syntax ([post-renames
sig)]) #'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
(list (make-rename-transformers
#'((ext-ivar ... ext-vid ... ... ext-sid ... ...) (quote-syntax
(make-rename-transformers (int-ivar ...
(quote-syntax int-vid ... ...
(int-ivar ... int-sid ... ...))))])
int-vid ... ... (list
int-sid ... ...)))) #'((let-syntaxes (post-renames) post-rhs) ...)
#'(post-rhs ...)))) ; Absence of a contract is represented by #f, but a contract can be present
; and be #'f, so we have to be extra careful not to coerce to syntax objects
; too early. After wrapping in (contract . _), converting to syntax is okay.
(map (λ (ctc)
(and ctc (cons 'contract #`(let-syntaxes (post-renames) #,ctc))))
(cadddr introduced-sig))))))
;; Using `make-rename-transformers' helps improve sharing in ;; Using `make-rename-transformers' helps improve sharing in
;; a syntax-quoted list of identifiers, although it risks ;; a syntax-quoted list of identifiers, although it risks
@ -631,32 +639,32 @@
(syntax->list ids)))) (syntax->list ids))))
(define-signature-form (open stx enclosing-intro) (define-signature-form (open stx enclosing-intro)
(define (build-sig-elems sig) (define (build-sig-elems ps cs)
(map (λ (p c) (map (λ (p c)
(if c #`(contracted [#,(car p) #,c]) (car p))) (if (syntax-e c)
(car sig) #`(contracted [#,(car p) #,(cdr (syntax-e c))])
(cadddr sig))) (car p)))
ps
cs))
(parameterize ([error-syntax stx]) (parameterize ([error-syntax stx])
(syntax-case stx () (syntax-case stx ()
((_ export-spec) ((_ export-spec)
(let ([sig (process-spec #'export-spec)]) (let ([sig (process-spec #'export-spec)])
(with-syntax (((sig-elem ...) (with-syntax ([(renames
(build-sig-elems sig))
((renames
(((mac-name ...) mac-body) ...) (((mac-name ...) mac-body) ...)
(((val-name ...) val-body) ...)) (((val-name ...) val-body) ...))
((build-val+macro-defs enclosing-intro) sig)) ((build-val+macro-defs enclosing-intro) sig)]
((((e-post-id ...) . _) ...) (list-ref sig 4)) [(((e-post-id ...) . _) ...) (list-ref sig 4)]
((post-renames (e-post-rhs ...)) [((e-post-rhs ...) (e-ctc ...)) (build-post-val-defs+ctcs sig)])
(build-post-val-defs sig))) (with-syntax ([(sig-elem ...)
(syntax->list (build-sig-elems (car sig) (syntax->list #'(e-ctc ...)))])
#'(sig-elem ... (syntax->list
(define-syntaxes . renames) #'(sig-elem ...
(define-syntaxes (mac-name ...) mac-body) ... (define-syntaxes . renames)
(define-values (val-name ...) val-body) ... (define-syntaxes (mac-name ...) mac-body) ...
(define-values-for-export (e-post-id ...) (define-values (val-name ...) val-body) ...
(let-syntaxes (post-renames) e-post-rhs)) (define-values-for-export (e-post-id ...) 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))))))))
@ -881,11 +889,7 @@
;; - (unit (import import-spec ...) (export export-spec ...) unit-body-expr ...) ;; - (unit (import import-spec ...) (export export-spec ...) unit-body-expr ...)
(define-for-syntax (localify exp def-ctx) (define-for-syntax (localify exp def-ctx)
(cadr (syntax->list (internal-definition-context-introduce def-ctx exp 'add))
(local-expand #`(stop #,exp)
'expression
(list #'stop)
def-ctx))))
(define-for-syntax (tagged-sigid->tagged-siginfo x) (define-for-syntax (tagged-sigid->tagged-siginfo x)
(cons (car x) (cons (car x)
@ -944,7 +948,7 @@
;; The `intro` mark should be added to everything except ;; The `intro` mark should be added to everything except
;; the introduced parts, which we implement by adding the ;; the introduced parts, which we implement by adding the
;; mark to the introduced parts and then flipping it ;; mark to the introduced parts and then flipping it
;; evenrywehere. ;; everywhere.
(define intro (make-syntax-introducer #t)) (define intro (make-syntax-introducer #t))
(with-syntax ((((dept . depr) ...) (with-syntax ((((dept . depr) ...)
@ -958,18 +962,11 @@
[(((int-ivar . ext-ivar) ...) ...) (map car import-sigs)] [(((int-ivar . ext-ivar) ...) ...) (map car import-sigs)]
[(((int-evar . ext-evar) ...) ...) (map car export-sigs)] [(((int-evar . ext-evar) ...) ...) (map car export-sigs)]
[((((e-post-id ...) . _) ...) ...) (map (lambda (s) (list-ref s 4)) export-sigs)] [((((e-post-id ...) . _) ...) ...) (map (lambda (s) (list-ref s 4)) export-sigs)]
[((post-renames (e-post-rhs ...)) ...) (map build-post-val-defs export-sigs)] [(((e-post-rhs ...) (e-ctc ...)) ...) (map build-post-val-defs+ctcs export-sigs)]
[((iloc ...) ...) [((iloc ...) ...)
(map (lambda (x) (generate-temporaries (car x))) import-sigs)] (map (lambda (x) (generate-temporaries (car x))) import-sigs)]
[((eloc ...) ...) [((eloc ...) ...)
(map (lambda (x) (generate-temporaries (car x))) export-sigs)] (map (lambda (x) (generate-temporaries (car x))) export-sigs)]
[((ectc ...) ...)
(map (λ (sig)
(map (λ (ctc)
(if ctc
(cons 'contract ctc)
#f))
(cadddr sig))) export-sigs)]
[((import-key import-super-keys ...) ...) [((import-key import-super-keys ...) ...)
(map tagged-info->keys import-tagged-infos)] (map tagged-info->keys import-tagged-infos)]
[((export-key ...) ...) [((export-key ...) ...)
@ -1029,11 +1026,10 @@
(int-ivar ... ...) (int-ivar ... ...)
(int-evar ... ...) (int-evar ... ...)
(eloc ... ...) (eloc ... ...)
(ectc ... ...) (e-ctc ... ...)
(begin . body) (begin . body)
(define-values (e-post-id ...) (define-values (e-post-id ...)
(letrec-syntaxes+values (post-renames ...) () e-post-rhs) ... ...)))))
e-post-rhs)) ... ...)))))
(unit-export ((export-key ...) (unit-export ((export-key ...)
(vector-immutable (λ () (check-not-unsafe-undefined (unbox eloc) 'int-evar)) (vector-immutable (λ () (check-not-unsafe-undefined (unbox eloc) 'int-evar))
...)) ...))
@ -1131,7 +1127,6 @@
[_ (void)])) [_ (void)]))
expanded-body) expanded-body)
table)]) table)])
(internal-definition-context-seal def-ctx)
;; Mark exported names and ;; Mark exported names and
;; check that all exported names are defined (as var): ;; check that all exported names are defined (as var):