units: Avoid use-before-initialization errors in signature contracts
This commit fixes an issue with the fix for contracted bindings in
signatures implemented in commit 5fb75e9f82. While the previous fix
worked in simple cases, it introduced a problem: although signatures
that define contracted bindings were able to refer to other bindings
in the signature in the binding contracts, but anyone doing so was
at the mercy of the exporting unit’s definition order. For example,
given a signature
(define-signature a^
[(contracted
[ctc contract?]
[val ctc])])
then a unit exporting the signature would cause a
use-before-initialization error if its definition for val appeared above
its definition for ctc.
This limitation did not exist in the units implementation prior to the
introduction of the sets-of-scopes expander in Racket v6.3 (after which
contracted bindings were broken until the aforementioned fix in Racket
v7.2). However, the fact that they worked at all seems semi-accidental:
instead of properly indirecting references to signature bindings within
binding contracts, the contract expressions were simply placed in a
context in which the existing names were bound. However, this meant that
any export that renamed identifiers could cause problems, which the
implementation strategy taken in this commit handles just fine.
This commit is contained in:
Alexis King
parent
1600bc5dc6
commit
db3c1d4cb9
|
|
@ -1069,3 +1069,193 @@
|
|||
(unit/c (import) (export x^) (init-depend)))
|
||||
|
||||
(void))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; 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)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Ellipses in signature bodies should not cause problems due to syntax template misuse
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval
|
||||
'(module m racket/base
|
||||
(require racket/contract
|
||||
racket/unit)
|
||||
|
||||
(provide result)
|
||||
|
||||
(define-signature foo^
|
||||
[(contracted [foo (-> integer? ... integer?)])])
|
||||
|
||||
(define-unit foo@
|
||||
(import)
|
||||
(export foo^)
|
||||
(define (foo . xs) (apply + xs)))
|
||||
|
||||
(define (foo+1@ foo-base@)
|
||||
(define-values/invoke-unit foo-base@
|
||||
(import)
|
||||
(export (prefix base: foo^)))
|
||||
(unit
|
||||
(import)
|
||||
(export foo^)
|
||||
(define (foo . xs) (add1 (apply base:foo xs)))))
|
||||
|
||||
(define-values/invoke-unit (foo+1@ foo@)
|
||||
(import)
|
||||
(export foo^))
|
||||
|
||||
(define result (foo 1 2 3))))
|
||||
(test 7 (dynamic-require ''m 'result)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Contracts that use other contracted bindings work when exporting through define-values/invoke-unit
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval
|
||||
'(module m racket/base
|
||||
(require racket/contract
|
||||
racket/unit)
|
||||
|
||||
(provide g)
|
||||
|
||||
(define-signature a^
|
||||
[(contracted
|
||||
[f (-> integer? contract?)]
|
||||
[g (f 10)])])
|
||||
|
||||
(define-unit a@
|
||||
(import)
|
||||
(export a^)
|
||||
(define (f x) (>=/c x))
|
||||
(define g 11))
|
||||
|
||||
(define-values/invoke-unit a@
|
||||
(import)
|
||||
(export a^))))
|
||||
(test 11 (dynamic-require ''m 'g)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Contracts in signatures that use bindings in the signature should work no matter what order
|
||||
;; they’re declared in
|
||||
|
||||
(let ()
|
||||
(define-signature a^
|
||||
[(contracted
|
||||
[pred? (-> any/c boolean?)]
|
||||
[proc (-> pred? pred?)])])
|
||||
|
||||
(define-signature b^
|
||||
[(contracted
|
||||
[proc (-> pred? pred?)]
|
||||
[pred? (-> any/c boolean?)])])
|
||||
|
||||
(define-values [a@ b@]
|
||||
(let ()
|
||||
(define (pred? x) (integer? x))
|
||||
(define (proc x) (add1 x))
|
||||
|
||||
(values (unit-from-context a^)
|
||||
(unit-from-context b^))))
|
||||
|
||||
(define-unit c@
|
||||
(import)
|
||||
(export a^)
|
||||
|
||||
(define (pred? x) (integer? x))
|
||||
(define (proc x) (add1 x)))
|
||||
|
||||
(define-unit d@
|
||||
(import)
|
||||
(export a^)
|
||||
|
||||
(define (proc x) (add1 x))
|
||||
(define (pred? x) (integer? x)))
|
||||
|
||||
(define-values/invoke-unit a@
|
||||
(import)
|
||||
(export (prefix a: a^)))
|
||||
(define-values/invoke-unit b@
|
||||
(import)
|
||||
(export (prefix b: b^)))
|
||||
(define-values/invoke-unit c@
|
||||
(import)
|
||||
(export (prefix c: a^)))
|
||||
(define-values/invoke-unit d@
|
||||
(import)
|
||||
(export (prefix d: a^)))
|
||||
|
||||
(test 11 (a:proc 10))
|
||||
(test 11 (b:proc 10))
|
||||
(test 11 (c:proc 10))
|
||||
(test 11 (d:proc 10))
|
||||
|
||||
(test-contract-error top-level "a:proc" "pred?" (a:proc 'not-an-integer))
|
||||
(test-contract-error top-level "b:proc" "pred?" (b:proc 'not-an-integer))
|
||||
(test-contract-error top-level "c:proc" "pred?" (c:proc 'not-an-integer))
|
||||
(test-contract-error top-level "d:proc" "pred?" (d:proc 'not-an-integer)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Signature definitions created with define-values-for-export are inside the contract boundary
|
||||
|
||||
(let ()
|
||||
(define-signature a^
|
||||
[(contracted
|
||||
[only-ints-please (-> integer? any/c)])
|
||||
(define-values-for-export [inside] (only-ints-please 'not-an-integer))
|
||||
inside])
|
||||
|
||||
(define-unit a@
|
||||
(import)
|
||||
(export a^)
|
||||
(define (only-ints-please x) x))
|
||||
|
||||
(define-values/invoke-unit/infer a@)
|
||||
|
||||
(test 'not-an-integer inside))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Contracted bindings work even if the export is renamed
|
||||
|
||||
(let ()
|
||||
(define-signature a^
|
||||
[(contracted
|
||||
[ctc contract?]
|
||||
[proc (-> ctc any/c)])])
|
||||
|
||||
(define-unit a@
|
||||
(import)
|
||||
(export (rename a^ [val/c ctc]))
|
||||
(define val/c integer?)
|
||||
(define proc add1))
|
||||
|
||||
(define-values/invoke-unit/infer a@)
|
||||
|
||||
(test 11 (proc 10))
|
||||
(test-contract-error top-level "proc" "integer?" (proc 'not-an-integer)))
|
||||
|
|
|
|||
|
|
@ -2212,94 +2212,3 @@
|
|||
(define a1 1)
|
||||
(define a2 2)
|
||||
(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)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Ellipses in signature bodies should not cause problems due to syntax template misuse
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval
|
||||
'(module m racket/base
|
||||
(require racket/contract
|
||||
racket/unit)
|
||||
|
||||
(provide result)
|
||||
|
||||
(define-signature foo^
|
||||
[(contracted [foo (-> integer? ... integer?)])])
|
||||
|
||||
(define-unit foo@
|
||||
(import)
|
||||
(export foo^)
|
||||
(define (foo . xs) (apply + xs)))
|
||||
|
||||
(define (foo+1@ foo-base@)
|
||||
(define-values/invoke-unit foo-base@
|
||||
(import)
|
||||
(export (prefix base: foo^)))
|
||||
(unit
|
||||
(import)
|
||||
(export foo^)
|
||||
(define (foo . xs) (add1 (apply base:foo xs)))))
|
||||
|
||||
(define-values/invoke-unit (foo+1@ foo@)
|
||||
(import)
|
||||
(export foo^))
|
||||
|
||||
(define result (foo 1 2 3))))
|
||||
(test 7 (dynamic-require ''m 'result)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Contracts that use other contracted bindings work when exporting through define-values/invoke-unit
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval
|
||||
'(module m racket/base
|
||||
(require racket/contract
|
||||
racket/unit)
|
||||
|
||||
(provide g)
|
||||
|
||||
(define-signature a^
|
||||
[(contracted
|
||||
[f (-> integer? contract?)]
|
||||
[g (f 10)])])
|
||||
|
||||
(define-unit a@
|
||||
(import)
|
||||
(export a^)
|
||||
(define (f x) (>=/c x))
|
||||
(define g 11))
|
||||
|
||||
(define-values/invoke-unit a@
|
||||
(import)
|
||||
(export a^))))
|
||||
(test 11 (dynamic-require ''m 'g)))
|
||||
|
|
|
|||
|
|
@ -17,8 +17,7 @@
|
|||
"private/unit-compiletime.rkt"
|
||||
"private/unit-syntax.rkt"))
|
||||
|
||||
(require racket/block
|
||||
racket/unsafe/undefined
|
||||
(require racket/unsafe/undefined
|
||||
racket/contract/base
|
||||
racket/contract/region
|
||||
racket/stxparam
|
||||
|
|
@ -602,7 +601,7 @@
|
|||
#'(((int-sid ...) sbody) ...)
|
||||
#'(((int-vid ...) vbody) ...)))))
|
||||
|
||||
;; build-post-val-defs : sig -> (list syntax-object)
|
||||
;; build-post-val-defs+ctcs : sig -> (list/c stx-list? (listof syntax?))
|
||||
(define-for-syntax (build-post-val-defs+ctcs sig)
|
||||
(define introduced-sig (map-sig (lambda (x) x)
|
||||
(make-syntax-introducer)
|
||||
|
|
@ -767,19 +766,15 @@
|
|||
(x
|
||||
(identifier? #'x)
|
||||
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs post-val-defs (cons #f ctcs)))
|
||||
((x (y z) ...)
|
||||
(and (identifier? #'x)
|
||||
(free-identifier=? #'x #'contracted)
|
||||
(andmap identifier? (syntax->list #'(y ...))))
|
||||
((contracted (y z) ...)
|
||||
(andmap identifier? (syntax->list #'(y ...)))
|
||||
(loop (cdr sig-exprs)
|
||||
(append (syntax->list #'(y ...)) bindings)
|
||||
(append (reverse (syntax->list #'(y ...))) bindings)
|
||||
val-defs
|
||||
stx-defs
|
||||
post-val-defs
|
||||
(append (syntax->list #'(z ...)) ctcs)))
|
||||
((x . z)
|
||||
(and (identifier? #'x)
|
||||
(free-identifier=? #'x #'contracted))
|
||||
(append (reverse (syntax->list #'(z ...))) ctcs)))
|
||||
((contracted . z)
|
||||
(raise-syntax-error
|
||||
'define-signature
|
||||
"expected a list of [id contract] pairs after the contracted keyword"
|
||||
|
|
@ -1102,6 +1097,14 @@
|
|||
(list #'(define-values (id ...) rhs))))]
|
||||
[else (list defn-or-expr)])))
|
||||
defns&exprs)))]
|
||||
[ends-in-defn?
|
||||
(syntax-case expanded-body ()
|
||||
[(_ ... (x . _))
|
||||
(and (identifier? #'x)
|
||||
(member #'x
|
||||
(list #'define-values #'define-syntaxes #'define-syntax)
|
||||
free-identifier=?))]
|
||||
[_ #f])]
|
||||
;; Get all the defined names, sorting out variable definitions
|
||||
;; from syntax definitions.
|
||||
[defined-names-table
|
||||
|
|
@ -1160,51 +1163,75 @@
|
|||
"definition for imported identifier"
|
||||
(var-info-id defid)))))
|
||||
(syntax->list (localify #'ivars def-ctx)))
|
||||
|
||||
(let ([marker (lambda (id) ((make-syntax-introducer) (datum->syntax #f (syntax-e id))))])
|
||||
(with-syntax ([(defn-or-expr ...)
|
||||
(apply append
|
||||
(map (λ (defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-values)
|
||||
[(define-values (id ...) body)
|
||||
(let* ([ids (syntax->list #'(id ...))]
|
||||
[tmps (map marker ids)]
|
||||
[do-one
|
||||
(λ (id tmp)
|
||||
(let ([var-info (bound-identifier-mapping-get
|
||||
defined-names-table
|
||||
id)])
|
||||
(cond
|
||||
[(var-info-exported? var-info)
|
||||
=>
|
||||
(λ (export-loc)
|
||||
(let ([ctc (var-info-ctc var-info)])
|
||||
(list (if ctc
|
||||
(quasisyntax/loc defn-or-expr
|
||||
(begin
|
||||
(contract #,ctc #,tmp
|
||||
(current-contract-region)
|
||||
'cant-happen
|
||||
(quote #,id)
|
||||
(quote-srcloc #,id))
|
||||
(set-box! #,export-loc
|
||||
(cons #,tmp (current-contract-region)))))
|
||||
(quasisyntax/loc defn-or-expr
|
||||
(set-box! #,export-loc #,tmp)))
|
||||
(quasisyntax/loc defn-or-expr
|
||||
(define-syntax #,id
|
||||
(make-id-mapper (quote-syntax #,tmp)))))))]
|
||||
[else (list (quasisyntax/loc defn-or-expr
|
||||
(define-syntax #,id
|
||||
(make-rename-transformer (quote-syntax #,tmp)))))])))])
|
||||
(cons (quasisyntax/loc defn-or-expr
|
||||
(define-values #,tmps body))
|
||||
(apply append (map do-one ids tmps))))]
|
||||
[else (list defn-or-expr)]))
|
||||
expanded-body))])
|
||||
(internal-definition-context-track
|
||||
def-ctx
|
||||
#'(block defn-or-expr ...)))))))))
|
||||
|
||||
;; Handles redirection of exported definitions and collects
|
||||
;; positive-blaming `contract` expressions
|
||||
(define (process-defn-or-expr defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-values)
|
||||
[(define-values (id ...) body)
|
||||
(let* ([ids (syntax->list #'(id ...))]
|
||||
[tmps (generate-temporaries ids)]
|
||||
[do-one
|
||||
(λ (id tmp)
|
||||
(let ([var-info (bound-identifier-mapping-get
|
||||
defined-names-table
|
||||
id)])
|
||||
(cond
|
||||
[(var-info-exported? var-info)
|
||||
=>
|
||||
(λ (export-loc)
|
||||
(let ([ctc (var-info-ctc var-info)])
|
||||
(values
|
||||
#`(begin
|
||||
#,(quasisyntax/loc defn-or-expr
|
||||
(set-box! #,export-loc
|
||||
#,(if ctc
|
||||
#`(cons #,tmp (current-contract-region))
|
||||
tmp)))
|
||||
#,(quasisyntax/loc defn-or-expr
|
||||
(define-syntax #,id
|
||||
(make-id-mapper (quote-syntax #,tmp)))))
|
||||
(and ctc
|
||||
#`(contract #,ctc #,tmp
|
||||
(current-contract-region)
|
||||
'cant-happen
|
||||
(quote #,id)
|
||||
(quote-srcloc #,id))))))]
|
||||
[else (values (quasisyntax/loc defn-or-expr
|
||||
(define-syntax #,id
|
||||
(make-rename-transformer (quote-syntax #,tmp))))
|
||||
#f)])))])
|
||||
(define-values (defns-and-exprs ctc-exprs)
|
||||
(for/lists [defns-and-exprs ctc-exprs]
|
||||
([id (in-list ids)]
|
||||
[tmp (in-list tmps)])
|
||||
(do-one id tmp)))
|
||||
(list (cons (quasisyntax/loc defn-or-expr
|
||||
(define-values #,tmps
|
||||
#,(if (and (pair? ids) (null? (cdr ids)))
|
||||
(syntax-property #'body 'inferred-name (car ids))
|
||||
#'body)))
|
||||
defns-and-exprs)
|
||||
(filter values ctc-exprs)))]
|
||||
[else (list (list defn-or-expr) '())]))
|
||||
|
||||
(internal-definition-context-track
|
||||
def-ctx
|
||||
(if (null? expanded-body)
|
||||
#'(void)
|
||||
(with-syntax ([([(defn-or-expr ...) (ctc-expr ...)] ...)
|
||||
(map process-defn-or-expr expanded-body)])
|
||||
(if ends-in-defn?
|
||||
#'(let ()
|
||||
defn-or-expr ... ...
|
||||
ctc-expr ... ...
|
||||
(void))
|
||||
(with-syntax ([(defn-or-expr ... last-defn-or-expr) #'(defn-or-expr ... ...)])
|
||||
#'(let ()
|
||||
defn-or-expr ...
|
||||
(begin0
|
||||
last-defn-or-expr
|
||||
ctc-expr ... ...))))))))))))
|
||||
|
||||
(define-for-syntax (redirect-imports/exports import?)
|
||||
(lambda (table-stx
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user