Improvements to unit/c contracts in preparation for unit support in typed/racket
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
Vincent St-Amour
parent
1d99ced2ea
commit
b16f0b24b7
|
|
@ -700,10 +700,21 @@ Expands to a @racket[provide] of all identifiers implied by the
|
|||
|
||||
@section[#:tag "unitcontracts"]{Unit Contracts}
|
||||
|
||||
@defform/subs[#:literals (import export)
|
||||
(unit/c (import sig-block ...) (export sig-block ...))
|
||||
@defform/subs[#:literals (import export values init-depend)
|
||||
(unit/c
|
||||
(import sig-block ...)
|
||||
(export sig-block ...)
|
||||
init-depends-decl
|
||||
optional-body-ctc)
|
||||
([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
|
||||
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.
|
||||
|
||||
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
|
||||
identifier which is not listed for a given signature is left alone.
|
||||
Variables used in a given @racket[contract] expression first refer to other
|
||||
variables in the same signature, and then to the context of the
|
||||
@racket[unit/c] expression.}
|
||||
superset of the export signatures listed in the unit contract. Additionally,
|
||||
the unit value must declare initialization dependencies that are a subset of
|
||||
those specified in the unit contract. Any identifier which is not listed
|
||||
for a given signature is left alone. Variables used in a given
|
||||
@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
|
||||
(import sig-spec-block ...)
|
||||
(export sig-spec-block ...)
|
||||
init-depends-decl
|
||||
optional-body-ctc
|
||||
unit-body-expr-or-defn
|
||||
...)
|
||||
([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
|
||||
link inference whose imports and exports are contracted with a unit
|
||||
contract. The unit name is used for the positive blame of the contract.}
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(module test-harness racket
|
||||
(require syntax/stx)
|
||||
(require syntax/stx rackunit)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
|
@ -35,28 +35,24 @@
|
|||
(define-syntax test-syntax-error
|
||||
(syntax-rules ()
|
||||
((_ err expr)
|
||||
(with-handlers ((exn:fail:syntax? (lambda (exn)
|
||||
(printf "get expected syntax error \"~a\"\n got message \"~a\"\n\n"
|
||||
err
|
||||
(exn-message exn)))))
|
||||
(expand #'expr)
|
||||
(error 'test-syntax-error "expected syntax error \"~a\" on ~a, got none" err 'expr)))))
|
||||
(check-exn
|
||||
(lambda (e) (and (exn:fail:syntax? e)
|
||||
(regexp-match? (regexp-quote err)
|
||||
(exn-message e))))
|
||||
(lambda () (expand #'expr))))))
|
||||
|
||||
(define-syntax test-runtime-error
|
||||
(syntax-rules ()
|
||||
((_ err-pred err expr)
|
||||
(with-handlers ((err-pred (lambda (exn)
|
||||
(printf "got expected runtime error \"~a\"\n got message \"~a\"\n\n"
|
||||
err
|
||||
(exn-message exn)))))
|
||||
expr
|
||||
(error 'test-runtime-error "expected runtime error \"~a\" on ~a, got none" err 'expr)))))
|
||||
(check-exn
|
||||
(λ (exn) (and (err-pred exn)
|
||||
(let ([msg (exn-message exn)])
|
||||
(and (regexp-match? (regexp-quote err) msg)))))
|
||||
(λ () expr (void))))))
|
||||
|
||||
(define-syntax test
|
||||
(syntax-rules ()
|
||||
((_ expected-value expr)
|
||||
(test equal? expected-value expr))
|
||||
(check-equal? expected-value expr))
|
||||
((_ cmp expected-value expr)
|
||||
(let ((v expr))
|
||||
(unless (cmp expected-value v)
|
||||
(error 'test "expected ~a to evaluate to ~a, got ~a" 'expr 'expected-value v)))))))
|
||||
(check cmp expected-value expr)))))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@
|
|||
racket/private/unit-runtime)
|
||||
|
||||
;; 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))
|
||||
|
||||
(test (void)
|
||||
|
|
@ -27,7 +28,8 @@
|
|||
'check-helper
|
||||
#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
|
||||
#((c . #((t . r4) (t . r1) (t . r2) (t . r3))))
|
||||
'check-helper
|
||||
|
|
@ -44,12 +46,11 @@
|
|||
#((a . #((t . r5) (t . r2) (t . r3))))
|
||||
'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
|
||||
#((c . #((t . r2) (t . r3))))
|
||||
'check-helper #f))
|
||||
|
||||
;; check-deps
|
||||
;;UNTESTED
|
||||
|
||||
(displayln "tests passed")
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
|
||||
(require "test-harness.rkt"
|
||||
racket/unit
|
||||
racket/contract)
|
||||
racket/contract
|
||||
rackunit)
|
||||
|
||||
(define temp-unit-blame-re "\\(unit temp[0-9]*\\)")
|
||||
(define top-level "top-level")
|
||||
|
|
@ -34,25 +35,13 @@
|
|||
(define-syntax test-contract-error/regexp
|
||||
(syntax-rules ()
|
||||
((_ blame obj err expr)
|
||||
(with-handlers ((exn:fail:contract?
|
||||
(lambda (exn)
|
||||
(let ([msg (exn-message exn)])
|
||||
(cond
|
||||
[(not (match-blame blame msg))
|
||||
(error 'test-contract-error
|
||||
"blame \"~a\" not found in:\n\"~a\""
|
||||
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)))))
|
||||
(check-exn (λ (exn)
|
||||
(and (exn:fail:contract? exn)
|
||||
(let ([msg (exn-message exn)])
|
||||
(and (match-blame blame msg)
|
||||
(match-obj obj msg)
|
||||
(regexp-match? err msg)))))
|
||||
(λ () expr)))))
|
||||
|
||||
(define-signature sig1
|
||||
((contracted [x number?])))
|
||||
|
|
@ -94,34 +83,39 @@
|
|||
|
||||
(define-values (c d) (values "foo" 3)))
|
||||
|
||||
(test-syntax-error "misuse of contracted"
|
||||
contracted)
|
||||
(test-syntax-error "invalid forms after contracted in signature"
|
||||
(test-syntax-error
|
||||
"misuse of define-signature keyword"
|
||||
contracted)
|
||||
(test-syntax-error
|
||||
"expected a list of [id contract]"
|
||||
(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]))))
|
||||
|
||||
(test-syntax-error "identifier h? not bound anywhere"
|
||||
(test-syntax-error
|
||||
"unbound identifier"
|
||||
(module h?-test racket
|
||||
(define-signature s^
|
||||
((define-values (f?) (values number?))
|
||||
(define-syntaxes (g?) (make-rename-transformer #'number?))
|
||||
(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)
|
||||
(define a #t)
|
||||
(define g zero?)
|
||||
(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))
|
||||
|
||||
(test-contract-error "(unit unit1)" "x" "not a number"
|
||||
(test-contract-error "(unit unit1)" "x" "number?"
|
||||
(invoke-unit (compound-unit (import) (export)
|
||||
(link (((S1 : sig1)) unit1)
|
||||
(() 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)
|
||||
(link (((S3 : sig3) (S4 : sig4))
|
||||
(unit (import) (export sig3 sig4)
|
||||
|
|
@ -131,7 +125,7 @@
|
|||
(define (b t) (if t 3 0))))
|
||||
(() 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)
|
||||
(link (((S3 : sig3) (S4 : sig4))
|
||||
(unit (import) (export sig3 sig4)
|
||||
|
|
@ -141,7 +135,7 @@
|
|||
(define (b t) (if t 3 0))))
|
||||
(() 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)
|
||||
(link (((S3 : sig3) (S4 : sig4))
|
||||
(unit (import) (export sig3 sig4)
|
||||
|
|
@ -151,7 +145,7 @@
|
|||
(define (b t) (if t 3 0))))
|
||||
(() unit4 S3 S4)))))
|
||||
|
||||
(test-contract-error "(unit unit5)" "d" "not a symbol"
|
||||
(test-contract-error "(unit unit5)" "d" "symbol?"
|
||||
(invoke-unit unit5))
|
||||
|
||||
(define-unit unit6
|
||||
|
|
@ -181,7 +175,7 @@
|
|||
(import)
|
||||
(export sig1)))
|
||||
|
||||
(test-contract-error "(unit unit7)" "x" "not a boolean"
|
||||
(test-contract-error "(unit unit7)" "x" "boolean?"
|
||||
(invoke-unit unit7))
|
||||
|
||||
(define-unit unit8
|
||||
|
|
@ -196,7 +190,7 @@
|
|||
(export sig2))
|
||||
(f #t))
|
||||
|
||||
(test-contract-error "(unit unit8)" "f" "not a number"
|
||||
(test-contract-error "(unit unit8)" "f" "number?"
|
||||
(invoke-unit unit8))
|
||||
|
||||
(define-unit unit9
|
||||
|
|
@ -211,7 +205,7 @@
|
|||
(export sig2))
|
||||
(f 3))
|
||||
|
||||
(test-contract-error "(unit unit9-1)" "f" "not a number"
|
||||
(test-contract-error "(unit unit9-1)" "f" "number?"
|
||||
(invoke-unit unit9))
|
||||
|
||||
(define-values/invoke-unit
|
||||
|
|
@ -221,7 +215,7 @@
|
|||
(import)
|
||||
(export sig2))
|
||||
|
||||
(test-contract-error top-level "f" "not a number"
|
||||
(test-contract-error top-level "f" "number?"
|
||||
(f #t))
|
||||
|
||||
(define-unit unit10
|
||||
|
|
@ -233,13 +227,13 @@
|
|||
(let ()
|
||||
(define x 0)
|
||||
(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))))
|
||||
|
||||
(let ()
|
||||
(define x 1)
|
||||
(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))))
|
||||
|
||||
;; testing that contracts from extended signatures are checked properly
|
||||
|
|
@ -252,9 +246,9 @@
|
|||
(define-values/invoke-unit unit11
|
||||
(import)
|
||||
(export sig3))
|
||||
(test-contract-error "(unit unit11)" "f" "not a number"
|
||||
(test-contract-error "(unit unit11)" "f" "number?"
|
||||
(f 3))
|
||||
(test-contract-error top-level "f" "not a number"
|
||||
(test-contract-error top-level "f" "number?"
|
||||
(f #t)))
|
||||
|
||||
;; unit/new-import-export tests
|
||||
|
|
@ -319,7 +313,7 @@
|
|||
(export)
|
||||
(link [((S : sig8)) unit19]
|
||||
[() unit20 S]))
|
||||
(test-contract-error "(unit unit19)" "f" "not a number"
|
||||
(test-contract-error "(unit unit19)" "f" "number?"
|
||||
(invoke-unit unit22)))
|
||||
|
||||
;; contracted import -> uncontracted import
|
||||
|
|
@ -340,7 +334,7 @@
|
|||
(export)
|
||||
(link [((S : sig7)) unit18]
|
||||
[() unit23 S]))
|
||||
(test-contract-error "(unit unit23)" "f" "not a number"
|
||||
(test-contract-error "(unit unit23)" "f" "number?"
|
||||
(invoke-unit unit25)))
|
||||
|
||||
;; contracted import -> contracted import
|
||||
|
|
@ -369,7 +363,7 @@
|
|||
(export)
|
||||
(link [((S : sig9)) unit28-1]
|
||||
[() unit26 S]))
|
||||
(test-contract-error "(unit unit28-1)" "f" "not a number"
|
||||
(test-contract-error "(unit unit28-1)" "f" "number?"
|
||||
(invoke-unit unit28-2)))
|
||||
|
||||
;; uncontracted export -> contracted export
|
||||
|
|
@ -390,7 +384,7 @@
|
|||
(export)
|
||||
(link [((S : sig8)) unit29]
|
||||
[() unit17 S]))
|
||||
(test-contract-error "(unit unit17)" "f" "not a number"
|
||||
(test-contract-error "(unit unit17)" "f" "number?"
|
||||
(invoke-unit unit31)))
|
||||
|
||||
;; contracted export -> uncontracted export
|
||||
|
|
@ -411,7 +405,7 @@
|
|||
(export)
|
||||
(link [((S : sig7)) unit32]
|
||||
[() unit16 S]))
|
||||
(test-contract-error "(unit unit32)" "f" "not a number"
|
||||
(test-contract-error "(unit unit32)" "f" "number?"
|
||||
(invoke-unit unit34)))
|
||||
|
||||
;; contracted export -> contracted export
|
||||
|
|
@ -440,7 +434,7 @@
|
|||
(export)
|
||||
(link [((S : sig9)) unit35]
|
||||
[() 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)))
|
||||
|
||||
;; Converting units with internal contract violations
|
||||
|
|
@ -456,7 +450,7 @@
|
|||
(export)
|
||||
(link [((S : sig8)) unit15]
|
||||
[() unit38 S]))
|
||||
(test-contract-error "(unit unit38)" "f" "not a number"
|
||||
(test-contract-error "(unit unit38)" "f" "number?"
|
||||
(invoke-unit unit39)))
|
||||
(let ()
|
||||
(define-compound-unit unit40
|
||||
|
|
@ -464,7 +458,7 @@
|
|||
(export)
|
||||
(link [((S : sig8)) unit19]
|
||||
[() unit38 S]))
|
||||
(test-contract-error "(unit unit38)" "f" "not a number"
|
||||
(test-contract-error "(unit unit38)" "f" "number?"
|
||||
(invoke-unit unit40)))
|
||||
|
||||
;; contracted import -> uncontracted import
|
||||
|
|
@ -478,7 +472,7 @@
|
|||
(export)
|
||||
(link [((S : sig7)) unit14]
|
||||
[() unit41 S]))
|
||||
(test-contract-error "(unit unit17)" "f" "not a number"
|
||||
(test-contract-error "(unit unit17)" "f" "number?"
|
||||
(invoke-unit unit42)))
|
||||
(let ()
|
||||
(define-compound-unit unit43
|
||||
|
|
@ -486,7 +480,7 @@
|
|||
(export)
|
||||
(link [((S : sig7)) unit18]
|
||||
[() unit41 S]))
|
||||
(test-contract-error "(unit unit17)" "f" "not a number"
|
||||
(test-contract-error "(unit unit17)" "f" "number?"
|
||||
(invoke-unit unit43)))
|
||||
|
||||
;; contracted import -> contracted import
|
||||
|
|
@ -504,7 +498,7 @@
|
|||
(export)
|
||||
(link [((S : sig9)) unit45-1]
|
||||
[() unit44 S]))
|
||||
(test-contract-error "(unit unit17)" "f" "not a number"
|
||||
(test-contract-error "(unit unit17)" "f" "number?"
|
||||
(invoke-unit unit45-2)))
|
||||
(let ()
|
||||
(define-unit unit46-1
|
||||
|
|
@ -516,7 +510,7 @@
|
|||
(export)
|
||||
(link [((S : sig9)) unit46-1]
|
||||
[() unit44 S]))
|
||||
(test-contract-error "(unit unit17)" "f" "not a number"
|
||||
(test-contract-error "(unit unit17)" "f" "number?"
|
||||
(invoke-unit unit46-2)))
|
||||
|
||||
;; uncontracted export -> contracted export
|
||||
|
|
@ -530,7 +524,7 @@
|
|||
(export)
|
||||
(link [((S : sig8)) unit47]
|
||||
[() unit13 S]))
|
||||
(test-contract-error "(unit unit47)" "f" "not a number"
|
||||
(test-contract-error "(unit unit47)" "f" "number?"
|
||||
(invoke-unit unit48)))
|
||||
(let ()
|
||||
(define-compound-unit unit49
|
||||
|
|
@ -538,7 +532,7 @@
|
|||
(export)
|
||||
(link [((S : sig8)) unit47]
|
||||
[() unit17 S]))
|
||||
(test-contract-error "(unit unit17)" "f" "not a number"
|
||||
(test-contract-error "(unit unit17)" "f" "number?"
|
||||
(invoke-unit unit49)))
|
||||
|
||||
;; contracted import -> uncontracted import
|
||||
|
|
@ -552,7 +546,7 @@
|
|||
(export)
|
||||
(link [((S : sig7)) unit50]
|
||||
[() unit12 S]))
|
||||
(test-contract-error "(unit unit19)" "f" "not a number"
|
||||
(test-contract-error "(unit unit19)" "f" "number?"
|
||||
(invoke-unit unit51)))
|
||||
(let ()
|
||||
(define-compound-unit unit52
|
||||
|
|
@ -560,7 +554,7 @@
|
|||
(export)
|
||||
(link [((S : sig7)) unit50]
|
||||
[() unit16 S]))
|
||||
(test-contract-error "(unit unit50)" "f" "not a number"
|
||||
(test-contract-error "(unit unit50)" "f" "number?"
|
||||
(invoke-unit unit52)))
|
||||
|
||||
;; contracted export -> contracted export
|
||||
|
|
@ -578,7 +572,7 @@
|
|||
(export)
|
||||
(link [((S : sig9)) unit53]
|
||||
[() unit54-1 S]))
|
||||
(test-contract-error "(unit unit19)" "f" "not a number"
|
||||
(test-contract-error "(unit unit19)" "f" "number?"
|
||||
(invoke-unit unit54-2)))
|
||||
(let ()
|
||||
(define-unit unit55-1
|
||||
|
|
@ -590,7 +584,7 @@
|
|||
(export)
|
||||
(link [((S : sig9)) unit53]
|
||||
[() 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)))
|
||||
|
||||
(module m1 racket
|
||||
|
|
@ -628,26 +622,29 @@
|
|||
(require (prefix-in m2: 'm2))
|
||||
|
||||
(m2:z)
|
||||
(test-contract-error "m2" "U@" "not a symbol" (m2:w))
|
||||
(test-contract-error "m1" "U@" "not a string" (m2:v))
|
||||
(test-contract-error "m2" "U@" "symbol?" (m2:w))
|
||||
(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?]))
|
||||
(export)))
|
||||
(test-syntax-error "two xs for sig1"
|
||||
(test-syntax-error
|
||||
"duplicate identifier found"
|
||||
(unit/c (import)
|
||||
(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)))
|
||||
|
||||
(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 ()
|
||||
(define/contract bad-export@
|
||||
(unit/c (import) (export sig1))
|
||||
(unit (import) (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 ()
|
||||
(define/contract bad-import@
|
||||
(unit/c (import) (export))
|
||||
|
|
@ -702,7 +699,7 @@
|
|||
|
||||
(require (prefix-in m4: 'm4))
|
||||
|
||||
(test-contract-error "m4" "f" "not an x"
|
||||
(test-contract-error "m4" "f" " x?"
|
||||
(m4:f 3))
|
||||
|
||||
(module m4:f racket
|
||||
|
|
@ -720,12 +717,12 @@
|
|||
|
||||
(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))
|
||||
|
||||
(require (prefix-in m3: 'm3))
|
||||
|
||||
(test-contract-error top-level "build-toys" "not a integer"
|
||||
(test-contract-error top-level "build-toys" "integer?"
|
||||
(let ()
|
||||
(define-values/invoke-unit/infer m3:simple-factory@)
|
||||
(build-toys #f)))
|
||||
|
|
@ -753,7 +750,7 @@
|
|||
|
||||
(m5:f 0)
|
||||
|
||||
(test-contract-error top-level "U@" "not an x"
|
||||
(test-contract-error top-level "U@" " x?"
|
||||
(m5:f 3))
|
||||
|
||||
(let ()
|
||||
|
|
@ -774,7 +771,7 @@
|
|||
(define-values/invoke-unit/infer V@)
|
||||
|
||||
(f 0)
|
||||
(test-contract-error top-level "f" "not an x"
|
||||
(test-contract-error top-level "f" "zero?"
|
||||
(f 3)))
|
||||
|
||||
(let ()
|
||||
|
|
@ -795,7 +792,7 @@
|
|||
(define-values/invoke-unit/infer V@)
|
||||
|
||||
(f 0)
|
||||
(test-contract-error "(unit V@)" "f" "not an x"
|
||||
(test-contract-error "(unit V@)" "f" "zero?"
|
||||
(f 3)))
|
||||
|
||||
(let ()
|
||||
|
|
@ -813,11 +810,11 @@
|
|||
(import) (export) (link U@ V@))
|
||||
(define-values/invoke-unit/infer U@)
|
||||
y
|
||||
(test-contract-error top-level "U@" "not a number"
|
||||
(test-contract-error top-level "U@" "number?"
|
||||
(x #t))
|
||||
(test-contract-error "(unit U@)" "U@" "not a number"
|
||||
(test-contract-error "(unit U@)" "U@" "number?"
|
||||
(x 3))
|
||||
(test-contract-error "(unit U@)" "U@" "not a number"
|
||||
(test-contract-error "(unit U@)" "U@" "number?"
|
||||
(invoke-unit W@)))
|
||||
|
||||
(let ()
|
||||
|
|
@ -831,16 +828,16 @@
|
|||
(define-unit V@
|
||||
(import foo^)
|
||||
(export)
|
||||
(test-contract-error top-level "U@" "not an x"
|
||||
(test-contract-error top-level "U@" " x?"
|
||||
(f 2))
|
||||
(test-contract-error "(unit U@)" "U@" "not an number"
|
||||
(test-contract-error "(unit U@)" "U@" " number?"
|
||||
(f 3)))
|
||||
(define-compound-unit/infer W@
|
||||
(import) (export) (link U@ V@))
|
||||
(define-values/invoke-unit/infer U@)
|
||||
(test-contract-error top-level "U@" "not an x"
|
||||
(test-contract-error top-level "U@" " x?"
|
||||
(f 4))
|
||||
(test-contract-error "(unit U@)" "U@" "not a number"
|
||||
(test-contract-error "(unit U@)" "U@" "number?"
|
||||
(f 3))
|
||||
(invoke-unit W@))
|
||||
|
||||
|
|
@ -860,7 +857,7 @@
|
|||
(define-values/invoke-unit/infer foo@)
|
||||
|
||||
(f 0)
|
||||
(test-contract-error top-level "f" "not an x"
|
||||
(test-contract-error top-level "f" " x?"
|
||||
(f 4))
|
||||
;; This is a weird one. The definition for foo@ has two conflicting
|
||||
;; 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
|
||||
;; b) what about other units that might link with foo@, that expect
|
||||
;; the stronger contract?
|
||||
(test-contract-error top-level "x?" "not a number"
|
||||
(test-contract-error top-level "x?" "number?"
|
||||
(f #t)))
|
||||
|
||||
(let ()
|
||||
|
|
@ -881,9 +878,9 @@
|
|||
(struct student (name id)))
|
||||
(define-values/invoke-unit/infer student@)
|
||||
(student "foo" 3)
|
||||
(test-contract-error top-level "student" "not a string"
|
||||
(test-contract-error top-level "student" "string?"
|
||||
(student 4 3))
|
||||
(test-contract-error top-level "student-id" "not a student"
|
||||
(test-contract-error top-level "student-id" "student?"
|
||||
(student-id 'a)))
|
||||
|
||||
;; Test that prefixing doesn't cause issues.
|
||||
|
|
@ -911,4 +908,164 @@
|
|||
(define-values/invoke-unit c@ (import) (export s^))
|
||||
(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))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -3,22 +3,16 @@
|
|||
(require syntax/parse
|
||||
"unit-compiletime.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
|
||||
import-clause/c export-clause/c)
|
||||
|
||||
(define-syntax-class sig-id
|
||||
#:attributes ()
|
||||
(pattern x
|
||||
#:declare x (static (λ (x)
|
||||
(signature? (set!-trans-extract x)))
|
||||
'signature)))
|
||||
(provide import-clause/contract export-clause/contract body-clause/contract dep-clause
|
||||
import-clause/c export-clause/c body-clause/c)
|
||||
|
||||
(define-syntax-class sig-spec #:literals (prefix rename only except)
|
||||
#:attributes ((name 0))
|
||||
#:transparent
|
||||
(pattern name:sig-id)
|
||||
(pattern name:identifier)
|
||||
(pattern (prefix i:identifier s:sig-spec)
|
||||
#:with name #'s.name)
|
||||
(pattern (rename s:sig-spec [int:identifier ext:identifier] ...)
|
||||
|
|
@ -38,8 +32,8 @@
|
|||
(define-syntax-class tagged-sig-id #:literals (tag)
|
||||
#:attributes ()
|
||||
#:transparent
|
||||
(pattern s:sig-id)
|
||||
(pattern (tag i:identifier s:sig-id)))
|
||||
(pattern s:identifier)
|
||||
(pattern (tag i:identifier s)))
|
||||
|
||||
(define-syntax-class unit/c-clause
|
||||
#:auto-nested-attributes
|
||||
|
|
@ -57,6 +51,62 @@
|
|||
#:transparent
|
||||
(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
|
||||
#:auto-nested-attributes
|
||||
#:transparent
|
||||
|
|
@ -76,3 +126,7 @@
|
|||
#:auto-nested-attributes
|
||||
#:transparent
|
||||
(pattern (init-depend s:tagged-sig-id ...)))
|
||||
(define-splicing-syntax-class body-clause/contract
|
||||
#:auto-nested-attributes
|
||||
#:transparent
|
||||
(pattern (~seq #:invoke/contract b:expr)))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
syntax/boundmap
|
||||
syntax/name
|
||||
syntax/parse
|
||||
(only-in racket/syntax generate-temporary)
|
||||
"unit-compiletime.rkt"
|
||||
"unit-contract-syntax.rkt"
|
||||
"unit-syntax.rkt")
|
||||
|
|
@ -68,10 +69,18 @@
|
|||
|
||||
(define-for-syntax contract-imports (contract-imports/exports #t))
|
||||
(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)
|
||||
(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
|
||||
(define-values (isig tagged-import-sigs import-tagged-infos
|
||||
import-tagged-sigids import-sigs)
|
||||
|
|
@ -80,7 +89,15 @@
|
|||
(define-values (esig tagged-export-sigs export-tagged-infos
|
||||
export-tagged-sigids export-sigs)
|
||||
(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
|
||||
(make-bound-identifier-mapping))
|
||||
|
||||
|
|
@ -102,12 +119,9 @@
|
|||
[c (in-list (syntax->list cs))])
|
||||
(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-unit-ie-sigs import-sigs export-sigs)
|
||||
|
||||
(for-each process-sig
|
||||
isig
|
||||
import-sigs
|
||||
|
|
@ -119,7 +133,13 @@
|
|||
(syntax->list #'((e.x ...) ...))
|
||||
(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]
|
||||
[((import-key ...) ...)
|
||||
(map tagged-info->keys import-tagged-infos)]
|
||||
|
|
@ -130,7 +150,8 @@
|
|||
import-tagged-infos)]
|
||||
[(export-name ...)
|
||||
(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
|
||||
(begin
|
||||
(make-contract
|
||||
|
|
@ -145,9 +166,13 @@
|
|||
(list (cons 'esig
|
||||
(map list (list 'e.x ...)
|
||||
(build-compound-type-name 'e.c ...)))
|
||||
...)))
|
||||
...))
|
||||
(cons 'init-depend
|
||||
(list 'd.s ...))
|
||||
#,@(attribute b.name))
|
||||
#:projection
|
||||
(λ (blame)
|
||||
#,@(make-define-ctcs/blame #'ctcs/blame #'blame)
|
||||
(λ (unit-tmp)
|
||||
(unit/c-first-order-check
|
||||
unit-tmp
|
||||
|
|
@ -157,6 +182,7 @@
|
|||
(vector-immutable
|
||||
(cons 'export-name
|
||||
(vector-immutable export-key ...)) ...)
|
||||
(list (cons 'dept depr) ...)
|
||||
blame)
|
||||
(make-unit
|
||||
'#,name
|
||||
|
|
@ -164,16 +190,19 @@
|
|||
(vector-immutable import-key ...)) ...)
|
||||
(vector-immutable (cons 'export-name
|
||||
(vector-immutable export-key ...)) ...)
|
||||
(unit-deps unit-tmp)
|
||||
(list (cons 'dept depr) ...)
|
||||
(λ ()
|
||||
(let-values ([(unit-fn export-table) ((unit-go unit-tmp))])
|
||||
(values (lambda (import-table)
|
||||
(unit-fn #,(contract-imports
|
||||
#'import-table
|
||||
import-tagged-infos
|
||||
import-sigs
|
||||
contract-table
|
||||
#'blame)))
|
||||
#,(apply-body-contract
|
||||
#`(unit-fn #,(contract-imports
|
||||
#'import-table
|
||||
import-tagged-infos
|
||||
import-sigs
|
||||
contract-table
|
||||
#'blame))
|
||||
#'blame
|
||||
#'ctcs/blame))
|
||||
#,(contract-exports
|
||||
#'export-table
|
||||
export-tagged-infos
|
||||
|
|
@ -190,6 +219,7 @@
|
|||
(vector-immutable
|
||||
(cons 'export-name
|
||||
(vector-immutable export-key ...)) ...)
|
||||
(list (cons 'dept depr) ...)
|
||||
#f)))))))]))
|
||||
|
||||
(define-syntax/err-param (unit/c stx)
|
||||
|
|
@ -198,7 +228,7 @@
|
|||
(let ([name (syntax-local-infer-name stx)])
|
||||
(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
|
||||
(define (failed str . args)
|
||||
(if blame
|
||||
|
|
@ -224,12 +254,57 @@
|
|||
[r (hash-ref t v0 #f)])
|
||||
(when (not r)
|
||||
(let ([sub-name (car (vector-ref super-sig i))])
|
||||
(if import?
|
||||
(failed "contract does not list import ~a" sub-name)
|
||||
(failed "unit must export signature ~a" sub-name)))))
|
||||
(define tag-part (vector-ref (cdr (vector-ref super-sig i)) 0))
|
||||
(define tag (and (pair? tag-part) (car tag-part)))
|
||||
(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)))))
|
||||
;; 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)
|
||||
(failed "not a unit"))
|
||||
(check-sig-subset expected-imports (unit-import-sigs val) #t)
|
||||
(check-sig-subset (unit-export-sigs val) expected-exports #f)
|
||||
(check-dependencies expected-deps (unit-deps val) expected-imports)
|
||||
#t))
|
||||
|
|
|
|||
|
|
@ -1933,14 +1933,18 @@
|
|||
(build-unit-from-context sig))
|
||||
"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)
|
||||
(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)
|
||||
(build-unit
|
||||
(check-unit-syntax
|
||||
(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))]
|
||||
[(import-tagged-sig-id ...)
|
||||
(map (λ (i s)
|
||||
|
|
@ -1956,17 +1960,27 @@
|
|||
[unit-contract
|
||||
(unit/c/core
|
||||
#'name
|
||||
(syntax/loc stx
|
||||
(quasisyntax/loc stx
|
||||
((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
|
||||
(syntax/loc stx
|
||||
(contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name)))
|
||||
isigs esigs deps))))]
|
||||
[(ic:import-clause/contract ec:export-clause/contract . body)
|
||||
(build-unit/contract
|
||||
(syntax/loc stx
|
||||
(ic ec (init-depend) . body)))]))
|
||||
[(ic:import-clause/contract ec:export-clause/contract dep:dep-clause . bexps)
|
||||
(build-unit/contract
|
||||
(quasisyntax/loc stx
|
||||
(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)
|
||||
(build-define-unit/contracted stx (λ (stx)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user