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

Improvements to unit/c contracts in preparation for unit support in typed/racket

Browse Source 
Changes:

 - Allow unit contracts to import and export the same signature.
 - Add "invoke" contracts that will wrap the result of invoking a unit contract,
   no wrapping occurs when a body contract is not specified
 - Improve error messages
 - Support for init-depend clauses in unit contracts.
 - Fix documentation to refelct the above
 - Overhaul of unit related tests

Handling init-depend clauses in unit contracts is a rather large and somewhat
non-backwards-compatible change to unit contracts. Unit contracts must now
specify at least as many initialization dependencies as the unit value being
contracted, but may include more. These new dependencies are now actually
specified in the unit wrapper so that they will be checked by compound-unit
expressions.

This commit also adds more information to the first-order-check
error messages. If a unit imports tagged signatures, previously the errror
message did not specify which tag was missing from the unit contract. Now
the tag is printed along with the signature name.

Documentation has been edited to reflect the changes to unit/c contracts
made by this commit.

Additionally this commit overhauls all tests for units and unit contracts.
Test cases now actually check that expected error messages are triggered when
checking contract, syntax, and runtime errors. Test forms now expand into uses
of rackunit's check-exn form so only test failures are reported and all tests in
a file are run on every run of the test file.
This commit is contained in:
Daniel Feltey 2015-02-17 16:34:20 -05:00 committed by Vincent St-Amour
parent 1d99ced2ea
commit b16f0b24b7
8 changed files with 1834 additions and 1253 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
pkgs/racket-doc/scribblings/reference/units.scrbl
View File

@ -700,10 +700,21 @@ Expands to a @racket[provide] of all identifiers implied by the
@section[#:tag "unitcontracts"]{Unit Contracts} @section[#:tag "unitcontracts"]{Unit Contracts}
@defform/subs[#:literals (import export) @defform/subs[#:literals (import export values init-depend)
(unit/c (import sig-block ...) (export sig-block ...)) (unit/c
(import sig-block ...)
(export sig-block ...)
init-depends-decl
optional-body-ctc)
([sig-block (tagged-sig-id [id contract] ...) ([sig-block (tagged-sig-id [id contract] ...)
tagged-sig-id])]{ tagged-sig-id]
[init-depends-decl
code:blank
(init-depend tagged-sig-id ...)]
[optional-body-ctc
code:blank
contract
(values contract ...)])]{
A @deftech{unit contract} wraps a unit and checks both its imported and A @deftech{unit contract} wraps a unit and checks both its imported and
exported identifiers to ensure that they match the appropriate contracts. exported identifiers to ensure that they match the appropriate contracts.
@ -711,21 +722,30 @@ This allows the programmer to add contract checks to a single unit value
without adding contracts to the imported and exported signatures. without adding contracts to the imported and exported signatures.
The unit value must import a subset of the import signatures and export a The unit value must import a subset of the import signatures and export a
superset of the export signatures listed in the unit contract. Any superset of the export signatures listed in the unit contract. Additionally,
identifier which is not listed for a given signature is left alone. the unit value must declare initialization dependencies that are a subset of
Variables used in a given @racket[contract] expression first refer to other those specified in the unit contract. Any identifier which is not listed
variables in the same signature, and then to the context of the for a given signature is left alone. Variables used in a given
@racket[unit/c] expression.} @racket[contract] expression first refer to other variables in the same
signature, and then to the context of the @racket[unit/c] expression.
If a body contract is specified then the result of invoking the unit value
is wrapped with the given contract, if no body contract is supplied then
no wrapping occurs when the unit value is invoked.}
@defform/subs[#:literals (import export) @defform/subs[#:literals (import export values)
(define-unit/contract unit-id (define-unit/contract unit-id
(import sig-spec-block ...) (import sig-spec-block ...)
(export sig-spec-block ...) (export sig-spec-block ...)
init-depends-decl init-depends-decl
optional-body-ctc
unit-body-expr-or-defn unit-body-expr-or-defn
...) ...)
([sig-spec-block (tagged-sig-spec [id contract] ...) ([sig-spec-block (tagged-sig-spec [id contract] ...)
tagged-sig-spec])]{ tagged-sig-spec]
[optional-body-ctc
code:blank
(code:line #:invoke/contract contract)
(code:line #:invoke/contract (values contract ...))])]{
The @racket[define-unit/contract] form defines a unit compatible with The @racket[define-unit/contract] form defines a unit compatible with
link inference whose imports and exports are contracted with a unit link inference whose imports and exports are contracted with a unit
contract. The unit name is used for the positive blame of the contract.} contract. The unit name is used for the positive blame of the contract.}

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

@ -1,5 +1,5 @@
(module test-harness racket (module test-harness racket
(require syntax/stx) (require syntax/stx rackunit)
(provide (all-defined-out)) (provide (all-defined-out))
@ -35,28 +35,24 @@
(define-syntax test-syntax-error (define-syntax test-syntax-error
(syntax-rules () (syntax-rules ()
((_ err expr) ((_ err expr)
(with-handlers ((exn:fail:syntax? (lambda (exn) (check-exn
(printf "get expected syntax error \"~a\"\n got message \"~a\"\n\n" (lambda (e) (and (exn:fail:syntax? e)
err (regexp-match? (regexp-quote err)
(exn-message exn))))) (exn-message e))))
(expand #'expr) (lambda () (expand #'expr))))))
(error 'test-syntax-error "expected syntax error \"~a\" on ~a, got none" err 'expr)))))
(define-syntax test-runtime-error (define-syntax test-runtime-error
(syntax-rules () (syntax-rules ()
((_ err-pred err expr) ((_ err-pred err expr)
(with-handlers ((err-pred (lambda (exn) (check-exn
(printf "got expected runtime error \"~a\"\n got message \"~a\"\n\n" (λ (exn) (and (err-pred exn)
err (let ([msg (exn-message exn)])
(exn-message exn))))) (and (regexp-match? (regexp-quote err) msg)))))
expr (λ () expr (void))))))
(error 'test-runtime-error "expected runtime error \"~a\" on ~a, got none" err 'expr)))))
(define-syntax test (define-syntax test
(syntax-rules () (syntax-rules ()
((_ expected-value expr) ((_ expected-value expr)
(test equal? expected-value expr)) (check-equal? expected-value expr))
((_ cmp expected-value expr) ((_ cmp expected-value expr)
(let ((v expr)) (check cmp expected-value expr)))))
(unless (cmp expected-value v)
(error 'test "expected ~a to evaluate to ~a, got ~a" 'expr 'expected-value v)))))))

11
pkgs/racket-test/tests/units/test-runtime.rkt
View File

@ -4,7 +4,8 @@
racket/private/unit-runtime) racket/private/unit-runtime)
;; check-unit ;; check-unit
(test-runtime-error exn:fail:contract? "check-unit: not a unit" (test-runtime-error exn:fail:contract?
"result of unit expression was not a unit"
(check-unit 1 'check-unit)) (check-unit 1 'check-unit))
(test (void) (test (void)
@ -27,7 +28,8 @@
'check-helper 'check-helper
#f)) #f))
(test-runtime-error exn:fail:contract? "check-helper: missing signature" (test-runtime-error exn:fail:contract?
"expects a unit with an export for tag t with signature c, which the given unit does not supply"
(check-helper sub-vector (check-helper sub-vector
#((c . #((t . r4) (t . r1) (t . r2) (t . r3)))) #((c . #((t . r4) (t . r1) (t . r2) (t . r3))))
'check-helper 'check-helper
@ -44,12 +46,11 @@
#((a . #((t . r5) (t . r2) (t . r3)))) #((a . #((t . r5) (t . r2) (t . r3))))
'check-helper #f)) 'check-helper #f))
(test-runtime-error exn:fail:contract? "check-helper: ambiguous signature" (test-runtime-error exn:fail:contract?
"expects a unit with an export for tag t with signature c, which the given unit supplies multiple times"
(check-helper sub-vector2 (check-helper sub-vector2
#((c . #((t . r2) (t . r3)))) #((c . #((t . r2) (t . r3))))
'check-helper #f)) 'check-helper #f))
;; check-deps ;; check-deps
;;UNTESTED ;;UNTESTED
(displayln "tests passed")

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

@ -2,7 +2,8 @@
(require "test-harness.rkt" (require "test-harness.rkt"
racket/unit racket/unit
racket/contract) racket/contract
rackunit)
(define temp-unit-blame-re "\\(unit temp[0-9]*\\)") (define temp-unit-blame-re "\\(unit temp[0-9]*\\)")
(define top-level "top-level") (define top-level "top-level")
@ -34,25 +35,13 @@
(define-syntax test-contract-error/regexp (define-syntax test-contract-error/regexp
(syntax-rules () (syntax-rules ()
((_ blame obj err expr) ((_ blame obj err expr)
(with-handlers ((exn:fail:contract? (check-exn (λ (exn)
(lambda (exn) (and (exn:fail:contract? exn)
(let ([msg (exn-message exn)]) (let ([msg (exn-message exn)])
(cond (and (match-blame blame msg)
[(not (match-blame blame msg)) (match-obj obj msg)
(error 'test-contract-error (regexp-match? err msg)))))
"blame \"~a\" not found in:\n\"~a\"" (λ () expr)))))
blame msg)]
[(not (match-obj obj msg))
(error 'test-contract-error
"object \"~a\" not found in:\n\"~a\""
obj msg)]
[else
(printf "got expected contract error \"~a\" on ~a blaming ~a: ok\n\t\"~a\"\n\n"
err obj blame (get-ctc-err msg))])))))
expr
(error 'test-contract-error
"expected contract error \"~a\" on ~a, got none"
err 'expr)))))
(define-signature sig1 (define-signature sig1
((contracted [x number?]))) ((contracted [x number?])))
@ -94,34 +83,39 @@
(define-values (c d) (values "foo" 3))) (define-values (c d) (values "foo" 3)))
(test-syntax-error "misuse of contracted" (test-syntax-error
contracted) "misuse of define-signature keyword"
(test-syntax-error "invalid forms after contracted in signature" contracted)
(test-syntax-error
"expected a list of [id contract]"
(define-signature x ((contracted x y)))) (define-signature x ((contracted x y))))
(test-syntax-error "identifier not first part of pair after contracted in signature" (test-syntax-error
"expected a list of [id contract]"
(define-signature x ((contracted [(-> number? number?) x])))) (define-signature x ((contracted [(-> number? number?) x]))))
(test-syntax-error "identifier h? not bound anywhere" (test-syntax-error
"unbound identifier"
(module h?-test racket (module h?-test racket
(define-signature s^ (define-signature s^
((define-values (f?) (values number?)) ((define-values (f?) (values number?))
(define-syntaxes (g?) (make-rename-transformer #'number?)) (define-syntaxes (g?) (make-rename-transformer #'number?))
(contracted [f (-> f? (and/c g? h?))]))))) (contracted [f (-> f? (and/c g? h?))])))))
(test-syntax-error "f not defined in unit exporting sig3" (test-syntax-error
"undefined export"
(unit (import) (export sig3 sig4) (unit (import) (export sig3 sig4)
(define a #t) (define a #t)
(define g zero?) (define g zero?)
(define (b t) (if t 3 0)))) (define (b t) (if t 3 0))))
(test-contract-error "(unit unit1)" "x" "not a number" (test-contract-error "(unit unit1)" "x" "number?"
(invoke-unit unit1)) (invoke-unit unit1))
(test-contract-error "(unit unit1)" "x" "not a number" (test-contract-error "(unit unit1)" "x" "number?"
(invoke-unit (compound-unit (import) (export) (invoke-unit (compound-unit (import) (export)
(link (((S1 : sig1)) unit1) (link (((S1 : sig1)) unit1)
(() unit2 S1))))) (() unit2 S1)))))
(test-contract-error/regexp temp-unit-blame-re "a" "not a number" (test-contract-error/regexp temp-unit-blame-re "a" "number?"
(invoke-unit (compound-unit (import) (export) (invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4)) (link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4) (unit (import) (export sig3 sig4)
@ -131,7 +125,7 @@
(define (b t) (if t 3 0)))) (define (b t) (if t 3 0))))
(() unit3 S3 S4))))) (() unit3 S3 S4)))))
(test-contract-error/regexp temp-unit-blame-re "g" "not a boolean" (test-contract-error/regexp temp-unit-blame-re "g" "boolean?"
(invoke-unit (compound-unit (import) (export) (invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4)) (link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4) (unit (import) (export sig3 sig4)
@ -141,7 +135,7 @@
(define (b t) (if t 3 0)))) (define (b t) (if t 3 0))))
(() unit3 S3 S4))))) (() unit3 S3 S4)))))
(test-contract-error "(unit unit4)" "b" "not a boolean" (test-contract-error "(unit unit4)" "b" "boolean?"
(invoke-unit (compound-unit (import) (export) (invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4)) (link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4) (unit (import) (export sig3 sig4)
@ -151,7 +145,7 @@
(define (b t) (if t 3 0)))) (define (b t) (if t 3 0))))
(() unit4 S3 S4))))) (() unit4 S3 S4)))))
(test-contract-error "(unit unit5)" "d" "not a symbol" (test-contract-error "(unit unit5)" "d" "symbol?"
(invoke-unit unit5)) (invoke-unit unit5))
(define-unit unit6 (define-unit unit6
@ -181,7 +175,7 @@
(import) (import)
(export sig1))) (export sig1)))
(test-contract-error "(unit unit7)" "x" "not a boolean" (test-contract-error "(unit unit7)" "x" "boolean?"
(invoke-unit unit7)) (invoke-unit unit7))
(define-unit unit8 (define-unit unit8
@ -196,7 +190,7 @@
(export sig2)) (export sig2))
(f #t)) (f #t))
(test-contract-error "(unit unit8)" "f" "not a number" (test-contract-error "(unit unit8)" "f" "number?"
(invoke-unit unit8)) (invoke-unit unit8))
(define-unit unit9 (define-unit unit9
@ -211,7 +205,7 @@
(export sig2)) (export sig2))
(f 3)) (f 3))
(test-contract-error "(unit unit9-1)" "f" "not a number" (test-contract-error "(unit unit9-1)" "f" "number?"
(invoke-unit unit9)) (invoke-unit unit9))
(define-values/invoke-unit (define-values/invoke-unit
@ -221,7 +215,7 @@
(import) (import)
(export sig2)) (export sig2))
(test-contract-error top-level "f" "not a number" (test-contract-error top-level "f" "number?"
(f #t)) (f #t))
(define-unit unit10 (define-unit unit10
@ -233,13 +227,13 @@
(let () (let ()
(define x 0) (define x 0)
(define f (lambda (x) #t)) (define f (lambda (x) #t))
(test-contract-error "(unit u)" "f" "not a number" (test-contract-error "(unit u)" "f" "number?"
(invoke-unit unit10 (import sig1 sig2)))) (invoke-unit unit10 (import sig1 sig2))))
(let () (let ()
(define x 1) (define x 1)
(define f values) (define f values)
(test-contract-error "(unit unit10)" "f" "not a number" (test-contract-error "(unit unit10)" "f" "number?"
(invoke-unit unit10 (import sig1 sig2)))) (invoke-unit unit10 (import sig1 sig2))))
;; testing that contracts from extended signatures are checked properly ;; testing that contracts from extended signatures are checked properly
@ -252,9 +246,9 @@
(define-values/invoke-unit unit11 (define-values/invoke-unit unit11
(import) (import)
(export sig3)) (export sig3))
(test-contract-error "(unit unit11)" "f" "not a number" (test-contract-error "(unit unit11)" "f" "number?"
(f 3)) (f 3))
(test-contract-error top-level "f" "not a number" (test-contract-error top-level "f" "number?"
(f #t))) (f #t)))
;; unit/new-import-export tests ;; unit/new-import-export tests
@ -319,7 +313,7 @@
(export) (export)
(link [((S : sig8)) unit19] (link [((S : sig8)) unit19]
[() unit20 S])) [() unit20 S]))
(test-contract-error "(unit unit19)" "f" "not a number" (test-contract-error "(unit unit19)" "f" "number?"
(invoke-unit unit22))) (invoke-unit unit22)))
;; contracted import -> uncontracted import ;; contracted import -> uncontracted import
@ -340,7 +334,7 @@
(export) (export)
(link [((S : sig7)) unit18] (link [((S : sig7)) unit18]
[() unit23 S])) [() unit23 S]))
(test-contract-error "(unit unit23)" "f" "not a number" (test-contract-error "(unit unit23)" "f" "number?"
(invoke-unit unit25))) (invoke-unit unit25)))
;; contracted import -> contracted import ;; contracted import -> contracted import
@ -369,7 +363,7 @@
(export) (export)
(link [((S : sig9)) unit28-1] (link [((S : sig9)) unit28-1]
[() unit26 S])) [() unit26 S]))
(test-contract-error "(unit unit28-1)" "f" "not a number" (test-contract-error "(unit unit28-1)" "f" "number?"
(invoke-unit unit28-2))) (invoke-unit unit28-2)))
;; uncontracted export -> contracted export ;; uncontracted export -> contracted export
@ -390,7 +384,7 @@
(export) (export)
(link [((S : sig8)) unit29] (link [((S : sig8)) unit29]
[() unit17 S])) [() unit17 S]))
(test-contract-error "(unit unit17)" "f" "not a number" (test-contract-error "(unit unit17)" "f" "number?"
(invoke-unit unit31))) (invoke-unit unit31)))
;; contracted export -> uncontracted export ;; contracted export -> uncontracted export
@ -411,7 +405,7 @@
(export) (export)
(link [((S : sig7)) unit32] (link [((S : sig7)) unit32]
[() unit16 S])) [() unit16 S]))
(test-contract-error "(unit unit32)" "f" "not a number" (test-contract-error "(unit unit32)" "f" "number?"
(invoke-unit unit34))) (invoke-unit unit34)))
;; contracted export -> contracted export ;; contracted export -> contracted export
@ -440,7 +434,7 @@
(export) (export)
(link [((S : sig9)) unit35] (link [((S : sig9)) unit35]
[() unit37-1 S])) [() unit37-1 S]))
(test-contract-error "(unit unit37-1)" "f" "not a number" (test-contract-error "(unit unit37-1)" "f" "number?"
(invoke-unit unit37-2))) (invoke-unit unit37-2)))
;; Converting units with internal contract violations ;; Converting units with internal contract violations
@ -456,7 +450,7 @@
(export) (export)
(link [((S : sig8)) unit15] (link [((S : sig8)) unit15]
[() unit38 S])) [() unit38 S]))
(test-contract-error "(unit unit38)" "f" "not a number" (test-contract-error "(unit unit38)" "f" "number?"
(invoke-unit unit39))) (invoke-unit unit39)))
(let () (let ()
(define-compound-unit unit40 (define-compound-unit unit40
@ -464,7 +458,7 @@
(export) (export)
(link [((S : sig8)) unit19] (link [((S : sig8)) unit19]
[() unit38 S])) [() unit38 S]))
(test-contract-error "(unit unit38)" "f" "not a number" (test-contract-error "(unit unit38)" "f" "number?"
(invoke-unit unit40))) (invoke-unit unit40)))
;; contracted import -> uncontracted import ;; contracted import -> uncontracted import
@ -478,7 +472,7 @@
(export) (export)
(link [((S : sig7)) unit14] (link [((S : sig7)) unit14]
[() unit41 S])) [() unit41 S]))
(test-contract-error "(unit unit17)" "f" "not a number" (test-contract-error "(unit unit17)" "f" "number?"
(invoke-unit unit42))) (invoke-unit unit42)))
(let () (let ()
(define-compound-unit unit43 (define-compound-unit unit43
@ -486,7 +480,7 @@
(export) (export)
(link [((S : sig7)) unit18] (link [((S : sig7)) unit18]
[() unit41 S])) [() unit41 S]))
(test-contract-error "(unit unit17)" "f" "not a number" (test-contract-error "(unit unit17)" "f" "number?"
(invoke-unit unit43))) (invoke-unit unit43)))
;; contracted import -> contracted import ;; contracted import -> contracted import
@ -504,7 +498,7 @@
(export) (export)
(link [((S : sig9)) unit45-1] (link [((S : sig9)) unit45-1]
[() unit44 S])) [() unit44 S]))
(test-contract-error "(unit unit17)" "f" "not a number" (test-contract-error "(unit unit17)" "f" "number?"
(invoke-unit unit45-2))) (invoke-unit unit45-2)))
(let () (let ()
(define-unit unit46-1 (define-unit unit46-1
@ -516,7 +510,7 @@
(export) (export)
(link [((S : sig9)) unit46-1] (link [((S : sig9)) unit46-1]
[() unit44 S])) [() unit44 S]))
(test-contract-error "(unit unit17)" "f" "not a number" (test-contract-error "(unit unit17)" "f" "number?"
(invoke-unit unit46-2))) (invoke-unit unit46-2)))
;; uncontracted export -> contracted export ;; uncontracted export -> contracted export
@ -530,7 +524,7 @@
(export) (export)
(link [((S : sig8)) unit47] (link [((S : sig8)) unit47]
[() unit13 S])) [() unit13 S]))
(test-contract-error "(unit unit47)" "f" "not a number" (test-contract-error "(unit unit47)" "f" "number?"
(invoke-unit unit48))) (invoke-unit unit48)))
(let () (let ()
(define-compound-unit unit49 (define-compound-unit unit49
@ -538,7 +532,7 @@
(export) (export)
(link [((S : sig8)) unit47] (link [((S : sig8)) unit47]
[() unit17 S])) [() unit17 S]))
(test-contract-error "(unit unit17)" "f" "not a number" (test-contract-error "(unit unit17)" "f" "number?"
(invoke-unit unit49))) (invoke-unit unit49)))
;; contracted import -> uncontracted import ;; contracted import -> uncontracted import
@ -552,7 +546,7 @@
(export) (export)
(link [((S : sig7)) unit50] (link [((S : sig7)) unit50]
[() unit12 S])) [() unit12 S]))
(test-contract-error "(unit unit19)" "f" "not a number" (test-contract-error "(unit unit19)" "f" "number?"
(invoke-unit unit51))) (invoke-unit unit51)))
(let () (let ()
(define-compound-unit unit52 (define-compound-unit unit52
@ -560,7 +554,7 @@
(export) (export)
(link [((S : sig7)) unit50] (link [((S : sig7)) unit50]
[() unit16 S])) [() unit16 S]))
(test-contract-error "(unit unit50)" "f" "not a number" (test-contract-error "(unit unit50)" "f" "number?"
(invoke-unit unit52))) (invoke-unit unit52)))
;; contracted export -> contracted export ;; contracted export -> contracted export
@ -578,7 +572,7 @@
(export) (export)
(link [((S : sig9)) unit53] (link [((S : sig9)) unit53]
[() unit54-1 S])) [() unit54-1 S]))
(test-contract-error "(unit unit19)" "f" "not a number" (test-contract-error "(unit unit19)" "f" "number?"
(invoke-unit unit54-2))) (invoke-unit unit54-2)))
(let () (let ()
(define-unit unit55-1 (define-unit unit55-1
@ -590,7 +584,7 @@
(export) (export)
(link [((S : sig9)) unit53] (link [((S : sig9)) unit53]
[() unit55-1 S])) [() unit55-1 S]))
(test-contract-error "(unit unit55-1)" "f" "not a number" (test-contract-error "(unit unit55-1)" "f" "number?"
(invoke-unit unit55-2))) (invoke-unit unit55-2)))
(module m1 racket (module m1 racket
@ -628,26 +622,29 @@
(require (prefix-in m2: 'm2)) (require (prefix-in m2: 'm2))
(m2:z) (m2:z)
(test-contract-error "m2" "U@" "not a symbol" (m2:w)) (test-contract-error "m2" "U@" "symbol?" (m2:w))
(test-contract-error "m1" "U@" "not a string" (m2:v)) (test-contract-error "m1" "U@" "string?" (m2:v))
(test-syntax-error "no y in sig1" (test-syntax-error
"identifier not member of signature"
(unit/c (import (sig1 [y number?])) (unit/c (import (sig1 [y number?]))
(export))) (export)))
(test-syntax-error "two xs for sig1" (test-syntax-error
"duplicate identifier found"
(unit/c (import) (unit/c (import)
(export (sig1 [x string?] [x number?])))) (export (sig1 [x string?] [x number?]))))
(test-syntax-error "no sig called faux^, so import description matching fails" (test-syntax-error
"unit/c: unknown signature"
(unit/c (import faux^) (export))) (unit/c (import faux^) (export)))
(test-contract-error "(definition bad-export@)" "bad-export@" "unit must export sig1" (test-contract-error "(definition bad-export@)" "bad-export@" "unit must export signature sig1"
(let () (let ()
(define/contract bad-export@ (define/contract bad-export@
(unit/c (import) (export sig1)) (unit/c (import) (export sig1))
(unit (import) (export))) (unit (import) (export)))
bad-export@)) bad-export@))
(test-contract-error "(definition bad-import@)" "bad-import@" "contract must import sig1" (test-contract-error "(definition bad-import@)" "bad-import@" "contract does not list import sig1"
(let () (let ()
(define/contract bad-import@ (define/contract bad-import@
(unit/c (import) (export)) (unit/c (import) (export))
@ -702,7 +699,7 @@
(require (prefix-in m4: 'm4)) (require (prefix-in m4: 'm4))
(test-contract-error "m4" "f" "not an x" (test-contract-error "m4" "f" " x?"
(m4:f 3)) (m4:f 3))
(module m4:f racket (module m4:f racket
@ -720,12 +717,12 @@
(require (prefix-in m4: 'm4:f)) (require (prefix-in m4: 'm4:f))
(test-contract-error "m4:f" "f:f" "not an f:x" (test-contract-error "m4:f" "f:f" "x?"
(m4:f:f 3)) (m4:f:f 3))
(require (prefix-in m3: 'm3)) (require (prefix-in m3: 'm3))
(test-contract-error top-level "build-toys" "not a integer" (test-contract-error top-level "build-toys" "integer?"
(let () (let ()
(define-values/invoke-unit/infer m3:simple-factory@) (define-values/invoke-unit/infer m3:simple-factory@)
(build-toys #f))) (build-toys #f)))
@ -753,7 +750,7 @@
(m5:f 0) (m5:f 0)
(test-contract-error top-level "U@" "not an x" (test-contract-error top-level "U@" " x?"
(m5:f 3)) (m5:f 3))
(let () (let ()
@ -774,7 +771,7 @@
(define-values/invoke-unit/infer V@) (define-values/invoke-unit/infer V@)
(f 0) (f 0)
(test-contract-error top-level "f" "not an x" (test-contract-error top-level "f" "zero?"
(f 3))) (f 3)))
(let () (let ()
@ -795,7 +792,7 @@
(define-values/invoke-unit/infer V@) (define-values/invoke-unit/infer V@)
(f 0) (f 0)
(test-contract-error "(unit V@)" "f" "not an x" (test-contract-error "(unit V@)" "f" "zero?"
(f 3))) (f 3)))
(let () (let ()
@ -813,11 +810,11 @@
(import) (export) (link U@ V@)) (import) (export) (link U@ V@))
(define-values/invoke-unit/infer U@) (define-values/invoke-unit/infer U@)
y y
(test-contract-error top-level "U@" "not a number" (test-contract-error top-level "U@" "number?"
(x #t)) (x #t))
(test-contract-error "(unit U@)" "U@" "not a number" (test-contract-error "(unit U@)" "U@" "number?"
(x 3)) (x 3))
(test-contract-error "(unit U@)" "U@" "not a number" (test-contract-error "(unit U@)" "U@" "number?"
(invoke-unit W@))) (invoke-unit W@)))
(let () (let ()
@ -831,16 +828,16 @@
(define-unit V@ (define-unit V@
(import foo^) (import foo^)
(export) (export)
(test-contract-error top-level "U@" "not an x" (test-contract-error top-level "U@" " x?"
(f 2)) (f 2))
(test-contract-error "(unit U@)" "U@" "not an number" (test-contract-error "(unit U@)" "U@" " number?"
(f 3))) (f 3)))
(define-compound-unit/infer W@ (define-compound-unit/infer W@
(import) (export) (link U@ V@)) (import) (export) (link U@ V@))
(define-values/invoke-unit/infer U@) (define-values/invoke-unit/infer U@)
(test-contract-error top-level "U@" "not an x" (test-contract-error top-level "U@" " x?"
(f 4)) (f 4))
(test-contract-error "(unit U@)" "U@" "not a number" (test-contract-error "(unit U@)" "U@" "number?"
(f 3)) (f 3))
(invoke-unit W@)) (invoke-unit W@))
@ -860,7 +857,7 @@
(define-values/invoke-unit/infer foo@) (define-values/invoke-unit/infer foo@)
(f 0) (f 0)
(test-contract-error top-level "f" "not an x" (test-contract-error top-level "f" " x?"
(f 4)) (f 4))
;; This is a weird one. The definition for foo@ has two conflicting ;; This is a weird one. The definition for foo@ has two conflicting
;; contracts. Who gets blamed? Still the top-level, since foo@ can't ;; contracts. Who gets blamed? Still the top-level, since foo@ can't
@ -869,7 +866,7 @@
;; just be an "overriding" contract, but a) that won't really work and ;; just be an "overriding" contract, but a) that won't really work and
;; b) what about other units that might link with foo@, that expect ;; b) what about other units that might link with foo@, that expect
;; the stronger contract? ;; the stronger contract?
(test-contract-error top-level "x?" "not a number" (test-contract-error top-level "x?" "number?"
(f #t))) (f #t)))
(let () (let ()
@ -881,9 +878,9 @@
(struct student (name id))) (struct student (name id)))
(define-values/invoke-unit/infer student@) (define-values/invoke-unit/infer student@)
(student "foo" 3) (student "foo" 3)
(test-contract-error top-level "student" "not a string" (test-contract-error top-level "student" "string?"
(student 4 3)) (student 4 3))
(test-contract-error top-level "student-id" "not a student" (test-contract-error top-level "student-id" "student?"
(student-id 'a))) (student-id 'a)))
;; Test that prefixing doesn't cause issues. ;; Test that prefixing doesn't cause issues.
@ -911,4 +908,164 @@
(define-values/invoke-unit c@ (import) (export s^)) (define-values/invoke-unit c@ (import) (export s^))
(new-make-t)) (new-make-t))
(displayln "tests passed")
(let ()
(define-signature s^ ((contracted [n number?])))
(define-unit s0@
(import)
(export s^)
(define n 0))
(define-unit s1@
(import)
(export s^)
(define n 1))
(define-unit/contract a0@
(import)
(export)
#:invoke/contract (-> integer? integer?)
(lambda (n) (add1 n)))
(define-unit/contract a1@
(import)
(export)
(init-depend)
#:invoke/contract (-> integer? integer?)
(lambda (n) "bad"))
((invoke-unit a0@) 1)
(test-contract-error "(unit a1@)" "a1@" " integer?" ((invoke-unit a1@) 1))
(define-unit t@
(import s^)
(export)
(if (zero? n) "zero" n))
(define c@/c (unit/c (import) (export) number?))
(define/contract c0@ c@/c
(compound-unit (import) (export) (link [((S : s^)) s0@] [() t@ S])))
(define/contract c1@ c@/c
(compound-unit (import) (export) (link [((S : s^)) s1@] [() t@ S])))
(test-contract-error "(definition c0@)" "c0@" "number?" (invoke-unit c0@))
(invoke-unit c1@))
;; tests for values case of unit/c contracts
(let ()
;; first order
(define c1 (unit/c (import) (export) (values integer?)))
(define c2 (unit/c (import) (export) (values integer? string?)))
(define/contract u1 c1 (unit (import) (export) 5))
(define/contract u2 c1 (unit (import) (export) "bad"))
(define/contract u3 c1 (unit (import) (export) (values 1 2)))
(define/contract u4 c2 (unit (import) (export) (values 1 "two")))
(define/contract u5 c2 (unit (import) (export) (values 1 2)))
(define/contract u6 c2 (unit (import) (export) "bad"))
;; passing
(invoke-unit u1)
(invoke-unit u4)
;; failing
(test-contract-error "(definition u2)" "u2" "promised: integer?" (invoke-unit u2))
(test-contract-error "(definition u5)" "u5" "promised: string?" (invoke-unit u5))
;; wrong number of values
(test-contract-error "(definition u3)" "u3" "expected 1 values" (invoke-unit u3))
(test-contract-error "(definition u6)" "u6" "expected 2 values" (invoke-unit u6))
;; higher order
(define c3 (unit/c (import) (export) (values (-> integer? string?))))
(define c4 (unit/c (import) (export) (values (-> integer? integer?) (-> string? string?))))
(define/contract u7 c3 (unit (import) (export) (λ (n) "ok")))
(define/contract u8 c3 (unit (import) (export) (λ (n) 'bad)))
(define/contract u9 c4 (unit (import) (export) (values (λ (n) n) (λ (s) s))))
(define/contract u10 c4 (unit (import) (export) (values (λ (n) "bad") (λ (s) 'bad))))
(define-values (f1) (invoke-unit u7))
(define-values (f2) (invoke-unit u8))
(define-values (f3 f4) (invoke-unit u9))
(define-values (f5 f6) (invoke-unit u10))
;; ok
(f1 1)
(f3 3)
(f4 "ok")
;; errors
(test-contract-error "top-level" "u7" "expected: integer?" (f1 "bad"))
(test-contract-error "top-level" "u8" "expected: integer?" (f2 "bad"))
(test-contract-error "(definition u8)" "u8" "promised: string?" (f2 5))
(test-contract-error "top-level" "u9" "expected: integer?" (f3 "bad"))
(test-contract-error "top-level" "u9" "expected: string?" (f4 5))
(test-contract-error "top-level" "u10" "expected: integer?" (f5 "bad"))
(test-contract-error "(definition u10)" "u10" "promised: integer?" (f5 5))
(test-contract-error "(definition u10)" "u10" "promised: string?" (f6 "bad"))
(test-contract-error "top-level" "u10" "expected: string?" (f6 6)))
;; tests for init-depends in unit contracts
(let ()
(define-signature a^ ())
(define-signature b^ ())
(define-signature c^ ())
(define/contract u@
(unit/c (import a^ b^) (export) (init-depend a^ b^))
(unit (import a^ b^) (export) (init-depend a^ b^)))
(define/contract v@
(unit/c (import a^ b^) (export) (init-depend a^ b^))
(unit (import a^) (export) (init-depend a^)))
(test-contract-error
"(definition w@)" "w@" "contract does not list initialization dependency a^"
(let ()
(define/contract w@
(unit/c (import a^) (export))
(unit (import a^) (export) (init-depend a^)))
w@))
;; make sure that extended dependencies are checked correctly
(define-signature a-sub^ extends a^ ())
(define/contract x@
(unit/c (import a-sub^) (export) (init-depend a-sub^))
(unit (import a^) (export) (init-depend a^)))
;; make sure tags are checked correctly for init-depends
(test-contract-error
"(definition y@)" "y@" "contract does not list initialization dependency a^ with tag A"
(let ()
(define/contract y@
(unit/c (import (tag A a^) a^) (export) (init-depend a^))
(unit (import (tag A a^) a^) (export) (init-depend (tag A a^))))
y@))
(test-syntax-error
"unit/c: initialization dependency on unknown import"
(let ()
(define-signature a^ ())
(define-signature a-sub^ extends a^ ())
(unit/c (import a^) (export) (init-depend a-sub^))))
(test-syntax-error
"unit/c: initialization dependency on unknown import"
(let ()
(define-signature a^ ())
(unit/c (import) (export) (init-depend a^))))
(test-syntax-error
"unit/c: unknown signature"
(unit/c (import x^) (export) (init-depend)))
(test-syntax-error
"unit/c: unknown signature"
(unit/c (import) (export) (init-depend x^)))
(test-syntax-error
"unit/c: unknown signature"
(unit/c (import) (export x^) (init-depend)))
(void))

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

File diff suppressed because it is too large Load Diff

80
racket/collects/racket/private/unit-contract-syntax.rkt
View File

@ -3,22 +3,16 @@
(require syntax/parse (require syntax/parse
"unit-compiletime.rkt" "unit-compiletime.rkt"
"unit-keywords.rkt" "unit-keywords.rkt"
(for-template "unit-keywords.rkt")) racket/contract
(for-template "unit-keywords.rkt" racket/base racket/contract))
(provide import-clause/contract export-clause/contract dep-clause (provide import-clause/contract export-clause/contract body-clause/contract dep-clause
import-clause/c export-clause/c) import-clause/c export-clause/c body-clause/c)
(define-syntax-class sig-id
#:attributes ()
(pattern x
#:declare x (static (λ (x)
(signature? (set!-trans-extract x)))
'signature)))
(define-syntax-class sig-spec #:literals (prefix rename only except) (define-syntax-class sig-spec #:literals (prefix rename only except)
#:attributes ((name 0)) #:attributes ((name 0))
#:transparent #:transparent
(pattern name:sig-id) (pattern name:identifier)
(pattern (prefix i:identifier s:sig-spec) (pattern (prefix i:identifier s:sig-spec)
#:with name #'s.name) #:with name #'s.name)
(pattern (rename s:sig-spec [int:identifier ext:identifier] ...) (pattern (rename s:sig-spec [int:identifier ext:identifier] ...)
@ -38,8 +32,8 @@
(define-syntax-class tagged-sig-id #:literals (tag) (define-syntax-class tagged-sig-id #:literals (tag)
#:attributes () #:attributes ()
#:transparent #:transparent
(pattern s:sig-id) (pattern s:identifier)
(pattern (tag i:identifier s:sig-id))) (pattern (tag i:identifier s)))
(define-syntax-class unit/c-clause (define-syntax-class unit/c-clause
#:auto-nested-attributes #:auto-nested-attributes
@ -57,6 +51,62 @@
#:transparent #:transparent
(pattern (export e:unit/c-clause ...))) (pattern (export e:unit/c-clause ...)))
;; Helper to reduce the size of unit contract expansion
;; This has to be defined in a module in order for
;; `unit/c-check-invoke-values` to be defined at the
;; correct phase during expansion when the body-clause/c
;; syntax class is parsed
(module unit-check-values racket/base
(provide unit/c-check-invoke-values)
(require racket/contract/base
racket/contract/combinator)
(define ((unit/c-check-invoke-values len blame ctcs) . args)
(define args-len (length args))
(unless (= len args-len)
(raise-blame-error (blame-add-context blame "the body of")
(blame-value blame)
(format "expected ~a values, returned ~a" len args-len)))
(apply values
(map
(lambda (ctc arg) (ctc arg))
ctcs args))))
(require (for-template 'unit-check-values))
(define-splicing-syntax-class body-clause/c
#:literals (values)
#:auto-nested-attributes
#:transparent
(pattern (~seq)
#:attr name #'()
#:attr make-define-ctcs/blame
(lambda (name blame) #'())
#:attr apply-invoke-ctcs
(lambda (id blame ctcs) id))
(pattern (values ctc:expr ...)
#:attr name #'('(values ctc ...))
#:attr make-define-ctcs/blame
(lambda (name blame)
#`((define #,name
(map (lambda (c) ((contract-projection c)
(blame-add-context #,blame "the body of")))
(list ctc ...)))))
#:attr apply-invoke-ctcs
;; blame here is really syntax representing a blame object
(lambda (id blame ctcs)
(define len (length (syntax->list #'(ctc ...))))
#`(call-with-values
(lambda () #,id)
(unit/c-check-invoke-values #,len #,blame #,ctcs))))
(pattern b:expr
#:attr name #'('b)
#:attr make-define-ctcs/blame
(lambda (name blame)
#`((define #,name ((contract-projection b)
(blame-add-context #,blame "the body of")))))
#:attr apply-invoke-ctcs
(lambda (id blame ctcs)
#`(#,ctcs #,id))))
(define-syntax-class unit/contract-clause (define-syntax-class unit/contract-clause
#:auto-nested-attributes #:auto-nested-attributes
#:transparent #:transparent
@ -76,3 +126,7 @@
#:auto-nested-attributes #:auto-nested-attributes
#:transparent #:transparent
(pattern (init-depend s:tagged-sig-id ...))) (pattern (init-depend s:tagged-sig-id ...)))
(define-splicing-syntax-class body-clause/contract
#:auto-nested-attributes
#:transparent
(pattern (~seq #:invoke/contract b:expr)))

115
racket/collects/racket/private/unit-contract.rkt
View File

@ -4,6 +4,7 @@
syntax/boundmap syntax/boundmap
syntax/name syntax/name
syntax/parse syntax/parse
(only-in racket/syntax generate-temporary)
"unit-compiletime.rkt" "unit-compiletime.rkt"
"unit-contract-syntax.rkt" "unit-contract-syntax.rkt"
"unit-syntax.rkt") "unit-syntax.rkt")
@ -68,10 +69,18 @@
(define-for-syntax contract-imports (contract-imports/exports #t)) (define-for-syntax contract-imports (contract-imports/exports #t))
(define-for-syntax contract-exports (contract-imports/exports #f)) (define-for-syntax contract-exports (contract-imports/exports #f))
;; This is copied from the unit implementation, but can't be required
;; from there since unit.rkt also requires this file
(define-for-syntax (tagged-sigid->tagged-siginfo x)
(cons (car x)
(signature-siginfo (lookup-signature (cdr x)))))
(define-for-syntax (unit/c/core name stx) (define-for-syntax (unit/c/core name stx)
(syntax-parse stx (syntax-parse stx
[(:import-clause/c :export-clause/c) [(:import-clause/c
:export-clause/c
(~optional d:dep-clause #:defaults ([(d.s 1) null]))
b:body-clause/c)
(begin (begin
(define-values (isig tagged-import-sigs import-tagged-infos (define-values (isig tagged-import-sigs import-tagged-infos
import-tagged-sigids import-sigs) import-tagged-sigids import-sigs)
@ -80,7 +89,15 @@
(define-values (esig tagged-export-sigs export-tagged-infos (define-values (esig tagged-export-sigs export-tagged-infos
export-tagged-sigids export-sigs) export-tagged-sigids export-sigs)
(process-unit-export #'(e.s ...))) (process-unit-export #'(e.s ...)))
(define deps (syntax->list #'(d.s ...)))
(define dep-tagged-siginfos
(map tagged-sigid->tagged-siginfo
(map check-tagged-id deps)))
(define apply-body-contract (attribute b.apply-invoke-ctcs))
(define make-define-ctcs/blame (attribute b.make-define-ctcs/blame))
(define contract-table (define contract-table
(make-bound-identifier-mapping)) (make-bound-identifier-mapping))
@ -102,12 +119,9 @@
[c (in-list (syntax->list cs))]) [c (in-list (syntax->list cs))])
(bound-identifier-mapping-put! contract-table x c))) (bound-identifier-mapping-put! contract-table x c)))
(check-duplicate-sigs import-tagged-infos isig null null) (check-duplicate-sigs import-tagged-infos isig dep-tagged-siginfos deps)
(check-duplicate-subs export-tagged-infos esig) (check-duplicate-subs export-tagged-infos esig)
(check-unit-ie-sigs import-sigs export-sigs)
(for-each process-sig (for-each process-sig
isig isig
import-sigs import-sigs
@ -119,7 +133,13 @@
(syntax->list #'((e.x ...) ...)) (syntax->list #'((e.x ...) ...))
(syntax->list #'((e.c ...) ...))) (syntax->list #'((e.c ...) ...)))
(with-syntax ([(isig ...) isig] (with-syntax ([((dept . depr) ...)
(map
(lambda (tinfo)
(cons (car tinfo)
(syntax-local-introduce (car (siginfo-rtime-ids (cdr tinfo))))))
dep-tagged-siginfos)]
[(isig ...) isig]
[(esig ...) esig] [(esig ...) esig]
[((import-key ...) ...) [((import-key ...) ...)
(map tagged-info->keys import-tagged-infos)] (map tagged-info->keys import-tagged-infos)]
@ -130,7 +150,8 @@
import-tagged-infos)] import-tagged-infos)]
[(export-name ...) [(export-name ...)
(map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) (map (lambda (tag/info) (car (siginfo-names (cdr tag/info))))
export-tagged-infos)]) export-tagged-infos)]
[ctcs/blame (generate-temporary 'ctcs/blame)])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(make-contract (make-contract
@ -145,9 +166,13 @@
(list (cons 'esig (list (cons 'esig
(map list (list 'e.x ...) (map list (list 'e.x ...)
(build-compound-type-name 'e.c ...))) (build-compound-type-name 'e.c ...)))
...))) ...))
(cons 'init-depend
(list 'd.s ...))
#,@(attribute b.name))
#:projection #:projection
(λ (blame) (λ (blame)
#,@(make-define-ctcs/blame #'ctcs/blame #'blame)
(λ (unit-tmp) (λ (unit-tmp)
(unit/c-first-order-check (unit/c-first-order-check
unit-tmp unit-tmp
@ -157,6 +182,7 @@
(vector-immutable (vector-immutable
(cons 'export-name (cons 'export-name
(vector-immutable export-key ...)) ...) (vector-immutable export-key ...)) ...)
(list (cons 'dept depr) ...)
blame) blame)
(make-unit (make-unit
'#,name '#,name
@ -164,16 +190,19 @@
(vector-immutable import-key ...)) ...) (vector-immutable import-key ...)) ...)
(vector-immutable (cons 'export-name (vector-immutable (cons 'export-name
(vector-immutable export-key ...)) ...) (vector-immutable export-key ...)) ...)
(unit-deps unit-tmp) (list (cons 'dept depr) ...)
(λ () (λ ()
(let-values ([(unit-fn export-table) ((unit-go unit-tmp))]) (let-values ([(unit-fn export-table) ((unit-go unit-tmp))])
(values (lambda (import-table) (values (lambda (import-table)
(unit-fn #,(contract-imports #,(apply-body-contract
#'import-table #`(unit-fn #,(contract-imports
import-tagged-infos #'import-table
import-sigs import-tagged-infos
contract-table import-sigs
#'blame))) contract-table
#'blame))
#'blame
#'ctcs/blame))
#,(contract-exports #,(contract-exports
#'export-table #'export-table
export-tagged-infos export-tagged-infos
@ -190,6 +219,7 @@
(vector-immutable (vector-immutable
(cons 'export-name (cons 'export-name
(vector-immutable export-key ...)) ...) (vector-immutable export-key ...)) ...)
(list (cons 'dept depr) ...)
#f)))))))])) #f)))))))]))
(define-syntax/err-param (unit/c stx) (define-syntax/err-param (unit/c stx)
@ -198,7 +228,7 @@
(let ([name (syntax-local-infer-name stx)]) (let ([name (syntax-local-infer-name stx)])
(unit/c/core name #'sstx))])) (unit/c/core name #'sstx))]))
(define (unit/c-first-order-check val expected-imports expected-exports blame) (define (unit/c-first-order-check val expected-imports expected-exports expected-deps blame)
(let/ec return (let/ec return
(define (failed str . args) (define (failed str . args)
(if blame (if blame
@ -224,12 +254,57 @@
[r (hash-ref t v0 #f)]) [r (hash-ref t v0 #f)])
(when (not r) (when (not r)
(let ([sub-name (car (vector-ref super-sig i))]) (let ([sub-name (car (vector-ref super-sig i))])
(if import? (define tag-part (vector-ref (cdr (vector-ref super-sig i)) 0))
(failed "contract does not list import ~a" sub-name) (define tag (and (pair? tag-part) (car tag-part)))
(failed "unit must export signature ~a" sub-name))))) (failed
(string-append
(if import?
(format "contract does not list import ~a" sub-name)
(format "unit must export signature ~a" sub-name))
(if tag
(format " with tag ~a" tag)
""))))))
(loop (sub1 i))))) (loop (sub1 i)))))
;; check that the dependencies of the given unit are consistent with the
;; dependencies specified by the contract. Ensures that the given dependencies
;; are a subset of the expected dependencies otherwise raises a contract error.
(define (check-dependencies expected given imports)
(define (lookup dep lst)
(member dep lst (lambda (p1 p2)
(and (eq? (car p1) (car p2))
(eq? (cdr p1) (cdr p2))))))
;; Normalize dependencies to be symbols or pairs of tags and symbols
(define (normalize-deps deps)
(map (lambda (dep) (if (car dep) dep (cdr dep))) deps))
(define t (for*/hash ([i (in-vector imports)]
[v (in-value (cdr i))]
[im (in-value (vector-ref v 0))]
#:when (member im (normalize-deps expected))
[vj (in-vector v)])
(values vj #t)))
;; use the imports to get the name and tag of dependency
(define (get-name dep-tag)
(define tag-table
(for/hash ([e (in-vector imports)])
(define name (car e))
(define v (vector-ref (cdr e) 0))
(define tag (if (pair? v) (cdr v) v))
(values tag name)))
(hash-ref tag-table dep-tag #f))
(for ([dep (in-list (normalize-deps given))])
(unless (hash-ref t dep #f)
(define tag (and (pair? dep) (car dep)))
(define sig-tag (or (and (pair? dep) (cdr dep)) dep))
(failed
(string-append
(format "contract does not list initialization dependency ~a"
(get-name sig-tag))
(if tag
(format " with tag ~a" tag)
""))))))
(unless (unit? val) (unless (unit? val)
(failed "not a unit")) (failed "not a unit"))
(check-sig-subset expected-imports (unit-import-sigs val) #t) (check-sig-subset expected-imports (unit-import-sigs val) #t)
(check-sig-subset (unit-export-sigs val) expected-exports #f) (check-sig-subset (unit-export-sigs val) expected-exports #f)
(check-dependencies expected-deps (unit-deps val) expected-imports)
#t)) #t))

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

@ -1933,14 +1933,18 @@
(build-unit-from-context sig)) (build-unit-from-context sig))
"missing unit name and signature")) "missing unit name and signature"))
;; A marker used when the result of invoking a unit should not be contracted
(define-for-syntax no-invoke-contract (gensym))
(define-for-syntax (build-unit/contract stx) (define-for-syntax (build-unit/contract stx)
(syntax-parse stx (syntax-parse stx
[(:import-clause/contract :export-clause/contract dep:dep-clause . body) [(:import-clause/contract :export-clause/contract dep:dep-clause :body-clause/contract . bexps)
(define splicing-body-contract
(if (eq? (syntax-e #'b) no-invoke-contract) #'() #'(b)))
(let-values ([(exp isigs esigs deps) (let-values ([(exp isigs esigs deps)
(build-unit (build-unit
(check-unit-syntax (check-unit-syntax
(syntax/loc stx (syntax/loc stx
((import i.s ...) (export e.s ...) dep . body))))]) ((import i.s ...) (export e.s ...) dep . bexps))))])
(with-syntax ([name (syntax-local-infer-name (error-syntax))] (with-syntax ([name (syntax-local-infer-name (error-syntax))]
[(import-tagged-sig-id ...) [(import-tagged-sig-id ...)
(map (λ (i s) (map (λ (i s)
@ -1956,17 +1960,27 @@
[unit-contract [unit-contract
(unit/c/core (unit/c/core
#'name #'name
(syntax/loc stx (quasisyntax/loc stx
((import (import-tagged-sig-id [i.x i.c] ...) ...) ((import (import-tagged-sig-id [i.x i.c] ...) ...)
(export (export-tagged-sig-id [e.x e.c] ...) ...))))]) (export (export-tagged-sig-id [e.x e.c] ...) ...)
dep
#,@splicing-body-contract)))])
(values (values
(syntax/loc stx (syntax/loc stx
(contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name))) (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name)))
isigs esigs deps))))] isigs esigs deps))))]
[(ic:import-clause/contract ec:export-clause/contract . body) [(ic:import-clause/contract ec:export-clause/contract dep:dep-clause . bexps)
(build-unit/contract (build-unit/contract
(syntax/loc stx (quasisyntax/loc stx
(ic ec (init-depend) . body)))])) (ic ec dep #:invoke/contract #,no-invoke-contract . bexps)))]
[(ic:import-clause/contract ec:export-clause/contract bc:body-clause/contract . bexps)
(build-unit/contract
(quasisyntax/loc stx
(ic ec (init-depend) #,@(syntax->list #'bc) . bexps)))]
[(ic:import-clause/contract ec:export-clause/contract . bexps)
(build-unit/contract
(quasisyntax/loc stx
(ic ec (init-depend) #:invoke/contract #,no-invoke-contract . bexps)))]))
(define-syntax/err-param (define-unit/contract stx) (define-syntax/err-param (define-unit/contract stx)
(build-define-unit/contracted stx (λ (stx) (build-define-unit/contracted stx (λ (stx)