From b16f0b24b7a6117c1c25c1d37b26b9ddbf27c267 Mon Sep 17 00:00:00 2001 From: Daniel Feltey Date: Tue, 17 Feb 2015 16:34:20 -0500 Subject: [PATCH] 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. --- .../scribblings/reference/units.scrbl | 40 +- pkgs/racket-test/tests/units/test-harness.rkt | 30 +- pkgs/racket-test/tests/units/test-runtime.rkt | 11 +- .../tests/units/test-unit-contracts.rkt | 323 ++- pkgs/racket-test/tests/units/test-unit.rkt | 2458 +++++++++-------- .../racket/private/unit-contract-syntax.rkt | 80 +- .../collects/racket/private/unit-contract.rkt | 115 +- racket/collects/racket/unit.rkt | 30 +- 8 files changed, 1834 insertions(+), 1253 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/units.scrbl b/pkgs/racket-doc/scribblings/reference/units.scrbl index 0a244a281a..6f8da3ee96 100644 --- a/pkgs/racket-doc/scribblings/reference/units.scrbl +++ b/pkgs/racket-doc/scribblings/reference/units.scrbl @@ -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.} diff --git a/pkgs/racket-test/tests/units/test-harness.rkt b/pkgs/racket-test/tests/units/test-harness.rkt index 42d5f523b9..849161751c 100644 --- a/pkgs/racket-test/tests/units/test-harness.rkt +++ b/pkgs/racket-test/tests/units/test-harness.rkt @@ -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))))) diff --git a/pkgs/racket-test/tests/units/test-runtime.rkt b/pkgs/racket-test/tests/units/test-runtime.rkt index 490c4f6c46..ea92546345 100644 --- a/pkgs/racket-test/tests/units/test-runtime.rkt +++ b/pkgs/racket-test/tests/units/test-runtime.rkt @@ -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") diff --git a/pkgs/racket-test/tests/units/test-unit-contracts.rkt b/pkgs/racket-test/tests/units/test-unit-contracts.rkt index 904a1175fa..04c6b473f3 100644 --- a/pkgs/racket-test/tests/units/test-unit-contracts.rkt +++ b/pkgs/racket-test/tests/units/test-unit-contracts.rkt @@ -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)) diff --git a/pkgs/racket-test/tests/units/test-unit.rkt b/pkgs/racket-test/tests/units/test-unit.rkt index 520056b0ce..c460883198 100644 --- a/pkgs/racket-test/tests/units/test-unit.rkt +++ b/pkgs/racket-test/tests/units/test-unit.rkt @@ -3,7 +3,7 @@ (require (for-syntax racket/private/unit-compiletime racket/private/unit-syntax)) (require "test-harness.rkt" - scheme/unit) + racket/unit) (define-syntax (lookup-sig-mac stx) (parameterize ((error-syntax stx)) @@ -14,14 +14,14 @@ ((make-syntax-delta-introducer (car (signature-vars s)) member-id) (datum->syntax #'id (syntax-e member-id)))) (list (map shift-scope (signature-vars s)) - (map (lambda (def) - (cons (map shift-scope (car def)) - (cdr def))) - (signature-val-defs s)) - (map (lambda (def) - (cons (map shift-scope (car def)) - (cdr def))) - (signature-stx-defs s)))))))) + (map (lambda (def) + (cons (map shift-scope (car def)) + (cdr def))) + (signature-val-defs s)) + (map (lambda (def) + (cons (map shift-scope (car def)) + (cdr def))) + (signature-stx-defs s)))))))) (define-signature x-sig (x)) (define-signature x-sig2 (x)) @@ -39,112 +39,155 @@ (define-signature y-sub extends y-sig (yy)) (define-signature x-sub2 extends x-sig (x2)) - + ;; Keyword errors -(test-syntax-error "misuse of import" - import) -(test-syntax-error "misuse of export" - export) -(test-syntax-error "misuse of init-depend" - init-depend) -(test-syntax-error "misuse of link" - link) -(test-syntax-error "misuse of only" - only) -(test-syntax-error "misuse of except" - except) -(test-syntax-error "misuse of prefix" - prefix) -(test-syntax-error "misuse of rename" - rename) -(test-syntax-error "misuse of tag" - tag) +(test-syntax-error + "misuse of unit keyword" + import) +(test-syntax-error + "misuse of unit keyword" + export) +(test-syntax-error + "misuse of unit keyword" + init-depend) +(test-syntax-error + "misuse of compound-unit keyword" + link) +(test-syntax-error + "misuse of unit import keyword" + only) +(test-syntax-error + "misuse of unit import keyword" + except) +(test-syntax-error + "misuse of unit import and export keyword" + prefix) +(test-syntax-error + "misuse of unit import and export keyword" + rename) +(test-syntax-error + "misuse of unit import and export keyword" + tag) ;; define-signature-forms syntax errors -(test-syntax-error "define-signature-form: missing arguments" - (define-signature-form)) -(test-syntax-error "define-signature-form: missing arguments" - (define-signature-form (a b))) -(test-syntax-error "define-signature-form: too many arguments" - (define-signature-form (a b c d) 1 2)) -(test-syntax-error "define-signature-form: dot" - (define-signature-form (a b) . c)) -(test-syntax-error "define-signature-form: set!" - (let () - (define-signature-form (a b) b) - (set! a 1))) +(test-syntax-error + "bad syntax (not a list)" + (define-signature-form)) +(test-syntax-error + "bad syntax" + (define-signature-form (a b))) +(test-syntax-error + "expected syntax matching (define-signature-form (id id) expr ...)" + (define-signature-form (a b c d) 1 2)) +(test-syntax-error + "bad syntax" + (define-signature-form (a b) . c)) +(test-syntax-error + "illegal use of signature form" + (let () + (define-signature-form (a b) b) + (set! a 1))) -(test-syntax-error "define-signature-form: bad params" - (define-signature-form 1 2)) -(test-syntax-error "define-signature-form: bad params" - (define-signature-form a 2)) -(test-syntax-error "define-signature-form: name not id" - (define-signature-form (1 a) 1)) -(test-syntax-error "define-signature-form: param not id" - (define-signature-form (a 1) 1)) -(test-syntax-error "define-signature-form: param dot" - (define-signature-form (a . b) 1)) +(test-syntax-error + "bad syntax (not a list)" + (define-signature-form 1 2)) +(test-syntax-error + "bad syntax (not a list)" + (define-signature-form a 2)) +(test-syntax-error "define-signature-form: not an identifier" + (define-signature-form (1 a) 1)) +(test-syntax-error + "not an identifier" + (define-signature-form (a 1) 1)) +(test-syntax-error + "bad syntax (not a list)" + (define-signature-form (a . b) 1)) ;; define-signature syntax-errors -(test-syntax-error "define-signature: missing name" - (define-signature)) -(test-syntax-error "define-signature: missing sig" - (define-signature x)) -(test-syntax-error "define-signature: too many args" - (define-signature x (a b) 1)) -(test-syntax-error "define-signature: bad name" - (define-signature 1 (a b))) -(test-syntax-error "define-signature: bad name" - (define-signature x extends 1 (a b))) -(test-syntax-error "define-signature: not a signature" - (define-signature x extends y12 (a b))) -(test-syntax-error "define-signature: not a signature" - (let () (define-signature x extends x (a b)))) -(test-syntax-error "define-signature: bad name" - (define-signature (a . b) (a b))) -(test-syntax-error "define-signature: dot" - (define-signature b . (a b))) -(test-syntax-error "define-signature: dot" - (define-signature b (a b) . 2)) -(test-syntax-error "define-signature: set!" - (let () - (define-signature a (a)) - (set! a 1))) -(test-syntax-error "define-signature: bad sig" - (define-signature x y)) -(test-syntax-error "define-signature: bad sig" - (define-signature x (1))) -(test-syntax-error "define-signature: bad sig" - (define-signature x (a . b))) -(test-syntax-error "define-signature: bad signature form" - (define-signature x ((a)))) -(test-syntax-error "define-signature: bad signature form" - (define-signature x ((define-signature)))) -(test-syntax-error "define-values: malformed (in define-signature)" - (define-signature x ((define-values 1 2)))) -(test-syntax-error "define-signature: bad form (does not return list)" - (let () - (define-signature-form (a b) 1) - (define-signature x ((a 1))))) -(test-syntax-error "define-signature: unknown form" - (let () - (define-signature-form (a b) (list #'(c d))) - (define-signature x ((a 1))) - 1)) -(test-syntax-error "define-signature: duplicate name" - (define-signature x (a a))) -(test-syntax-error "define-signature: duplicate values" - (define-signature x (a (define-values (a) 1)))) -(test-syntax-error "define-signature: duplicate values" - (define-signature x (a (define-values (b b) 1)))) -(test-syntax-error "define-signature: duplicate values" - (define-signature x (a (define-values (b) 1) (define-syntaxes (b) 1)))) -(test-syntax-error "define-signature: duplicate values" - (let () - (define-signature test (y)) - (define-signature x extends test ((define-values (y) 1))))) +(test-syntax-error + "expected syntax matching" + (define-signature)) +(test-syntax-error + "expected syntax matching" + (define-signature x)) +(test-syntax-error + "expected syntax matching" + (define-signature x (a b) 1)) +(test-syntax-error + "not an identifier" + (define-signature 1 (a b))) +(test-syntax-error + "not an identifier" + (define-signature x extends 1 (a b))) +(test-syntax-error + "unknown signature" + (define-signature x extends y12 (a b))) +(test-syntax-error + "unknown signature" + (let () (define-signature x extends x (a b)))) +(test-syntax-error + "not an identifier" + (define-signature (a . b) (a b))) +(test-syntax-error + "expected syntax matching" + (define-signature b . (a b))) +(test-syntax-error + "bad syntax (illegal use of `.')" + (define-signature b (a b) . 2)) +(test-syntax-error + "set!: illegal use of signature name" + (let () + (define-signature a (a)) + (set! a 1))) +(test-syntax-error + "expected syntax matching" + (define-signature x y)) +(test-syntax-error + "define-signature: expected either an identifier or signature form" + (define-signature x (1))) + +(test-syntax-error + "define-signature: bad syntax (illegal use of `.')" + (define-signature x (a . b))) +(test-syntax-error + "define-signature: unknown signature form" + (define-signature x ((a)))) +(test-syntax-error + "define-signature: not a signature form" + (define-signature x ((define-signature)))) +(test-syntax-error + "define-values: bad variable list" + (define-signature x ((define-values 1 2)))) +(test-syntax-error + "define-signature: expected list of results from signature form, got 1" + (let () + (define-signature-form (a b) 1) + (define-signature x ((a 1))))) +(test-syntax-error + "define-signature: unknown signature form" + (let () + (define-signature-form (a b) (list #'(c d))) + (define-signature x ((a 1))) + 1)) +(test-syntax-error + "define-signature: duplicate identifier" + (define-signature x (a a))) +(test-syntax-error + "define-signature: duplicate identifier" + (define-signature x (a (define-values (a) 1)))) +(test-syntax-error + "define-signature: duplicate identifier" + (define-signature x (a (define-values (b b) 1)))) +(test-syntax-error + "define-signature: duplicate identifier" + (define-signature x (a (define-values (b) 1) (define-syntaxes (b) 1)))) +(test-syntax-error + "define-signature: duplicate identifier" + (let () + (define-signature test (y)) + (define-signature x extends test ((define-values (y) 1))))) ;; define-signature (test stx-bound-id=? #'((a b) () ()) @@ -197,7 +240,7 @@ (lookup-sig-mac x))) (let () (define-signature-form (x y) - (list (cdr (syntax-e y)))) + (list (cdr (syntax-e y)))) (test stx-bound-id=? #'((a) () ()) @@ -206,160 +249,205 @@ (lookup-sig-mac z)))) ;; unit syntax errors (without sub-signatures) -(test-syntax-error "unit: bad sig import" - (unit (import 1) (export))) -(test-syntax-error "unit: bad sig export" - (unit (import) (export 1))) -(test-syntax-error "unit: unknown sig import" - (unit (import a) (export))) -(test-syntax-error "unit: unknown sig export" - (unit (import) (export a))) -(test-syntax-error "unit: bad tag (not identifier)" - (unit (import (tag 1 empty-sig)) (export))) -(test-syntax-error "unit: bad tag (not identifier)" - (unit (import) (export (tag 'a empty-sig)))) -(test-syntax-error "define-values: bad syntax (in unit)" - (unit (import) (export) (define-values))) -(test-syntax-error "unit: multiple definition" - (unit (import) (export) (define-values (x x) (values 1 2)))) -(test-syntax-error "unit: multiple definition" - (unit (import) (export) (define-syntaxes (x x) (values 1 2)))) -(test-syntax-error "unit: multiple definition" - (unit (import) (export) (define x 1) (define x 2))) -(test-syntax-error "unit: multiple definition" - (unit (import) (export) (define-syntax x 1) (define-syntax x 2))) -(test-syntax-error "unit: multiple definition" - (unit (import) (export) (define x 1) (define-syntax x 2))) -(test-syntax-error "unit: re-export" - (unit (import x-sig) (export x-sig) (define x 1))) -(test-syntax-error "unit: redefine import" - (unit (import x-sig) (export) (define x 1))) -(test-syntax-error "unit: set! import" - (unit (import x-sig) (export) (set! x 1))) -(test-syntax-error "unit: set! export" - (unit (import) (export x-sig) (define x 1) (set! x 1))) +(test-syntax-error + "unit: bad import spec" + (unit (import 1) (export))) +(test-syntax-error + "unit: bad export spec" + (unit (import) (export 1))) +(test-syntax-error + "unit: unknown signature" + (unit (import a) (export))) +(test-syntax-error + "unit: unknown signature" + (unit (import) (export a))) +(test-syntax-error + "unit: tag must be a symbol" + (unit (import (tag 1 empty-sig)) (export))) +(test-syntax-error + "unit: tag must be a symbol" + (unit (import) (export (tag 'a empty-sig)))) +(test-syntax-error + "define-values: bad syntax (has 0 parts after keyword)" + (unit (import) (export) (define-values))) +(test-syntax-error + "unit: variable defined twice" + (unit (import) (export) (define-values (x x) (values 1 2)))) +(test-syntax-error + "unit: variable defined twice" + (unit (import) (export) (define-syntaxes (x x) (values 1 2)))) +(test-syntax-error + "unit: variable defined twice" + (unit (import) (export) (define x 1) (define x 2))) +(test-syntax-error + "unit: variable defined twice" + (unit (import) (export) (define-syntax x 1) (define-syntax x 2))) +(test-syntax-error + "unit: variable defined twice" + (unit (import) (export) (define x 1) (define-syntax x 2))) +(test-syntax-error + "unit: import x is exported" + (unit (import x-sig) (export x-sig) (define x 1))) +(test-syntax-error + "unit: definition for imported identifier" + (unit (import x-sig) (export) (define x 1))) +(test-syntax-error + "unit: cannot set! imported or exported variables" + (unit (import x-sig) (export) (set! x 1))) +(test-syntax-error + "unit: cannot set! imported or exported variables" + (unit (import) (export x-sig) (define x 1) (set! x 1))) (test-syntax-error "unit: undefined export" - (unit (import) (export x-sig))) + (unit (import) (export x-sig))) (test-syntax-error "unit: undefined export" - (unit (import) (export (prefix x: x-sig)) (define x 1))) -(test-syntax-error "unit: syntax export" - (unit (import) (export x-sig) (define-syntax x 1))) -(test-syntax-error "unit: duplicate import" - (unit (import x-sig x-sig2) (export))) -(test-syntax-error "unit: duplicate export" - (unit (import) (export x-sig x-sig2) (define x 12))) + (unit (import) (export (prefix x: x-sig)) (define x 1))) +(test-syntax-error + "unit: cannot export syntax from a unit" + (unit (import) (export x-sig) (define-syntax x 1))) +(test-syntax-error + "unit: x is imported by multiple signatures" + (unit (import x-sig x-sig2) (export))) +(test-syntax-error + "unit: x is exported by multiple signatures" + (unit (import) (export x-sig x-sig2) (define x 12))) +(test-syntax-error + "unit: duplicate import signature" + (unit (import x-sig (prefix a x-sig)) (export))) +(test-syntax-error + "unit: the signature of x-sig extends this signature" + (unit (import) (export x-sig (prefix a x-sig)) + (define x 1) (define ax 2))) (test-syntax-error "unit: duplicate import signature" - (unit (import x-sig (prefix a x-sig)) (export))) -(test-syntax-error "unit: duplicate export signature" - (unit (import) (export x-sig (prefix a x-sig)) - (define x 1) (define ax 2))) -(test-syntax-error "unit: duplicate import signature" - (unit (import (tag t x-sig) (tag t (prefix a x-sig))) (export))) -(test-syntax-error "unit: duplicate export signature" - (unit (import) (export (tag t x-sig) (tag t (prefix a x-sig))) - (define x 1) (define ax 2))) -(test-syntax-error "unit: duplicate export signature" - (unit (import) (export x-sig x-sig) - (define x 1))) + (unit (import (tag t x-sig) (tag t (prefix a x-sig))) (export))) +(test-syntax-error + "unit: the signature of (tag t x-sig) extends this signature" + (unit (import) (export (tag t x-sig) (tag t (prefix a x-sig))) + (define x 1) (define ax 2))) +(test-syntax-error + "unit: the signature of x-sig extends this signature" + (unit (import) (export x-sig x-sig) + (define x 1))) ;; compound-unit syntax errors (without sub-signatures) -(test-syntax-error "compound-unit: bad import clause" - (compound-unit (import (a empty-sig)) (export) (link))) -(test-syntax-error "compound-unit: import clause bad link id" - (compound-unit (import (1 : empty-sig)) (export) (link))) -(test-syntax-error "compound-unit: import clause unknown sig" - (compound-unit (import (a : empty-si)) (export) (link))) -(test-syntax-error "compound-unit: export bad link id" - (compound-unit (import) (export a 1 b) (link))) -(test-syntax-error "compound-unit: link line bad link id" - (compound-unit (import) (export) (link (((a : empty-sig)) b 1)))) -(test-syntax-error "compound-unit: import clause bad sig id" - (compound-unit (import (a : ())) (export) (link))) -(test-syntax-error "compound-unit: link line clause bad sig id" - (compound-unit (import) (export) (link (((a : "")) b)))) -(test-syntax-error "compound-unit: link line clause bad" - (compound-unit (import) (export) (link (((a empty-sig)) b)))) -(test-syntax-error "compound-unit: link line clause unknown" - (compound-unit (import) (export) (link (((a : b)) b)))) -(test-syntax-error "compound-unit: duplicate link ids" - (compound-unit (import (x : x-sig) (x : y-sig)) (export) (link))) -(test-syntax-error "compound-unit: duplicate link ids" - (compound-unit (import) (export) (link (((x : x-sig) (x : y-sig)) u)))) -(test-syntax-error "compound-unit: duplicate link ids" - (compound-unit (import (x : x-sig)) (export) (link (((x : x-sig)) u)))) -(test-syntax-error "export: unbound link id" - (compound-unit (import) (export a) (link))) -(test-syntax-error "link link: unbound link id" - (compound-unit (import) (export) (link (() u a)))) -(test-syntax-error "compound-unit: re-export" - (compound-unit (import (S : x-sig)) (export S) (link))) -(test-syntax-error "compound-unit: re-export" - (compound-unit (import (tag s (S : x-sig))) (export (tag t S)) (link))) -(test-syntax-error "compound-unit: duplicate export signature" - (compound-unit (import) (export X1 X2) - (link (((X1 : x-sig)) (unit (import) (export x-sig) (define x 1))) - (((X2 : x-sig)) (unit (import) (export x-sig) (define x 1)))))) -(test-syntax-error "compound-unit: duplicate export signature" - (compound-unit (import) (export (tag t X1) (tag t X2)) - (link (((X1 : x-sig)) (unit (import) (export x-sig) (define x 1))) - (((X2 : x-sig)) (unit (import) (export x-sig) (define x 1)))))) +(test-syntax-error + "compound-unit: expected syntax matching ( : ) or ( : (tag ))" + (compound-unit (import (a empty-sig)) (export) (link))) +(test-syntax-error + "compound-unit: expected syntax matching ( : ) or ( : (tag ))" + (compound-unit (import (1 : empty-sig)) (export) (link))) +(test-syntax-error + "compound-unit: unknown signature" + (compound-unit (import (a : empty-si)) (export) (link))) +(test-syntax-error + "compound-unit: not an identifier" + (compound-unit (import) (export a 1 b) (link))) +(test-syntax-error + "compound-unit: not an identifier" + (compound-unit (import) (export) (link (((a : empty-sig)) b 1)))) +(test-syntax-error + "compound-unit: not an identifier" + (compound-unit (import (a : ())) (export) (link))) +(test-syntax-error + "compound-unit: not an identifier" + (compound-unit (import) (export) (link (((a : "")) b)))) +(test-syntax-error + "compound-unit: expected syntax matching ( : ) or ( : (tag ))" + (compound-unit (import) (export) (link (((a empty-sig)) b)))) +(test-syntax-error + "compound-unit: unknown signature" + (compound-unit (import) (export) (link (((a : b)) b)))) +(test-syntax-error + "compound-unit: duplicate linking identifier definition" + (compound-unit (import (x : x-sig) (x : y-sig)) (export) (link))) +(test-syntax-error + "compound-unit: duplicate linking identifier definition" + (compound-unit (import) (export) (link (((x : x-sig) (x : y-sig)) u)))) +(test-syntax-error + "compound-unit: duplicate linking identifier definition" + (compound-unit (import (x : x-sig)) (export) (link (((x : x-sig)) u)))) +(test-syntax-error + "compound-unit: unknown linking identifier" + (compound-unit (import) (export a) (link))) +(test-syntax-error + "compound-unit: unknown linking identifier" + (compound-unit (import) (export) (link (() u a)))) +(test-syntax-error + "compound-unit: cannot directly export an import" + (compound-unit (import (S : x-sig)) (export S) (link))) +(test-syntax-error + "compound-unit: expected syntax matching ( : ) or ( : (tag ))" + (compound-unit (import (tag s (S : x-sig))) (export (tag t S)) (link))) +(test-syntax-error + "compound-unit: the signature of X1 extends this signature" + (compound-unit (import) (export X1 X2) + (link (((X1 : x-sig)) (unit (import) (export x-sig) (define x 1))) + (((X2 : x-sig)) (unit (import) (export x-sig) (define x 1)))))) +(test-syntax-error + "compound-unit: the signature of (tag t X1) extends this signature" + (compound-unit (import) (export (tag t X1) (tag t X2)) + (link (((X1 : x-sig)) (unit (import) (export x-sig) (define x 1))) + (((X2 : x-sig)) (unit (import) (export x-sig) (define x 1)))))) ;; define-values/invoke-unit syntax errors -(test-syntax-error "define-values/invoke-unit: no unit" - (define-values/invoke-unit)) -(test-syntax-error "define-values/invoke-unit: dot" - (define-values/invoke-unit x y . x)) -(test-syntax-error "define-values/invoke-unit: bad sig" - (define-values/invoke-unit 1 1)) -(test-syntax-error "define-values/invoke-unit: duplicate exports" - (define-values/invoke-unit (unit (import) (export (prefix x: x-sig) x-sig2) - (define x 1) - (define x:x 2)) - x-sig x-sig2)) +(test-syntax-error + "define-values/invoke-unit: missing unit" + (define-values/invoke-unit)) +(test-syntax-error + "define-values/invoke-unit: expected syntax matching (define-values/invoke-unit (import ...) (export ...))" + (define-values/invoke-unit x y . x)) +(test-syntax-error + "define-values/invoke-unit: expected syntax matching (define-values/invoke-unit (import ...) (export ...))" + (define-values/invoke-unit 1 1)) +(test-syntax-error + "define-values/invoke-unit: expected syntax matching (define-values/invoke-unit (import ...) (export ...))" + (define-values/invoke-unit (unit (import) (export (prefix x: x-sig) x-sig2) + (define x 1) + (define x:x 2)) + x-sig x-sig2)) ;; simple units, compound-units, and invoke-units (no subtypes, no tags, no prefix/rename/etc, no fancy signatures) (test 12 - (invoke-unit (unit (import) (export) 12))) + (invoke-unit (unit (import) (export) 12))) (test 3 - (invoke-unit - (compound-unit (import) (export) - (link (((X : x-sig) (Y : y-sig)) (unit (import empty-sig z-sig) - (export y-sig x-sig) - (define x 1) - (define y 2)) - Z E) - (((Z : z-sig) (E : empty-sig)) (unit (import x-sig y-sig) - (export empty-sig z-sig) - (define z 3) - 3) X Y))))) - + (invoke-unit + (compound-unit (import) (export) + (link (((X : x-sig) (Y : y-sig)) (unit (import empty-sig z-sig) + (export y-sig x-sig) + (define x 1) + (define y 2)) + Z E) + (((Z : z-sig) (E : empty-sig)) (unit (import x-sig y-sig) + (export empty-sig z-sig) + (define z 3) + 3) X Y))))) + ;; Test compound export with signatures containing overlapping names (test (list 10 11 12) - (let ((un (compound-unit (import) (export S U) - (link (((S : x-sig)) (unit (import) (export x-sig) (define x 10))) - (((U : xy-sig)) (unit (import) (export xy-sig) (define x 11) (define y 12))))))) - (invoke-unit - (compound-unit (import) (export) - (link (((S : x-sig) (U : xy-sig)) un) - (((B : b-sig)) (unit (import x-sig) (export b-sig) (define b x)) S) - (() (unit (import b-sig xy-sig) (export) (list b x y)) B U)))))) + (let ((un (compound-unit (import) (export S U) + (link (((S : x-sig)) (unit (import) (export x-sig) (define x 10))) + (((U : xy-sig)) (unit (import) (export xy-sig) (define x 11) (define y 12))))))) + (invoke-unit + (compound-unit (import) (export) + (link (((S : x-sig) (U : xy-sig)) un) + (((B : b-sig)) (unit (import x-sig) (export b-sig) (define b x)) S) + (() (unit (import b-sig xy-sig) (export) (list b x y)) B U)))))) (define-signature even-sig (even)) (define-signature odd-sig (odd)) (define even-unit (unit (import odd-sig) - (export even-sig) + (export even-sig) (define (even x) (or (= 0 x) (odd (sub1 x)))))) (define odd-unit (unit (import even-sig) - (export odd-sig) + (export odd-sig) (define (odd x) (and (> x 0) (even (sub1 x)))) (define x (odd 11)) @@ -368,8 +456,8 @@ (define run-unit (compound-unit (import) (export) - (link (((EVEN : even-sig)) even-unit ODD) - (((ODD : odd-sig)) odd-unit EVEN)))) + (link (((EVEN : even-sig)) even-unit ODD) + (((ODD : odd-sig)) odd-unit EVEN)))) (test #t (invoke-unit run-unit)) @@ -379,38 +467,38 @@ (define is-3x-unit (unit (import is-3x+2-sig) - (export is-3x-sig) + (export is-3x-sig) (define (is-3x x) (or (= 0 x) (is-3x+2 (sub1 x)))))) (define is-3x+2-unit (unit (import is-3x+1-sig) - (export is-3x+2-sig) + (export is-3x+2-sig) (define (is-3x+2 x) (and (> x 0) (is-3x+1 (sub1 x)))))) (define is-3x+1-unit (unit (import is-3x-sig) - (export is-3x+1-sig) + (export is-3x+1-sig) (define (is-3x+1 x) (and (> x 0) (is-3x (sub1 x)))))) (define 3x-compound1 (compound-unit (import (IS-3X : is-3x-sig)) (export IS-3X+1 IS-3X+2) - (link (((IS-3X+1 : is-3x+1-sig)) is-3x+1-unit IS-3X) - (((IS-3X+2 : is-3x+2-sig)) is-3x+2-unit IS-3X+1)))) + (link (((IS-3X+1 : is-3x+1-sig)) is-3x+1-unit IS-3X) + (((IS-3X+2 : is-3x+2-sig)) is-3x+2-unit IS-3X+1)))) (define 3x-compound2 (compound-unit (import) (export IS-3X) - (link (((IS-3X : is-3x-sig)) is-3x-unit IS-3X+2) - (((IS-3X+1 : is-3x+1-sig) - (IS-3X+2 : is-3x+2-sig)) 3x-compound1 IS-3X)))) + (link (((IS-3X : is-3x-sig)) is-3x-unit IS-3X+2) + (((IS-3X+1 : is-3x+1-sig) + (IS-3X+2 : is-3x+2-sig)) 3x-compound1 IS-3X)))) (define 3x-run-unit (unit (import is-3x-sig is-3x+1-sig is-3x+2-sig) - (export) + (export) (list (is-3x 1) (is-3x 3) (is-3x+1 5) @@ -421,100 +509,104 @@ (define 3x-compound3 (compound-unit (import) (export IS-3X IS-3X+1 IS-3X+2) - (link (((IS-3X : is-3x-sig)) 3x-compound2) - (((IS-3X+1 : is-3x+1-sig) - (IS-3X+2 : is-3x+2-sig)) 3x-compound1 IS-3X) - (() 3x-run-unit IS-3X IS-3X+1 IS-3X+2)))) + (link (((IS-3X : is-3x-sig)) 3x-compound2) + (((IS-3X+1 : is-3x+1-sig) + (IS-3X+2 : is-3x+2-sig)) 3x-compound1 IS-3X) + (() 3x-run-unit IS-3X IS-3X+1 IS-3X+2)))) (test (list #f #t #f #t #f #t) - (invoke-unit 3x-compound3)) + (invoke-unit 3x-compound3)) (test (list #t #t #t) - (let () - (define-values/invoke-unit 3x-compound3 (import) (export is-3x-sig is-3x+1-sig is-3x+2-sig)) - (list (is-3x+2 8) - (is-3x+1 7) - (is-3x 6)))) + (let () + (define-values/invoke-unit 3x-compound3 (import) (export is-3x-sig is-3x+1-sig is-3x+2-sig)) + (list (is-3x+2 8) + (is-3x+1 7) + (is-3x 6)))) (test (list #t #t #t) - (let () - (define-values/invoke-unit 3x-compound3 (import) (export (only is-3x-sig is-3x) (except is-3x+1-sig) (prefix x: is-3x+2-sig))) - (list (x:is-3x+2 8) - (is-3x+1 7) - (is-3x 6)))) + (let () + (define-values/invoke-unit 3x-compound3 (import) (export (only is-3x-sig is-3x) (except is-3x+1-sig) (prefix x: is-3x+2-sig))) + (list (x:is-3x+2 8) + (is-3x+1 7) + (is-3x 6)))) (test (list #t #t #t) - (let () - (define-values/invoke-unit 3x-compound3 (import) (export is-3x-sig is-3x+1-sig (rename is-3x+2-sig (y is-3x+2)))) - (list (y 8) - (is-3x+1 7) - (is-3x 6)))) + (let () + (define-values/invoke-unit 3x-compound3 (import) (export is-3x-sig is-3x+1-sig (rename is-3x+2-sig (y is-3x+2)))) + (list (y 8) + (is-3x+1 7) + (is-3x 6)))) ;; Tags (let () (define u (unit (import x-sig (tag t (prefix t: x-sig)) (tag u (prefix u: x-sig))) - (export) - (list x t:x u:x))) + (export) + (list x t:x u:x))) (define v (unit (import) - (export x-sig (tag t (prefix t: x-sig)) (tag u (prefix u: x-sig))) - (define x 1) - (define t:x 2) - (define u:x 3))) + (export x-sig (tag t (prefix t: x-sig)) (tag u (prefix u: x-sig))) + (define x 1) + (define t:x 2) + (define u:x 3))) (test '(3 1 2) - (invoke-unit - (compound-unit (import) (export) - (link (((X1 : x-sig) (X2 : (tag u x-sig)) (X3 : (tag t x-sig))) v) - (() u (tag t X1) X2 (tag u X3)))))) + (invoke-unit + (compound-unit (import) (export) + (link (((X1 : x-sig) (X2 : (tag u x-sig)) (X3 : (tag t x-sig))) v) + (() u (tag t X1) X2 (tag u X3)))))) (test '(3 1 2) - (invoke-unit - (compound-unit (import) (export) - (link (((L1 : (tag a x-sig)) (L2 : (tag b x-sig)) (L3 : (tag c x-sig))) - (compound-unit (import) (export (tag a X1) (tag b X2) (tag c X3)) - (link (((X1 : x-sig) (X2 : (tag u x-sig)) (X3 : (tag t x-sig))) v)))) - (() - (compound-unit (import (X1 : x-sig) (X2 : (tag u x-sig)) (X3 : (tag t x-sig))) (export) - (link (() u (tag t X1) X2 (tag u X3)))) - L1 (tag u L2) (tag t L3))))))) + (invoke-unit + (compound-unit (import) (export) + (link (((L1 : (tag a x-sig)) (L2 : (tag b x-sig)) (L3 : (tag c x-sig))) + (compound-unit (import) (export (tag a X1) (tag b X2) (tag c X3)) + (link (((X1 : x-sig) (X2 : (tag u x-sig)) (X3 : (tag t x-sig))) v)))) + (() + (compound-unit (import (X1 : x-sig) (X2 : (tag u x-sig)) (X3 : (tag t x-sig))) (export) + (link (() u (tag t X1) X2 (tag u X3)))) + L1 (tag u L2) (tag t L3))))))) (let () (define-values/invoke-unit (unit (import) (export (tag t x-sig)) (define x 1)) (import) (export (tag t x-sig))) (test 1 x)) ;; simple runtime errors (no subtyping, no deps) -(test-runtime-error exn:fail:contract? "compound-unit: not a unit" - (compound-unit (import) (export) (link (() 1)))) -(test-runtime-error exn:fail:contract? "compound-unit: missing import" - (compound-unit (import) (export) - (link (() (unit (import x-sig) (export)))))) -(test-runtime-error exn:fail:contract? "compound-unit: missing import" - (compound-unit (import (X : x-sig)) (export) - (link (() (unit (import x-sig) (export)) - (tag u X))))) -(test-runtime-error exn:fail:contract? "compound-unit: missing import" - (compound-unit (import (X : x-sig)) (export) - (link (() (unit (import (tag u x-sig)) (export)) - X)))) -(test-runtime-error exn:fail:contract? "compound-unit: missing export" - (compound-unit (import) (export) - (link (((X : x-sig)) (unit (import) (export)))))) -(test-runtime-error exn:fail:contract? "compound-unit: missing export" - (compound-unit (import) (export) - (link (((X : (tag u x-sig))) (unit (import) (export x-sig) (define x 1)))))) -(test-runtime-error exn:fail:contract? "compound-unit: missing export" - (compound-unit (import) (export) - (link (((X : x-sig)) (unit (import (tag u x-sig)) (export)))))) +(test-runtime-error exn:fail:contract? "compound-unit: result of unit expression was not a unit: 1" + (compound-unit (import) (export) (link (() 1)))) +(test-runtime-error exn:fail:contract? "compound-unit: unit argument expects an untagged import with signature x-sig, which this usage context does not supply" + (compound-unit (import) (export) + (link (() (unit (import x-sig) (export)))))) +(test-runtime-error exn:fail:contract? "compound-unit: unit argument expects an untagged import with signature x-sig, which this usage context does not supply" + (compound-unit (import (X : x-sig)) (export) + (link (() (unit (import x-sig) (export)) + (tag u X))))) +(test-runtime-error exn:fail:contract? "compound-unit: unit argument expects an import for tag u with signature x-sig, which this usage context does not supply" + (compound-unit (import (X : x-sig)) (export) + (link (() (unit (import (tag u x-sig)) (export)) + X)))) +(test-runtime-error exn:fail:contract? "compound-unit: this usage context expects a unit with an untagged export with signature x-sig, which the given unit does not supply" + (compound-unit (import) (export) + (link (((X : x-sig)) (unit (import) (export)))))) +(test-runtime-error exn:fail:contract? "compound-unit: this usage context expects a unit with an export for tag u with signature x-sig, which the given unit does not supply" + (compound-unit (import) (export) + (link (((X : (tag u x-sig))) (unit (import) (export x-sig) (define x 1)))))) +(test-runtime-error exn:fail:contract? "compound-unit: unit argument expects an import for tag u with signature x-sig, which this usage context does not supply" + (compound-unit (import) (export) + (link (((X : x-sig)) (unit (import (tag u x-sig)) (export)))))) -(test-runtime-error exn:fail:contract? "invoke-unit: not a unit" - (invoke-unit 1)) -(test-runtime-error exn:fail:contract? "invoke-unit: unit has imports" - (invoke-unit (unit (import x-sig) (export) x))) +(test-runtime-error exn:fail:contract? "invoke-unit: result of unit expression was not a unit: 1" + (invoke-unit 1)) +(test-runtime-error exn:fail:contract? "invoke-unit: unit argument expects an untagged import with signature x-sig, which this usage context does not supply" + (invoke-unit (unit (import x-sig) (export) x))) -(test-runtime-error exn:fail:contract? "define-values/invoke-unit: not a unit" - (define-values/invoke-unit 1 (import) (export))) -(test-runtime-error exn:fail:contract? "define-values/invoke-unit: has imports" - (define-values/invoke-unit (unit (import x-sig) (export) x) (import) (export))) -(test-runtime-error exn:fail:contract? "define-values/invoke-unit: signature mismatch" - (define-values/invoke-unit (unit (import) (export)) (import) (export x-sig))) +(test-runtime-error exn:fail:contract? "define-values/invoke-unit: result of unit expression was not a unit: 1" + (define-values/invoke-unit 1 (import) (export))) +(test-runtime-error + exn:fail:contract? + "define-values/invoke-unit: unit argument expects an untagged import with signature x-sig, which this usage context does not supply" + (define-values/invoke-unit (unit (import x-sig) (export) x) (import) (export))) +(test-runtime-error + exn:fail:contract? + "define-values/invoke-unit: this usage context expects a unit with an untagged export with signature x-sig, which the given unit does not supply" + (define-values/invoke-unit (unit (import) (export)) (import) (export x-sig))) ;; unit creation w/o signatures (including macros and prefixes/renames). @@ -522,20 +614,20 @@ (let ((y 1) (z 10)) (define u (unit (import) (export yz-sig) - (define y 2) - (define z 3))) + (define y 2) + (define z 3))) (define u1 (unit (import) (export) - y)) + y)) (define u2 (unit (import (only yz-sig z)) (export) - y)) + y)) (define u3 (unit (import (except yz-sig y)) (export) - y)) + y)) (define u4 (unit (import (prefix s: yz-sig)) (export) - y)) + y)) (define u5 (unit (import (rename yz-sig (r y))) (export) - y)) + y)) (define u6 (unit (import yz-sig) (export) - y)) + y)) (define (l x) (invoke-unit (compound-unit (import) (export) @@ -554,85 +646,85 @@ (define-values/invoke-unit (unit-from-context yz-sig) (import) (export yz-sig)) y)) (test 1 - (let () - (let ((u (unit-from-context yz-sig))) - (define-values/invoke-unit u (import) (export (prefix x: yz-sig))) - x:y))) + (let () + (let ((u (unit-from-context yz-sig))) + (define-values/invoke-unit u (import) (export (prefix x: yz-sig))) + x:y))) ;; Exporting and prefix don't work right because the shadower doesn't see the shadowed ;; bindings, I think. #;(test 1 + (let ((x:y 12) + (x:z 10)) +(let ((u (unit-from-context (prefix x: yz-sig)))) + (define-values/invoke-unit u yz-sig) + y))) +#;(test 1 +(let ((x:y 12) + (x:z 10)) + (define-signature t (y z)) + (let ((u (unit-from-context (prefix x: t)))) + (define-values/invoke-unit u t) + y))) +(test 12 (let ((x:y 12) (x:z 10)) - (let ((u (unit-from-context (prefix x: yz-sig)))) - (define-values/invoke-unit u yz-sig) - y))) - #;(test 1 - (let ((x:y 12) - (x:z 10)) - (define-signature t (y z)) - (let ((u (unit-from-context (prefix x: t)))) - (define-values/invoke-unit u t) - y))) - (test 12 - (let ((x:y 12) - (x:z 10)) - (define-values/invoke-unit (unit-from-context (rename yz-sig (x:y y) (x:z z))) - (import) (export yz-sig)) - y)) - (test 12 - (let ((x:y 12) - (x:z 10)) - (define-signature t (y z)) - (let () - (define-values/invoke-unit (unit-from-context (rename t (x:y y) (x:z z))) (import) (export t)) - y)))) + (define-values/invoke-unit (unit-from-context (rename yz-sig (x:y y) (x:z z))) + (import) (export yz-sig)) + y)) +(test 12 + (let ((x:y 12) + (x:z 10)) + (define-signature t (y z)) + (let () + (define-values/invoke-unit (unit-from-context (rename t (x:y y) (x:z z))) (import) (export t)) + y)))) ;; Test that a define-values can define both internal and exported vars (test '(1 2) - (invoke-unit - (compound-unit (import) (export) - (link (((T : yz-sig)) (unit (import x-sig) (export yz-sig) + (invoke-unit + (compound-unit (import) (export) + (link (((T : yz-sig)) (unit (import x-sig) (export yz-sig) (define-values (y a) (values 1 2)) (define-values (b z) (values y a))) - S) - (((S : x-sig)) (unit (import yz-sig) (export x-sig) (define x 3) (list y z)) T))))) + S) + (((S : x-sig)) (unit (import yz-sig) (export x-sig) (define x 3) (list y z)) T))))) ;; Test that internal macros can define exports (test 1 - (invoke-unit - (unit (import) (export x-sig) + (invoke-unit + (unit (import) (export x-sig) (define-syntax (y stx) (syntax-case stx () ((_ x) #'(define x 1)))) (y x) x))) - + (define-signature fact-sig (fact n)) ;; Test renaming, self-recursion, only, and except (test 24 - (invoke-unit - (compound-unit (import) (export) - (link (((F : fact-sig)) (unit (import (except (rename fact-sig (f-in fact)) n)) - (export (rename fact-sig (f-out fact))) - (define n 1) - (define (f-out x) (if (= 0 x) - 1 - (* x (f-in (sub1 x)))))) + (invoke-unit + (compound-unit (import) (export) + (link (((F : fact-sig)) (unit (import (except (rename fact-sig (f-in fact)) n)) + (export (rename fact-sig (f-out fact))) + (define n 1) + (define (f-out x) (if (= 0 x) + 1 + (* x (f-in (sub1 x)))))) F) - (() (unit (import (only fact-sig fact)) (export) - (define n 2) - (fact 4)) - F))))) + (() (unit (import (only fact-sig fact)) (export) + (define n 2) + (fact 4)) + F))))) ;; Test import prefix (test 1 - (invoke-unit - (compound-unit (import) (export) - (link (((S : x-sig)) (unit (import) (export x-sig) (define x 1))) - (() (unit (import (prefix s: x-sig)) (export) s:x) S))))) + (invoke-unit + (compound-unit (import) (export) + (link (((S : x-sig)) (unit (import) (export x-sig) (define x 1))) + (() (unit (import (prefix s: x-sig)) (export) s:x) S))))) (define-signature sx (x)) (define-signature sy (y)) @@ -640,50 +732,50 @@ ;; Test separate signatures with overlapping bindings, and export renaming and prefix (test '(1 2 3) - (invoke-unit - (compound-unit (import) (export) - (link (((S : x-sig) (T : yz-sig) (U : xy-sig)) (unit (import) (export (rename x-sig (s:x x)) - (rename yz-sig (t:y y) (t:z z)) - (prefix u: xy-sig)) - (define x 1) (define y 2) (define z 3) - (define s:x x) (define t:y y) (define t:z z) (define u:x x) (define u:y y))) - (((SX : sx)) (unit (import (prefix s: x-sig)) (export sx) (define x s:x)) S) - (((SY : sy)) (unit (import (prefix u: xy-sig)) (export sy) (define y u:y)) U) - (((SZ : sz)) (unit (import (prefix t: yz-sig)) (export sz) (define z t:z)) T) - (() (unit (import sx sy sz) (export) (list x y z)) SX SY SZ))))) + (invoke-unit + (compound-unit (import) (export) + (link (((S : x-sig) (T : yz-sig) (U : xy-sig)) (unit (import) (export (rename x-sig (s:x x)) + (rename yz-sig (t:y y) (t:z z)) + (prefix u: xy-sig)) + (define x 1) (define y 2) (define z 3) + (define s:x x) (define t:y y) (define t:z z) (define u:x x) (define u:y y))) + (((SX : sx)) (unit (import (prefix s: x-sig)) (export sx) (define x s:x)) S) + (((SY : sy)) (unit (import (prefix u: xy-sig)) (export sy) (define y u:y)) U) + (((SZ : sz)) (unit (import (prefix t: yz-sig)) (export sz) (define z t:z)) T) + (() (unit (import sx sy sz) (export) (list x y z)) SX SY SZ))))) ;; Test units importing and exporting b, where lexical definition of b shadows ;; the b identifier in the signature (test 2 - (let ((b 1)) - (define u1 (unit (import) (export b-sig) (define b 2))) - (define u2 (unit (import b-sig) (export) b)) - (invoke-unit (compound-unit (import) (export) - (link (((B : b-sig)) u1) - (() u2 B)))))) + (let ((b 1)) + (define u1 (unit (import) (export b-sig) (define b 2))) + (define u2 (unit (import b-sig) (export) b)) + (invoke-unit (compound-unit (import) (export) + (link (((B : b-sig)) u1) + (() u2 B)))))) (test 1 - (let ((b 1)) - (define u1 (unit-from-context b-sig)) - (let ((b 2)) - (define-values/invoke-unit u1 (import) (export b-sig)) - b))) + (let ((b 1)) + (define u1 (unit-from-context b-sig)) + (let ((b 2)) + (define-values/invoke-unit u1 (import) (export b-sig)) + b))) (let ((x 1) (v 2)) (let-syntax ((s (syntax-rules () ((_) (list x v))))) (define-signature t (x (define-syntaxes (s) - (syntax-rules () - ((_) (list x v)))) + (syntax-rules () + ((_) (list x v)))) (define-values (v) (add1 x)))) (define-signature t2 (x (define-syntaxes (s) - (syntax-rules () - ((_) (list x v)))) - (define-values (v) (add1 x)))) + (syntax-rules () + ((_) (list x v)))) + (define-values (v) (add1 x)))) (define u3 (unit (import) (export t) - (define x 3))) + (define x 3))) (define u4 (unit (import) (export t2) - (define x 4))) + (define x 4))) (define (i u) (invoke-unit (compound-unit (import) (export) @@ -695,73 +787,73 @@ (v 6)) (let-syntax ((s (syntax-rules () ((_) (list x v))))) (test '(7 8 (7 8) 3 4 (3 4) 4 5 (4 5)) - (i (unit (import (prefix p: t) (prefix q: t2)) (export) + (i (unit (import (prefix p: t) (prefix q: t2)) (export) (define x 7) (define v 8) (define-syntax s (syntax-rules () ((_) (list x v)))) (list x v (s) p:x p:v (p:s) q:x q:v (q:s))))) (test '(5 6 (5 6) 3 4 (3 4) 4 5 (4 5)) - (i (unit (import (prefix p: t) (prefix q: t2)) (export) + (i (unit (import (prefix p: t) (prefix q: t2)) (export) (list x v (s) p:x p:v (p:s) q:x q:v (q:s))))))) (test '(7 8 (7 8) 3 4 (3 4) 4 5 (4 5)) - (i (unit (import (prefix p: t) (prefix q: t2)) (export) + (i (unit (import (prefix p: t) (prefix q: t2)) (export) (define x 7) (define v 8) (define-syntax s (syntax-rules () ((_) (list x v)))) (list x v (s) p:x p:v (p:s) q:x q:v (q:s))))) (test '(1 2 (1 2) 3 4 (3 4) 4 5 (4 5)) - (i (unit (import (prefix p: t) (prefix q: t2)) (export) + (i (unit (import (prefix p: t) (prefix q: t2)) (export) (list x v (s) p:x p:v (p:s) q:x q:v (q:s))))) ;; only (let ((x 5) (v 6)) (let-syntax ((s (syntax-rules () ((_) (list x v))))) (test '(7 8 (7 8) (3 4) (4 5)) - (i (unit (import (prefix p: (only t s)) (only (prefix q: t2) q:s)) (export) + (i (unit (import (prefix p: (only t s)) (only (prefix q: t2) q:s)) (export) (define x 7) (define v 8) (define-syntax s (syntax-rules () ((_) (list x v)))) (list x v (s) (p:s) (q:s))))) (test '(5 6 (5 6) (3 4) (4 5)) - (i (unit (import (prefix p: (only t s)) (prefix q: (only t2 s))) (export) + (i (unit (import (prefix p: (only t s)) (prefix q: (only t2 s))) (export) (list x v (s) (p:s) (q:s))))))) (test '(7 8 (7 8) (3 4) (4 5)) - (i (unit (import (only (prefix p: t) p:s) (only (prefix q: t2) q:s)) (export) + (i (unit (import (only (prefix p: t) p:s) (only (prefix q: t2) q:s)) (export) (define x 7) (define v 8) (define-syntax s (syntax-rules () ((_) (list x v)))) (list x v (s) (p:s) (q:s))))) (test '(1 2 (1 2) (3 4) (4 5)) - (i (unit (import (prefix p: (only t s)) (prefix q: (only t2 s))) (export) + (i (unit (import (prefix p: (only t s)) (prefix q: (only t2 s))) (export) (list x v (s) (p:s) (q:s))))) ;;rename (let ((x 5) (v 6)) (let-syntax ((s (syntax-rules () ((_) (list x v))))) (test '(7 8 (7 8) 3 4 (3 4) 4 5 (4 5)) - (i (unit (import (rename t (p:x x) (p:v v) (p:s s)) - (rename t2 (q:x x) (q:v v) (q:s s))) + (i (unit (import (rename t (p:x x) (p:v v) (p:s s)) + (rename t2 (q:x x) (q:v v) (q:s s))) (export) (define x 7) (define v 8) (define-syntax s (syntax-rules () ((_) (list x v)))) (list x v (s) p:x p:v (p:s) q:x q:v (q:s))))) (test '(5 6 (5 6) 3 4 (3 4) 4 5 (4 5)) - (i (unit (import (rename t (p:x x) (p:v v) (p:s s)) - (rename t2 (q:x x) (q:v v) (q:s s))) + (i (unit (import (rename t (p:x x) (p:v v) (p:s s)) + (rename t2 (q:x x) (q:v v) (q:s s))) (export) (list x v (s) p:x p:v (p:s) q:x q:v (q:s))))))) (test '(7 8 (7 8) 3 4 (3 4) 4 5 (4 5)) - (i (unit (import (rename t (p:x x) (p:v v) (p:s s)) - (rename t2 (q:x x) (q:v v) (q:s s))) + (i (unit (import (rename t (p:x x) (p:v v) (p:s s)) + (rename t2 (q:x x) (q:v v) (q:s s))) (export) (define x 7) (define v 8) (define-syntax s (syntax-rules () ((_) (list x v)))) (list x v (s) p:x p:v (p:s) q:x q:v (q:s))))) (test '(1 2 (1 2) 3 4 (3 4) 4 5 (4 5)) - (i (unit (import (rename t (p:x x) (p:v v) (p:s s)) - (rename t2 (q:x x) (q:v v) (q:s s))) + (i (unit (import (rename t (p:x x) (p:v v) (p:s s)) + (rename t2 (q:x x) (q:v v) (q:s s))) (export) (list x v (s) p:x p:v (p:s) q:x q:v (q:s)))))) ) @@ -777,10 +869,10 @@ (m a) (a 1))))) (test 1 - (invoke-unit - (compound-unit (import) (export) - (link (((X : x)) (unit (import) (export x))) - (() (unit (import x) (export) v) X)))))) + (invoke-unit + (compound-unit (import) (export) + (link (((X : x)) (unit (import) (export x))) + (() (unit (import x) (export) v) X)))))) (let () (define-signature x ((define-syntaxes (m) (syntax-rules () @@ -794,10 +886,10 @@ (m a) (m2 a))))) (test 1 - (invoke-unit - (compound-unit (import) (export) - (link (((X : x)) (unit (import) (export x))) - (() (unit (import x) (export) v) X)))))) + (invoke-unit + (compound-unit (import) (export) + (link (((X : x)) (unit (import) (export x))) + (() (unit (import x) (export) v) X)))))) (let () (define-signature x ((define-syntaxes (m) #'1) @@ -809,10 +901,10 @@ (let () (m2 m))))) (test 1 - (invoke-unit - (compound-unit (import) (export) - (link (((X : x)) (unit (import) (export x))) - (() (unit (import x) (export) v) X)))))) + (invoke-unit + (compound-unit (import) (export) + (link (((X : x)) (unit (import) (export x))) + (() (unit (import x) (export) v) X)))))) (let () @@ -821,8 +913,8 @@ (define u1 (unit (import s2) (export) (cons y z))) (define u2 (unit (import) (export s2) (define a 123))) (test (list 2 123 1) (invoke-unit (compound-unit (import) (export) - (link (((a : s2)) u2) - (() u1 a)))))) + (link (((a : s2)) u2) + (() u1 a)))))) (let () (define-signature s1 (a (define-values (x y) (values 1 2)))) (let ((x 12)) @@ -838,8 +930,8 @@ (define u1 (unit (import s2) (export) (define c 77) (cons y z))) (define u2 (unit (import) (export s2) (define a 123))) (test (list 2 123 50) (invoke-unit (compound-unit (import) (export) - (link (((a : s2)) u2) - (() u1 a)))))) + (link (((a : s2)) u2) + (() u1 a)))))) #; (let ([c 5]) (define-signature s1 (a (define-values (x y) (values c 2)))) @@ -850,96 +942,96 @@ (link (((a : s2)) u2) (() u1 a)))))) -;; Test define-syntaxes and define-values, without except, only, prefix and rename -;; Check the scoping -(let ((a 'abad) - (b 'bbad) - (c 'cbad) - (v1 'v1bad) - (v2 'v2bad) - (s1 's1bad) - (s2 's2bad) - (strange-fact 'sfbad) - (z 'zbad)) - (define z 1) - (define a 'abad2) - (define c 'cbad2) - (define strange-fact 'sfbad4) - (define-signature macro (a b c - (define-values (v1) (list a b c z 2)) - (define-values (v2) (s2 a b c)) - (define-values (strange-fact) - (lambda (x) - (if (= x 0) (list z a b c) (cons x (strange-fact (sub1 x)))))) - (define-syntaxes (s1 s2) - (values - (syntax-rules () - ((_ a1 b1 c1) (list a b c v1 a1 b1 c1 z))) - (syntax-rules () - ((_ a1 b1 c1) (s1 a1 b1 c1))))))) - (let ((b 'bbad2) - (c 'cbad3)) - (define z 3) - (define u1 - (unit (import macro) (export) - (define z 4) - (list a b c v1 v2 (strange-fact 5) (s1 6 7 8) (s2 9 10 11)))) - (define u2 - (unit (import) (export macro) - (define a 12) - (define b 13) - (define c 14))) - (test '(12 13 14 - (12 13 14 1 2) - (12 13 14 (12 13 14 1 2) 12 13 14 1) - (5 4 3 2 1 1 12 13 14) - (12 13 14 (12 13 14 1 2) 6 7 8 1) - (12 13 14 (12 13 14 1 2) 9 10 11 1)) - (invoke-unit - (compound-unit (import) (export) - (link (((U2 : macro)) u2) - (() u1 U2))))))) + ;; Test define-syntaxes and define-values, without except, only, prefix and rename + ;; Check the scoping + (let ((a 'abad) + (b 'bbad) + (c 'cbad) + (v1 'v1bad) + (v2 'v2bad) + (s1 's1bad) + (s2 's2bad) + (strange-fact 'sfbad) + (z 'zbad)) + (define z 1) + (define a 'abad2) + (define c 'cbad2) + (define strange-fact 'sfbad4) + (define-signature macro (a b c + (define-values (v1) (list a b c z 2)) + (define-values (v2) (s2 a b c)) + (define-values (strange-fact) + (lambda (x) + (if (= x 0) (list z a b c) (cons x (strange-fact (sub1 x)))))) + (define-syntaxes (s1 s2) + (values + (syntax-rules () + ((_ a1 b1 c1) (list a b c v1 a1 b1 c1 z))) + (syntax-rules () + ((_ a1 b1 c1) (s1 a1 b1 c1))))))) + (let ((b 'bbad2) + (c 'cbad3)) + (define z 3) + (define u1 + (unit (import macro) (export) + (define z 4) + (list a b c v1 v2 (strange-fact 5) (s1 6 7 8) (s2 9 10 11)))) + (define u2 + (unit (import) (export macro) + (define a 12) + (define b 13) + (define c 14))) + (test '(12 13 14 + (12 13 14 1 2) + (12 13 14 (12 13 14 1 2) 12 13 14 1) + (5 4 3 2 1 1 12 13 14) + (12 13 14 (12 13 14 1 2) 6 7 8 1) + (12 13 14 (12 13 14 1 2) 9 10 11 1)) + (invoke-unit + (compound-unit (import) (export) + (link (((U2 : macro)) u2) + (() u1 U2))))))) -;; We can re-define imported values -(let () - (define-signature s ((define-values (y) 1))) - (define-signature t (z)) + ;; We can re-define imported values + (let () + (define-signature s ((define-values (y) 1))) + (define-signature t (z)) (test 3 - (invoke-unit - (compound-unit (import) (export) - (link (((T : t)) (unit (import s) (export t) (define y 3) (define z y)) S) - (((S : s)) (unit (import) (export s) (define y 1))) - (() (unit (import t) (export) z) T)))))) + (invoke-unit + (compound-unit (import) (export) + (link (((T : t)) (unit (import s) (export t) (define y 3) (define z y)) S) + (((S : s)) (unit (import) (export s) (define y 1))) + (() (unit (import t) (export) z) T)))))) -;; Can't use imports as pattern variables -#;(let () + ;; Can't use imports as pattern variables + #;(let () (define-signature s (y (define-syntaxes (m) (syntax-rules (y) ((_ y) 1))))) (unit (import s) (export) - (m y))) + (m y))) -(test '(2 3) + (test '(2 3) + (let () + (define-signature sig (y (define-values (v) (add1 y)))) + (let () + (define-values/invoke-unit + (unit (import) (export sig) (define y 2)) + (import) + (export sig)) + (list y v)))) + + + ;; I'm not sure that this should work. + #;(test '(2 3) (let () - (define-signature sig (y (define-values (v) (add1 y)))) - (let () - (define-values/invoke-unit - (unit (import) (export sig) (define y 2)) - (import) - (export sig)) - (list y v)))) + (define-signature sig (y (define-values (v) (add1 y)))) + (define-values/invoke-unit + (unit (import) (export sig) (define y 2)) + sig) + (list y v))) -;; I'm not sure that this should work. -#;(test '(2 3) - (let () - (define-signature sig (y (define-values (v) (add1 y)))) - (define-values/invoke-unit - (unit (import) (export sig) (define y 2)) - sig) - (list y v))) - - ;; subtyping @@ -985,16 +1077,16 @@ (define u1 (unit (import) (export x-sig) (define x 1))) (define u2 (unit (import x-sub) (export))) - (test-runtime-error exn:fail:contract? "compound-unit: not a subtype" + (test-runtime-error exn:fail:contract? "compound-unit: this usage context expects a unit with an untagged export with signature x-sub, which the given unit does not supply" (compound-unit (import) (export) (link (((S : x-sub)) u1)))) - (test-runtime-error exn:fail:contract? "compound-unit: not a subtype" + (test-runtime-error exn:fail:contract? "compound-unit: unit argument expects an untagged import with signature x-sub, which this usage context does not supply" (compound-unit (import) (export) (link (((S : x-sig)) u1) (() u2 S)))) - (test-runtime-error exn:fail:contract? "compound-unit: not a subtype" + (test-runtime-error exn:fail:contract? "compound-unit: unit argument expects an untagged import with signature x-sub, which this usage context does not supply" (compound-unit (import (S : x-sig)) (export) (link (() u2 S))))) @@ -1002,43 +1094,46 @@ (define u1 (unit (import) (export x-sub y-sub) (define x 1) (define xx 2) (define y 3) (define yy 4))) (define-values/invoke-unit u1 (import) (export x-sig)) (test 1 x) - (test-runtime-error exn? "unbound identifier" xx) - (test-runtime-error exn? "unbound identifier" y) - (test-runtime-error exn? "unbound identifier" yy)) + (test-runtime-error exn? "xx: undefined;\n cannot reference undefined identifier" xx) + (test-runtime-error exn? "y: undefined;\n cannot reference undefined identifier" y) + (test-runtime-error exn? "yy: undefined;\n cannot reference undefined identifier" yy)) (let () (define u1 (unit (import) (export x-sig) (define x 1))) - (test-runtime-error exn:fail:contract? "define-values/invoke-unit: not a subtype" + (test-runtime-error exn:fail:contract? "define-values/invoke-unit: this usage context expects a unit with an untagged export with signature x-sub, which the given unit does not supply" (define-values/invoke-unit u1 (import) (export x-sub)))) ;; export-subtyping -(test-syntax-error "duplicate exports (subtypes)" - (unit (import) (export x-sig x-sub) - (define x 1) - (define xx 1))) -(test-syntax-error "duplicate exports (subtypes)" - (unit (import) (export x-sub x-sig) - (define x 1) - (define xx 1))) +(test-syntax-error + "unit: the signature of x-sub extends this signature" + (unit (import) (export x-sig x-sub) + (define x 1) + (define xx 1))) +(test-syntax-error + "unit: the signature of x-sub extends this signature" + (unit (import) (export x-sub x-sig) + (define x 1) + (define xx 1))) (let () (define u (unit (import) (export x-sub) (define x 1) (define xx 1))) - (test-syntax-error "duplicate exports (subtypes)" - (compound-unit (import) (export l1 l2) - (link (((l1 : s1)) u) - (((l2 : s2)) u))))) + (test-syntax-error + "compound-unit: unknown signature" + (compound-unit (import) (export l1 l2) + (link (((l1 : s1)) u) + (((l2 : s2)) u))))) (let () (define u (unit (import) (export x-sub (prefix x: x-sub2)) - (define x 1) - (define xx 2) - (define x:x 3) - (define x:x2 4))) + (define x 1) + (define xx 2) + (define x:x 3) + (define x:x2 4))) (define u2 (unit (import x-sig) (export))) (define v (unit (import x-sub) (export) - (+ x xx))) + (+ x xx))) (define w (unit (import x-sub2) (export) - (+ x x2))) + (+ x x2))) (define u3 (unit (import x-sub (prefix m: x-sub2)) (export) - (+ x xx m:x m:x2))) + (+ x xx m:x m:x2))) (test 3 (invoke-unit (compound-unit (import) (export) @@ -1054,18 +1149,20 @@ (compound-unit (import) (export) (link (((S3 : x-sub2) (S2 : x-sub)) u) (() u3 S3 S2))))) - (test-runtime-error exn:fail:contract? "ambiguous export" + (test-runtime-error exn:fail:contract? + "compound-unit: this usage context expects a unit with an untagged export with signature x-sig, which the given unit supplies multiple times" (compound-unit (import) (export) - (link (((S1 : x-sig)) u))))) - (test-runtime-error exn:fail:contract? "ambiguous import" + (link (((S1 : x-sig)) u)))) + (test-runtime-error exn:fail:contract? "compound-unit: unit argument expects an untagged import with signature x-sig, which this usage context supplies multiple times" (compound-unit (import (S1 : x-sub) (S2 : x-sub2)) (export) (link (() u2 S1 S2)))) -(test-syntax-error "duplicate links (subtype)" - (compound-unit (import) (export) - (link (((S1 : x-sig)) u3) - (() u1 S2 S1) - (((S2 : x-sig)) u3)))) + (test-syntax-error + "compound-unit: the signature of S2 extends this signature" + (compound-unit (import) (export) + (link (((S1 : x-sig)) u3) + (() u1 S2 S1) + (((S2 : x-sig)) u3))))) ;; tags (let () @@ -1078,44 +1175,44 @@ (tag t (prefix s2: s2)) (prefix bs1: s2) (prefix bs2: s3)) - (export) - (list s1:a s2:a s2:b bs1:a bs2:b))) + (export) + (list s1:a s2:a s2:b bs1:a bs2:b))) (define u2 (unit (import) (export s3) - (define a 1) (define b 2))) + (define a 1) (define b 2))) (define u3 (unit (import) (export s2) - (define a 3) (define b 4))) + (define a 3) (define b 4))) (test '(1 3 4 1 2) (invoke-unit (compound-unit (import) (export) (link (((S2a : s3)) u2) (((S2b : s2)) u3) (() u1 S2a (tag t S2b)))))) - (test-runtime-error exn:fail:contract? "compound-unit: signature mismatch" - (invoke-unit - (compound-unit (import) (export) - (link (((S1 : s1)) u2) - (((S2 : s2)) u3) - (() u1 (tag t S1) S2)))))) + (test-runtime-error exn:fail:contract? "compound-unit: unit argument expects an untagged import with signature s3, which this usage context does not supply" + (invoke-unit + (compound-unit (import) (export) + (link (((S1 : s1)) u2) + (((S2 : s2)) u3) + (() u1 (tag t S1) S2)))))) (let () (define u1 (unit (import) (export (prefix a: x-sig) (tag t (prefix c: x-sig))) - (define a:x 1) - (define c:x 4))) + (define a:x 1) + (define c:x 4))) (define u2 (unit (import x-sig) (export) - x)) + x)) (define u3 (unit (import x-sub) (export) - (list x xx))) + (list x xx))) (test 4 (invoke-unit (compound-unit (import) (export) (link (((S1 : (tag t x-sig)) (S2 : x-sig)) u1) (() u2 S1))))) - (test-runtime-error exn:fail:contract? "compound-unit: signature mismatch" + (test-runtime-error exn:fail:contract? "compound-unit: this usage context expects a unit with an untagged export with signature x-sub, which the given unit does not supply" (invoke-unit (compound-unit (import) (export) (link (((S1 : (tag t x-sub)) (S2 : x-sub)) u1) @@ -1124,8 +1221,8 @@ (let () (define u1 (unit (import) (export (tag t1 x-sig) (prefix : x-sig)) - (define x 10) - (define :x 11))) + (define x 10) + (define :x 11))) (define-values/invoke-unit u1 (import) (export x-sig (tag t1 (prefix m x-sig)))) (test '(11 10) (list x mx))) @@ -1135,90 +1232,152 @@ (define-signature s2 (a x z)) -(test-syntax-error "unit-from-context: no sigs" - (unit-from-context)) -(test-syntax-error "unit-from-context: too many sigs" - (unit-from-context s1 s2)) -(test-syntax-error "unit-from-context: too many sigs" - (unit-from-context s1 . s2)) -(test-syntax-error "unit-from-context: bad sig" - (unit-from-context 1)) +(test-syntax-error + "unit-from-context: missing export-spec" + (unit-from-context)) +(test-syntax-error + "unit-from-context: nothing is permitted after export-spec" + (unit-from-context s1 s2)) +(test-syntax-error + "unit-from-context: nothing is permitted after export-spec" + (unit-from-context s1 . s2)) +(test-syntax-error + "unit-from-context: bad export spec" + (unit-from-context 1)) -(test-syntax-error "unit-from-context: no name" - (define-unit-from-context)) -(test-syntax-error "unit-from-context: no sigs" - (define-unit-from-context s1)) -(test-syntax-error "unit-from-context: no sigs" - (define-unit-from-context n)) -(test-syntax-error "unit-from-context: too many sigs" - (define-unit-from-context n s1 s2)) -(test-syntax-error "unit-from-context: too many sigs" - (define-unit-from-context n s1 . s2)) -(test-syntax-error "unit-from-context: bad sig" - (define-unit-from-context n 1)) +(test-syntax-error + "define-unit-from-context: missing unit name and signature" + (define-unit-from-context)) +(test-syntax-error + "define-unit-from-context: missing export-spec" + (define-unit-from-context s1)) +(test-syntax-error + "define-unit-from-context: missing export-spec" + (define-unit-from-context n)) +(test-syntax-error + "define-unit-from-context: nothing is permitted after export-spec" + (define-unit-from-context n s1 s2)) +(test-syntax-error + "define-unit-from-context: nothing is permitted after export-spec" + (define-unit-from-context n s1 . s2)) +(test-syntax-error + "define-unit-from-context: bad export spec" + (define-unit-from-context n 1)) ;; Test the struct form (test-syntax-error "struct: missing name and fields" - (define-signature x ((struct)))) -(test-syntax-error "struct: missing name" - (define-signature x ((struct n)))) -(test-syntax-error "struct: bad name" - (define-signature x ((struct 1 ())))) -(test-syntax-error "struct: bad fields (dot)" - (define-signature x ((struct n (x . y))))) -(test-syntax-error "struct: bad fields" - (define-signature x ((struct n 1)))) -(test-syntax-error "struct: bad omission" - (define-signature x ((struct n () t)))) -(test-syntax-error "struct: bad omission (dot)" - (define-signature x ((struct n () . -selectors)))) -(test-syntax-error "struct: bad omission" - (define-signature x ((struct n () x)))) + (define-signature x ((struct)))) +(test-syntax-error + "struct: bad syntax; missing fields" + (define-signature x ((struct n)))) +(test-syntax-error + "struct: expected an identifier to name the structure type" + (define-signature x ((struct 1 ())))) +(test-syntax-error + "struct: bad syntax; expected a parenthesized sequence of fields" + (define-signature x ((struct n (x . y))))) +(test-syntax-error + "struct: bad syntax; expected a parenthesized sequence of fields" + (define-signature x ((struct n 1)))) +(test-syntax-error + "struct: expected a keyword to specify option: #:mutable, #:constructor-name, #:extra-constructor-name, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values" + (define-signature x ((struct n () t)))) +(test-syntax-error + "struct: bad syntax" + (define-signature x ((struct n () . -selectors)))) +(test-syntax-error + "struct: expected a keyword to specify option: #:mutable, #:constructor-name, #:extra-constructor-name, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values" + (define-signature x ((struct n () x)))) (let () (define-signature sig ((struct s (x y)))) (test 3 - (invoke-unit - (compound-unit (import) (export) - (link (((S : sig)) (unit (import) (export sig) + (invoke-unit + (compound-unit (import) (export) + (link (((S : sig)) (unit (import) (export sig) (define-struct s (x y)))) - (() (unit (import sig) (export) - (match (make-s 1 2) + (() (unit (import sig) (export) + (match (s 1 2) ((struct s (a b)) (+ a b)))) - S))))) + S))))) (let () (define-values/invoke-unit (unit (import) (export sig) (define-struct s (x y))) (import) (export sig)) (test 3 - (match (make-s 1 2) - ((struct s (a b)) (+ a b))))) + (match (s 1 2) + ((struct s (a b)) (+ a b))))) + (let () + (define u + (unit (import) (export (rename sig (make-s/defaults s))) + (define-struct s (x y)) + (define (make-s/defaults x) + (make-s x 'default)))) + (define-values/invoke-unit u (import) (export sig)) + (test #t (s? (s 1)))) + + (let ((set-s-x! 1)) + (define-signature sig ((struct s (x y)))) + (test 1 + (invoke-unit + (compound-unit (import) (export) + (link (((S : sig)) (unit (import) (export sig) (define-struct s (x y)))) + (() (unit (import sig) (export) + set-s-x!) S)))))) + ;; TODO: Pending bug fix in units + #;(let ((s 1)) + (define-signature sig ((struct s (x y) #:omit-constructor))) + (test 1 + (invoke-unit + (compound-unit (import) (export) + (link (((S : sig)) (unit (import) (export sig) (define-struct s (x y)))) + (() (unit (import sig) (export) + s) S))))))) +(let () + (local-require scheme/unit) + (define-signature sig ((struct s (x y)))) + (test 3 + (invoke-unit + (compound-unit (import) (export) + (link (((S : sig)) (unit (import) (export sig) + (define-struct s (x y)))) + (() (unit (import sig) (export) + (match (make-s 1 2) + ((struct s (a b)) (+ a b)))) + S))))) + (let () + (define-values/invoke-unit (unit (import) (export sig) (define-struct s (x y))) + (import) + (export sig)) + (test 3 + (match (make-s 1 2) + ((struct s (a b)) (+ a b))))) (let () (define u (unit (import) (export (rename sig (make-s/defaults make-s))) - (define-struct s (x y)) - (define (make-s/defaults x) - (make-s x 'default)))) + (define-struct s (x y)) + (define (make-s/defaults x) + (make-s x 'default)))) (define-values/invoke-unit u (import) (export sig)) (test #t (s? (make-s 1)))) (let ((set-s-x! 1)) (define-signature sig ((struct s (x y)))) (test 1 - (invoke-unit - (compound-unit (import) (export) - (link (((S : sig)) (unit (import) (export sig) (define-struct s (x y)))) - (() (unit (import sig) (export) + (invoke-unit + (compound-unit (import) (export) + (link (((S : sig)) (unit (import) (export sig) (define-struct s (x y)))) + (() (unit (import sig) (export) set-s-x!) S)))))) (let ((make-s 1)) (define-signature sig ((struct s (x y) #:omit-constructor))) (test 1 - (invoke-unit - (compound-unit (import) (export) - (link (((S : sig)) (unit (import) (export sig) (define-struct s (x y)))) - (() (unit (import sig) (export) + (invoke-unit + (compound-unit (import) (export) + (link (((S : sig)) (unit (import) (export sig) (define-struct s (x y)))) + (() (unit (import sig) (export) make-s) S))))))) ;; Dependencies @@ -1227,41 +1386,43 @@ (define-signature s2 extends s1 ()) (define u1 (unit (import s1) (export) (init-depend s1) - a)) + a)) (define u2 (unit (import) (export s1) - (define a 12))) + (define a 12))) (define u3 (unit (import (tag t s1)) (export) (init-depend (tag t s1)) - a)) + a)) (define u4 (compound-unit (import (L : s2)) (export) (link (() u1 L)))) (define u5 (unit (import) (export s2) - (define a 12))) -(test-syntax-error "unit: bad dependency" - (unit (import (tag t s1)) (export) (init-depend s1))) -(test-syntax-error "unit: bad dependency" - (unit (import s1) (export) (init-depend (tag t s1)))) + (define a 12))) +(test-syntax-error + "unit: initialization dependency on unknown import" + (unit (import (tag t s1)) (export) (init-depend s1))) +(test-syntax-error + "unit: initialization dependency on unknown import" + (unit (import s1) (export) (init-depend (tag t s1)))) (test 12 (invoke-unit (compound-unit (import) (export) (link (((S1 : s1)) u2) (() u1 S1))))) -(test-runtime-error exn:fail:contract? "Dependency violation" +(test-runtime-error exn:fail:contract? "compound-unit: untagged initialization dependent signature s1 is supplied from a later unit with link S1" (compound-unit (import) (export) - (link (() u1 S1) - (((S1 : s1)) u2)))) + (link (() u1 S1) + (((S1 : s1)) u2)))) -(test-runtime-error exn:fail:contract? "Dependency violation" +(test-runtime-error exn:fail:contract? "compound-unit: initialization dependent signature s1 with tag t is supplied from a later unit with link S1" (compound-unit (import) (export) - (link (() u3 (tag t S1)) - (((S1 : s1)) u2)))) + (link (() u3 (tag t S1)) + (((S1 : s1)) u2)))) -(test-runtime-error exn:fail:contract? "Dependency violation" +(test-runtime-error exn:fail:contract? "compound-unit: untagged initialization dependent signature s1 is supplied from a later unit with link S2" (compound-unit (import) (export) - (link (() u4 S2) - (((S2 : s2)) u5)))) + (link (() u4 S2) + (((S2 : s2)) u5)))) ;; Inference @@ -1276,119 +1437,144 @@ (link (((A : x-sig) (B : y-sig)) v) (() u A B)))))) -(test-runtime-error exn:fail:contract? "not subunit" +(test-runtime-error exn:fail:contract? "define-unit-binding: this usage context expects a unit with an untagged export with signature x-sig, which the given unit does not supply" (let () (define-unit-binding u2 u (import x-sig) (export x-sig)) 1)) -(test-runtime-error exn:fail:contract? "not subunit" +(test-runtime-error exn:fail:contract? "define-unit-binding: unit argument expects an untagged import with signature x-sig, which this usage context does not supply" (let () (define-unit-binding u2 u (import) (export)) 1)) (test-runtime-error exn:fail:contract? "not a unit" (let () (define-unit-binding u2 1 (import) (export)) 1)) (test-syntax-error "define-unit-binding: duplicate import" (define-unit-binding u 1 (import x-sig x-sig) (export))) -(test-syntax-error "define-unit-binding: export subtypes" - (define-unit-binding u 1 (import) (export x-sig x-sub))) -(test-syntax-error "define-unit-binding: export subtypes" - (define-unit-binding u 1 (import) (export x-sub x-sig))) -(test-syntax-error "define-unit-binding: bad dependency" - (define-unit-binding u 1 (import x-sig) (export) (init-depend x-sub))) -(test-syntax-error "define-unit-binding: bad dependency" - (define-unit-binding u 1 (import x-sub) (export) (init-depend x-sig))) +(test-syntax-error + "define-unit-binding: the signature of x-sub extends this signature" + (define-unit-binding u 1 (import) (export x-sig x-sub))) +(test-syntax-error + "define-unit-binding: the signature of x-sub extends this signature" + (define-unit-binding u 1 (import) (export x-sub x-sig))) +(test-syntax-error + "define-unit-binding: initialization dependency on unknown import" + (define-unit-binding u 1 (import x-sig) (export) (init-depend x-sub))) +(test-syntax-error + "define-unit-binding: initialization dependency on unknown import" + (define-unit-binding u 1 (import x-sub) (export) (init-depend x-sig))) -(test-syntax-error "define-unit: missing name, import, export" - (define-unit)) -(test-syntax-error "define-unit: missing import, export" - (define-unit a)) +(test-syntax-error + "define-unit: missing unit name, import clause, and export clause" + (define-unit)) +(test-syntax-error + "define-unit: missing import and export clauses" + (define-unit a)) (test-syntax-error "define-unit: missing export" - (define-unit a (import))) -(test-syntax-error "define-unit: missing name" - (define-unit (import) (export))) -(test-syntax-error "define-unit: bad name" - (define-unit "x" (import) (export))) -(test-syntax-error "define-unit: bad syntax" - (define-unit x (unit (import) (export)))) -(test-runtime-error exn:fail:contract? "define-unit: bad set!" - (let () - (define-signature s ()) - (define-unit x (import) (export) 1) - (set! x (unit (import s) (export) 1)))) -(test-runtime-error exn:fail:contract? "define-unit: bad set!" - (let () - (define-signature s ()) - (define-unit x (import) (export s) 1) - (set! x (unit (import) (export) 1)))) + (define-unit a (import))) +(test-syntax-error + "define-unit: not an identifier" + (define-unit (import) (export))) +(test-syntax-error + "define-unit: not an identifier" + (define-unit "x" (import) (export))) +(test-syntax-error + "define-unit: import clause must start with keyword \"import\"" + (define-unit x (unit (import) (export)))) +(test-runtime-error exn:fail:contract? "set!: unit argument expects an untagged import with signature s, which this usage context does not supply" + (let () + (define-signature s ()) + (define-unit x (import) (export) 1) + (set! x (unit (import s) (export) 1)))) +(test-runtime-error exn:fail:contract? "set!: this usage context expects a unit with an untagged export with signature s, which the given unit does not supply" + (let () + (define-signature s ()) + (define-unit x (import) (export s) 1) + (set! x (unit (import) (export) 1)))) (test-syntax-error "define-compound-unit: missing import" - (define-compound-unit x)) -(test-syntax-error "define-compound-unit: missing name" - (define-compound-unit)) -(test-syntax-error "define-compound-unit: missing name" - (define-compound-unit (import) (link) (export))) -(test-syntax-error "define-compound-unit: bad name" - (define-compound-unit 1 (import) (link) (export))) + (define-compound-unit x)) +(test-syntax-error + "define-compound-unit: missing unit name" + (define-compound-unit)) +(test-syntax-error + "define-compound-unit: not an identifier" + (define-compound-unit (import) (link) (export))) +(test-syntax-error + "define-compound-unit: not an identifier" + (define-compound-unit 1 (import) (link) (export))) -(test-syntax-error "invoke-unit/infer : no unit" - (invoke-unit/infer)) -(test-syntax-error "invoke-unit/infer : not a unit" - (invoke-unit/infer 1)) -(test-syntax-error "invoke-unit/infer : not a unit" - (let ([x 1]) (invoke-unit/infer x))) -(test-syntax-error "invoke-unit/infer : not a unit" - (let-syntax ([x 1]) (invoke-unit/infer x))) -(test-syntax-error "invoke-unit/infer: too much" - (invoke-unit/infer x y)) +(test-syntax-error + "invoke-unit/infer: missing unit" + (invoke-unit/infer)) +(test-syntax-error + "invoke-unit/infer: not an identifier" + (invoke-unit/infer 1)) +(test-syntax-error + "invoke-unit/infer: unknown unit definition" + (let ([x 1]) (invoke-unit/infer x))) +(test-syntax-error + "invoke-unit/infer: not a unit definition" + (let-syntax ([x 1]) (invoke-unit/infer x))) +(test-syntax-error + "invoke-unit/infer: expected syntax matching (invoke-unit/infer ) or (invoke-unit/infer (link ...))" + (invoke-unit/infer x y)) (define-unit u (import x-sig) (export)) (define-unit v (import) (export x-sig) (define x 3)) -(test-syntax-error "invoke-unit/infer : no unit" - (invoke-unit/infer (link))) -(test-syntax-error "invoke-unit/infer : not a unit" - (invoke-unit/infer (link 1 u))) -(test-syntax-error "invoke-unit/infer : not a unit" - (let ([x 1]) (invoke-unit/infer (link u x)))) -(test-syntax-error "invoke-unit/infer : not a unit" - (let-syntax ([x 1]) (invoke-unit/infer (link x u)))) +(test-syntax-error + "invoke-unit/infer: no units in link clause" + (invoke-unit/infer (link))) +(test-syntax-error + "invoke-unit/infer: not an identifier" + (invoke-unit/infer (link 1 u))) +(test-syntax-error + "invoke-unit/infer: unknown unit definition" + (let ([x 1]) (invoke-unit/infer (link u x)))) +(test-syntax-error + "invoke-unit/infer: not a unit definition" + (let-syntax ([x 1]) (invoke-unit/infer (link x u)))) (invoke-unit/infer (link u v)) -(test-syntax-error "define-values/invoke-unit/infer: no unit" - (define-values/invoke-unit/infer)) +(test-syntax-error + "define-values/invoke-unit/infer: missing unit" + (define-values/invoke-unit/infer)) +(test-syntax-error + "define-values/invoke-unit/infer: not an identifier" + (define-values/invoke-unit/infer 1)) +(test-syntax-error + "define-values/invoke-unit/infer: unknown unit definition" + (let ((x 1)) + (define-values/invoke-unit/infer x))) (test-syntax-error "define-values/invoke-unit/infer: not a unit" - (define-values/invoke-unit/infer 1)) -(test-syntax-error "define-values/invoke-unit/infer: not a unit" - (let ((x 1)) - (define-values/invoke-unit/infer x))) -(test-syntax-error "define-values/invoke-unit/infer: not a unit" - (let-syntax ((x 1)) - (define-values/invoke-unit/infer x))) -(test-syntax-error "define-values/invoke-unit/infer: too much" - (define-values/invoke-unit/infer x y)) + (let-syntax ((x 1)) + (define-values/invoke-unit/infer x))) +(test-syntax-error + "define-values/invoke-unit/infer: expected syntax matching (define-values/invoke-unit/infer [(export )] ) or (define-values/invoke-unit/infer [(export )] (link ...))" + (define-values/invoke-unit/infer x y)) (define-unit u (import x-sig) (export) x) (define-unit v (import) (export x-sig) (define x 3)) (test-syntax-error "define-values/invoke-unit/infer: no unit" - (define-values/invoke-unit/infer (link))) + (define-values/invoke-unit/infer (link))) +(test-syntax-error + "define-values/invoke-unit/infer: not an identifier" + (define-values/invoke-unit/infer (link 1 u))) +(test-syntax-error + "define-values/invoke-unit/infer: unknown unit definition" + (let ([x 1]) + (define-values/invoke-unit/infer (link u x)))) (test-syntax-error "define-values/invoke-unit/infer: not a unit" - (define-values/invoke-unit/infer (link 1 u))) -(test-syntax-error "define-values/invoke-unit/infer: not a unit" - (let ([x 1]) - (define-values/invoke-unit/infer (link u x)))) -(test-syntax-error "define-values/invoke-unit/infer: not a unit" - (let-syntax ([x 1]) - (define-values/invoke-unit/infer (link u x)))) + (let-syntax ([x 1]) + (define-values/invoke-unit/infer (link u x)))) (test-runtime-error - exn:fail:contract:variable? - "undefined" + exn:fail:contract:variable? "undefined" (let () (define-values/invoke-unit/infer (link u v)) x)) (test-runtime-error - exn:fail:contract:variable? - "undefined" + exn:fail:contract:variable? "undefined" (let () (define-values/invoke-unit/infer (export x-sig) (link u v)) x)) @@ -1396,19 +1582,22 @@ (let () (define-values/invoke-unit/infer (export x-sig) v) x) -(test-syntax-error "define-values/invoke-unit/infer: doesn't export y" - (define-values/invoke-unit/infer (export y-sig) (link u v))) +(test-syntax-error + "define-values/invoke-unit/infer: no subunit exports signature y-sig" + (define-values/invoke-unit/infer (export y-sig) (link u v))) -(test-runtime-error exn? "define-values/invoke-unit/infer: unbound variable: x" - (let () - (define-values/invoke-unit/infer (export) (link u v)) - x)) -(test-syntax-error "define-values/invoke-unit/infer: doesn't export y" - (define-values/invoke-unit/infer (export y-sig) v)) -(test-runtime-error exn? "define-values/invoke-unit/infer: unbound variable: x" - (let () - (define-values/invoke-unit/infer (export) v) - x)) +(test-runtime-error exn? "x: undefined" + (let () + (define-values/invoke-unit/infer (export) (link u v)) + x)) +(test-syntax-error + "define-values/invoke-unit/infer: no subunit exports signature y-sig" + (define-values/invoke-unit/infer (export y-sig) v)) +(test-runtime-error exn? + "x: undefined" + (let () + (define-values/invoke-unit/infer (export) v) + x)) (let () (define-signature s^ (a)) @@ -1423,37 +1612,64 @@ (export s^) (define a 2)) (define-values/invoke-unit/infer (export) (link v@ u@)) - (test-syntax-error "define-values/invoke-unit/infer: init-depend broken" - (define-values/invoke-unit/infer (export) (link u@ v@)))) + (void)) -(define-unit u (import x-sig) (export) x) -(test-syntax-error "define-values/invoke-unit/infer: bad imports" - (define-values/invoke-unit/infer u)) -(define-unit u (import x-sig y-sig) (export)) -(test-syntax-error "define-values/invoke-unit/infer: bad imports" - (define-values/invoke-unit/infer u)) +(test-syntax-error + + "define-values/invoke-unit/infer: unit depends on initialization of later unit" + (let () + (define-signature s^ (a)) + (define-signature t^ (b)) + (define-unit u@ + (import s^) + (export t^) + (init-depend s^) + (define b a)) + (define-unit v@ + (import) + (export s^) + (define a 2)) + (define-values/invoke-unit/infer (export) (link u@ v@)) + (void))) + +(test-syntax-error + + "x: unbound identifier in module" + (module foo racket + (define-signature x-sig (x)) + (define-unit u (import x-sig) (export) x) + (define-values/invoke-unit/infer u))) + +(test-syntax-error + + "y: unbound identifier in module" + (module foo racket + (define-signature x-sig (x)) + (define-signature y-sig (y)) + (define-unit u (import x-sig y-sig) (export)) + (define-values/invoke-unit/infer u))) (define-unit u (import) (export x-sig y-sig) (define x 10) (define y 20)) (test 30 - (let () - (define-values/invoke-unit/infer u) - (+ y x))) + (let () + (define-values/invoke-unit/infer u) + (+ y x))) (test 1 - (let () - (define-unit x (import) (export) 1) - (invoke-unit x))) + (let () + (define-unit x (import) (export) 1) + (invoke-unit x))) (test 1 - (let () - (define-unit x (import) (export) 1) - (let ((u 1)) - (invoke-unit x)))) + (let () + (define-unit x (import) (export) 1) + (let ((u 1)) + (invoke-unit x)))) (test 2 - (let () - (define-unit x (import) (export) 1) - (set! x (unit (import) (export) 2)) - (invoke-unit x))) + (let () + (define-unit x (import) (export) 1) + (set! x (unit (import) (export) 2)) + (invoke-unit x))) @@ -1472,19 +1688,24 @@ (test-syntax-error "compound-unit/infer: missing export" - (compound-unit/infer (link) (import))) -(test-syntax-error "compound-unit/infer: bad unit" - (compound-unit/infer (import) (export) (link 1))) -(test-syntax-error "compound-unit/infer: bad import" - (compound-unit/infer (import (a : b)) (export) (link))) -(test-syntax-error "compound-unit/infer: bad link" - (compound-unit/infer (import) (export) (link (((A : b)) c)))) + (compound-unit/infer (link) (import))) +(test-syntax-error + "compound-unit/infer: bad linking line" + (compound-unit/infer (import) (export) (link 1))) +(test-syntax-error + "compound-unit/infer: unknown signature" + (compound-unit/infer (import (a : fake-signature)) (export) (link))) +(test-syntax-error + "compound-unit/infer: unknown unit definition" + (compound-unit/infer (import) (export) (link (((A : b)) c)))) +(test-syntax-error +"compound-unit/infer: unknown signature" + (compound-unit/infer (import ??) (export) (link))) (test-syntax-error "compound-unit/infer: unknown sig" - (compound-unit/infer (import ??) (export) (link))) -(test-syntax-error "compound-unit/infer: unknown sig" - (compound-unit/infer (import) (export ??) (link))) -(test-syntax-error "compound-unit/infer: unknown sig" - (compound-unit/infer (import) (export) (link (() u ??)))) + (compound-unit/infer (import) (export ??) (link))) +(test-syntax-error + "compound-unit/infer: unknown linking identifier" + (compound-unit/infer (import) (export) (link (() u ??)))) (define-unit x @@ -1516,14 +1737,44 @@ (export) (+ x y z)) -(test-syntax-error "compound-unit/infer: re-export" - (compound-unit/infer (import (l : x-sig)) (export x-sig) (link))) -(test-syntax-error "compound-unit/infer: duplicate def and import" - (compound-unit/infer (import y-sig x-sig) (export) (link x y))) -(test-syntax-error "compound-unit/infer: unprovided sig" - (compound-unit/infer (import) (export) (link x))) -(test-syntax-error "compound-unit/infer: unprovided sig" - (compound-unit/infer (import) (export x-sig) (link))) +(test-syntax-error + + "compound-unit/infer: cannot directly export an import" + (module foo racket + (define-signature x-sig (x)) + (compound-unit/infer (import (l : x-sig)) (export x-sig) (link)))) +(test-syntax-error + + "compound-unit/infer: multiple linkages satisfy untagged x-sig import" + (module foo racket + (define-signature x-sig (x)) + (define-signature y-sig (y)) + (define-unit x + (import x-sig) + (export y-sig) + (define y x) + y) + (define-unit y + (import y-sig) + (export (rename x-sig (x x))) + (define x y) + x) + (compound-unit/infer (import y-sig x-sig) (export) (link x y)))) +(test-syntax-error + "compound-unit/infer: no linkages satisfy untagged x-sig import" + (module foo racket + (define-signature x-sig (x)) + (define-signature y-sig (y)) + (define-unit x + (import x-sig) + (export y-sig) + (define y x) + y) + (compound-unit/infer (import) (export) (link x)))) +(test-syntax-error + + "compound-unit/infer: no sub unit exports this signature" + (compound-unit/infer (import) (export x-sig) (link))) (test-runtime-error exn:fail:contract:variable? @@ -1533,16 +1784,16 @@ (link x y)))) (test 3 - (let () - (define-signature s (x y)) - (let ((x 1) - (y 2)) - (define-unit-from-context u1 s) - (define-unit u2 (import (prefix : s)) (export) - (+ :x :y)) - (invoke-unit - (compound-unit/infer (import) (export) - (link u1 u2)))))) + (let () + (define-signature s (x y)) + (let ((x 1) + (y 2)) + (define-unit-from-context u1 s) + (define-unit u2 (import (prefix : s)) (export) + (+ :x :y)) + (invoke-unit + (compound-unit/infer (import) (export) + (link u1 u2)))))) (test 6 (invoke-unit (compound-unit/infer (import) (export) @@ -1589,335 +1840,348 @@ (test 12 x)) -(let () - (define-unit u (import) (export x-sig) - (define x 12)) - (define-unit u2 (import) (export x-sig) - (define x 13)) - (define-unit v (import) (export y-sig) - (define y 11)) - (define-unit v2 (import) (export y-sig) - (define y 1)) - (define-unit u3 (import y-sig x-sig) (export) - (+ y x)) - (test 24 + (let () + (define-unit u (import) (export x-sig) + (define x 12)) + (define-unit u2 (import) (export x-sig) + (define x 13)) + (define-unit v (import) (export y-sig) + (define y 11)) + (define-unit v2 (import) (export y-sig) + (define y 1)) + (define-unit u3 (import y-sig x-sig) (export) + (+ y x)) + (test 24 + (invoke-unit + (compound-unit/infer (import) (export) + (link (((l : x-sig)) u) + (((l2 : x-sig)) u2) + (((l3 : y-sig)) v) + (((l4 : y-sig)) v2) + (() u3 l2 l3)))))) + + ;; unit/new-import-export + + (test-runtime-error exn:fail:contract? "unit/new-import-export: result of unit expression was not a unit: 1" + (unit/new-import-export (import) (export) + (() 1))) + + (test-runtime-error exn:fail:contract? "unit/new-import-export: this usage context expects a unit with an untagged export with signature x-sig, which the given unit does not supply" + (unit/new-import-export (import) (export) + ((x-sig) (unit (import) (export))))) + + + (test-runtime-error exn:fail:contract? "unit/new-import-export: unit argument expects an untagged import with signature x-sig, which this usage context does not supply" + (unit/new-import-export (import) (export) + (() (unit (import x-sig) (export))))) + + (define-unit u (import x-sig) (export y-sig) + (define y x)) + + (test-syntax-error + + "unit/new-import-export: identifier x is not present in new imports" + (module foo racket + (define-signature x-sig (x)) + (define-signature y-sig (y)) + (define-unit u (import x-sig) (export y-sig) + (define y x)) + (unit/new-import-export (import) (export x-sig) + ((y-sig) u x-sig)))) + + (test-syntax-error + + "unit/new-import-export: identifier z is not present in old exports" + (module foo racket + (define-signature x-sig (x)) + (define-signature y-sig (y)) + (define-signature z-sig (z)) + (define-unit u (import x-sig) (export y-sig) + (define y x)) + (unit/new-import-export (import x-sig) (export y-sig z-sig) + ((y-sig) u x-sig)))) + + (let () + (define-unit u + (import xy-sig) (export z-sig) + (define z (+ x y))) + (define-unit v + (import) (export x-sig y-sig) + (define x 4) + (define y 8)) + (define-unit w (import z-sig) (export) + z) + (define-unit/new-import-export u2 (import x-sig y-sig) (export z-sig) + ((z-sig) u xy-sig)) + (test 12 + (invoke-unit (compound-unit/infer (import) (export) + (link v u2 w))))) + + (let () + (define-unit u + (import x-sig y-sig) (export z-sig) + (define z (+ x y))) + (define-unit v + (import) (export xy-sig) + (define x 4) + (define y 8)) + (define-unit w (import z-sig) (export) + z) + (define-unit/new-import-export u2 (import xy-sig) (export z-sig) + ((z-sig) u y-sig x-sig)) + (test 12 + (invoke-unit (compound-unit/infer (import) (export) + (link v u2 w))))) + + (let () + (define-unit u + (import xy-sig) (export z-sig) + (define z (+ x y))) + (define-unit v + (import) (export x-sig y-sig) + (define x 4) + (define y 8)) + (define-unit w (import z-sig) (export) + z) + (define-unit/new-import-export v2 (import) (export xy-sig) + ((x-sig y-sig) v)) + (test 12 + (invoke-unit (compound-unit/infer (import) (export) + (link v2 u w))))) + + (let () + (define-unit u + (import x-sig y-sig) (export z-sig) + (define z (+ x y))) + (define-unit v + (import) (export xy-sig) + (define x 4) + (define y 8)) + (define-unit w (import z-sig) (export) + z) + (define-unit/new-import-export v2 (import) (export y-sig x-sig) + ((xy-sig) v)) + (test 12 + (invoke-unit (compound-unit/infer (import) (export) + (link v2 u w))))) + + + + + ;; open + (let () + (define-signature xzy + ((open x-sig) (open y-sig) (open z-sig))) + + (define-unit u (import xzy) (export) + (+ x z y)) + + (define-unit v (import) (export xzy) + (define x 10) + (define y 20) + (define z 30)) + + (test 60 + (invoke-unit (compound-unit/infer (import) (export) (link v u))))) + + (let ([x 1] + [y 2] + [z 3]) + (define-signature xzy + ((open x-sig) (open y-sig) (open z-sig))) + + (define-unit u (import xzy) (export) + (+ x z y)) + + (define-unit v (import) (export xzy) + (define x 10) + (define y 20) + (define z 30)) + + (test 60 + (invoke-unit (compound-unit/infer (import) (export) (link v u))))) + + (define-signature s + (x (define-values (y) (add1 x)))) + + (let ([x 1] + [y 10] + [s:x 100] + [s:y 1000]) + (define-signature s2 + ((open (prefix s: s)) x (define-values (y) (sub1 x)))) + (define-unit u1 (import s2) (export) + (list s:x s:y x y)) + (define-unit u2 (import) (export s2) + (define s:x 3) + (define x 19)) + (test '(3 4 19 18) + (invoke-unit (compound-unit/infer (import) (export) (link u2 u1))))) + + + (define-signature sig^ (u-a)) + + (define-unit unit@ + (import) + (export sig^) + + (define u-a 'zero)) + + (test 'zero + (let ([q:u-a 5]) + (define-values/invoke-unit unit@ (import) (export (prefix q: sig^))) + q:u-a)) + + (define-syntax (use-unit stx) + (syntax-case stx () + [(_) + #'(let () + (define-values/invoke-unit unit@ (import) (export sig^)) + u-a)])) + + (define-syntax (use-unit2 stx) + (syntax-case stx () + [(_) + #'(let () + (define-values/invoke-unit/infer unit@) + u-a)])) + + (define-syntax (use-unit-badly1 stx) + (syntax-case stx () + [(_ u-a) + #'(let () + (define-values/invoke-unit unit@ (import) (export sig^)) + u-a)])) + + (define-syntax (use-unit-badly2 stx) + (syntax-case stx () + [(_ sig^) + #'(let () + (define-values/invoke-unit unit@ (import) (export sig^)) + u-a)])) + + (test 'zero (use-unit)) + (test 'zero (use-unit2)) + (test-runtime-error exn:fail:contract:variable? "u-a: undefined;\n cannot reference undefined identifier" + (use-unit-badly1 u-a)) + (test-runtime-error exn:fail:contract:variable? "u-a: undefined;\n cannot reference undefined identifier" + (use-unit-badly2 sig^)) + + (test 12 + (let () + (define-signature s^ (x)) + (define-unit u@ + (import) + (export s^) + (define x 12)) + (define-values/invoke-unit u@ (import) (export s^)) + x)) + + ;; ---------------------------------------- + ;; May sure unit body expansion doesn't mangle context: + + (test 5 (invoke-unit - (compound-unit/infer (import) (export) - (link (((l : x-sig)) u) - (((l2 : x-sig)) u2) - (((l3 : y-sig)) v) - (((l4 : y-sig)) v2) - (() u3 l2 l3)))))) + (let ([x 5]) + (define-syntax-rule (m) x) + (unit (import) (export) + (define x 6) + (m))))) -;; unit/new-import-export - -(test-runtime-error exn:fail:contract? "unit/new-import-export: not a unit" - (unit/new-import-export (import) (export) - (() 1))) - -(test-runtime-error exn:fail:contract? "unit/new-import-export: not a subtype" - (unit/new-import-export (import) (export) - ((x-sig) (unit (import) (export))))) - - -(test-runtime-error exn:fail:contract? "unit/new-import-export: not a subtype" - (unit/new-import-export (import) (export) - (() (unit (import x-sig) (export))))) - -(define-unit u (import x-sig) (export y-sig) - (define y x)) - -(test-syntax-error "unit/new-import-export: not enough imports" - (unit/new-import-export (import) (export x-sig) - ((y-sig) u x-sig))) - -(test-syntax-error "unit/new-import-export: too many exports" - (unit/new-import-export (import x-sig) (export y-sig z-sig) - ((y-sig) u x-sig))) - -(let () - (define-unit u - (import xy-sig) (export z-sig) - (define z (+ x y))) - (define-unit v - (import) (export x-sig y-sig) - (define x 4) - (define y 8)) - (define-unit w (import z-sig) (export) - z) - (define-unit/new-import-export u2 (import x-sig y-sig) (export z-sig) - ((z-sig) u xy-sig)) - (test 12 - (invoke-unit (compound-unit/infer (import) (export) - (link v u2 w))))) - -(let () - (define-unit u - (import x-sig y-sig) (export z-sig) - (define z (+ x y))) - (define-unit v - (import) (export xy-sig) - (define x 4) - (define y 8)) - (define-unit w (import z-sig) (export) - z) - (define-unit/new-import-export u2 (import xy-sig) (export z-sig) - ((z-sig) u y-sig x-sig)) - (test 12 - (invoke-unit (compound-unit/infer (import) (export) - (link v u2 w))))) - -(let () - (define-unit u - (import xy-sig) (export z-sig) - (define z (+ x y))) - (define-unit v - (import) (export x-sig y-sig) - (define x 4) - (define y 8)) - (define-unit w (import z-sig) (export) - z) - (define-unit/new-import-export v2 (import) (export xy-sig) - ((x-sig y-sig) v)) - (test 12 - (invoke-unit (compound-unit/infer (import) (export) - (link v2 u w))))) - -(let () - (define-unit u - (import x-sig y-sig) (export z-sig) - (define z (+ x y))) - (define-unit v - (import) (export xy-sig) - (define x 4) - (define y 8)) - (define-unit w (import z-sig) (export) - z) - (define-unit/new-import-export v2 (import) (export y-sig x-sig) - ((xy-sig) v)) - (test 12 - (invoke-unit (compound-unit/infer (import) (export) - (link v2 u w))))) - - - - -;; open -(let () - (define-signature xzy - ((open x-sig) (open y-sig) (open z-sig))) - - (define-unit u (import xzy) (export) - (+ x z y)) - - (define-unit v (import) (export xzy) - (define x 10) - (define y 20) - (define z 30)) - - (test 60 - (invoke-unit (compound-unit/infer (import) (export) (link v u))))) - -(let ([x 1] - [y 2] - [z 3]) - (define-signature xzy - ((open x-sig) (open y-sig) (open z-sig))) - - (define-unit u (import xzy) (export) - (+ x z y)) - - (define-unit v (import) (export xzy) - (define x 10) - (define y 20) - (define z 30)) - - (test 60 - (invoke-unit (compound-unit/infer (import) (export) (link v u))))) - -(define-signature s - (x (define-values (y) (add1 x)))) - -(let ([x 1] - [y 10] - [s:x 100] - [s:y 1000]) - (define-signature s2 - ((open (prefix s: s)) x (define-values (y) (sub1 x)))) - (define-unit u1 (import s2) (export) - (list s:x s:y x y)) - (define-unit u2 (import) (export s2) - (define s:x 3) - (define x 19)) - (test '(3 4 19 18) - (invoke-unit (compound-unit/infer (import) (export) (link u2 u1))))) - - -(define-signature sig^ (u-a)) - -(define-unit unit@ - (import) - (export sig^) - - (define u-a 'zero)) - -(test 'zero - (let ([q:u-a 5]) - (define-values/invoke-unit unit@ (import) (export (prefix q: sig^))) - q:u-a)) - -(define-syntax (use-unit stx) - (syntax-case stx () - [(_) - #'(let () - (define-values/invoke-unit unit@ (import) (export sig^)) - u-a)])) - -(define-syntax (use-unit2 stx) - (syntax-case stx () - [(_) - #'(let () - (define-values/invoke-unit/infer unit@) - u-a)])) - -(define-syntax (use-unit-badly1 stx) - (syntax-case stx () - [(_ u-a) - #'(let () - (define-values/invoke-unit unit@ (import) (export sig^)) - u-a)])) - -(define-syntax (use-unit-badly2 stx) - (syntax-case stx () - [(_ sig^) - #'(let () - (define-values/invoke-unit unit@ (import) (export sig^)) - u-a)])) - -(test 'zero (use-unit)) -(test 'zero (use-unit2)) -(test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a" - (use-unit-badly1 u-a)) -(test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a" - (use-unit-badly2 sig^)) - -(test 12 - (let () - (define-signature s^ (x)) - (define-unit u@ - (import) - (export s^) - (define x 12)) - (define-values/invoke-unit u@ (import) (export s^)) - x)) - -;; ---------------------------------------- -;; May sure unit body expansion doesn't mangle context: - -(test 5 - (invoke-unit - (let ([x 5]) - (define-syntax-rule (m) x) - (unit (import) (export) - (define x 6) - (m))))) - -(test 5 - (invoke-unit - (let-syntax ([x (syntax-rules () - [(_) 5])]) - (define-syntax-rule (m) (x)) - (unit (import) (export) - (define (x) 6) - (m))))) - -;; ---------------------------------------- - -;; Make sure that right-hand side of a `define-values` -;; has the right scope, including in the case of -;; signature extension. -;; Based on examples from Dan Feltey. - -(parameterize ([current-namespace (make-base-namespace)]) - (eval - '(module scope-check/a-sig racket - (provide a^) - (define-signature a^ ((define-values (a) (+ b 1)))) - (define b 7))) - (eval - '(module scope-check/b-sig racket - (require 'scope-check/a-sig) - (provide result) - - (define-signature b^ extends a^ (b)) - - (define b-out@ (unit (import) (export b^) - (define b "BAD"))) - (define b-in@ - (unit (import b^) (export) a)) - (define result + (test 5 (invoke-unit - (compound-unit (import) (export) - (link (((B : b^)) b-out@) - (() b-in@ B))))))) - (test 8 (dynamic-require ''scope-check/b-sig 'result))) + (let-syntax ([x (syntax-rules () + [(_) 5])]) + (define-syntax-rule (m) (x)) + (unit (import) (export) + (define (x) 6) + (m))))) -(parameterize ([current-namespace (make-base-namespace)]) - (eval - '(module scope-check/a-sig racket - (provide a^) - (define-signature a^ ((define-values (a) (+ b 1)))) - (define b 7))) - (eval - '(module scope-check/b-sig racket - (require 'scope-check/a-sig) - (provide result) + ;; ---------------------------------------- - (define-signature b^ extends a^ ()) - (define b "BAD") + ;; Make sure that right-hand side of a `define-values` + ;; has the right scope, including in the case of + ;; signature extension. + ;; Based on examples from Dan Feltey. - (define b-out@ (unit (import) (export b^))) - (define b-in@ - (unit (import b^) (export) a)) - (define result - (invoke-unit - (compound-unit (import) (export) - (link (((B : b^)) b-out@) - (() b-in@ B))))))) - (test 8 (dynamic-require ''scope-check/b-sig 'result))) + (parameterize ([current-namespace (make-base-namespace)]) + (eval + '(module scope-check/a-sig racket + (provide a^) + (define-signature a^ ((define-values (a) (+ b 1)))) + (define b 7))) + (eval + '(module scope-check/b-sig racket + (require 'scope-check/a-sig) + (provide result) -;; ---------------------------------------- + (define-signature b^ extends a^ (b)) -(module check-define-values-invoke-unit-spec racket/base - (require racket/unit) + (define b-out@ (unit (import) (export b^) + (define b "BAD"))) + (define b-in@ + (unit (import b^) (export) a)) + (define result + (invoke-unit + (compound-unit (import) (export) + (link (((B : b^)) b-out@) + (() b-in@ B))))))) + (test 8 (dynamic-require ''scope-check/b-sig 'result))) - (define-signature a^ (foo)) - (define-signature b^ (bar)) + (parameterize ([current-namespace (make-base-namespace)]) + (eval + '(module scope-check/a-sig racket + (provide a^) + (define-signature a^ ((define-values (a) (+ b 1)))) + (define b 7))) + (eval + '(module scope-check/b-sig racket + (require 'scope-check/a-sig) + (provide result) - (define-unit works@ - (import) (export a^) (define foo 'foo)) - (define-values/invoke-unit/infer - (export (rename a^ [qux foo])) - works@) + (define-signature b^ extends a^ ()) + (define b "BAD") - (define-unit doesnt@ - (import) (export b^) (define bar 0)) - (define-unit work@ - (import b^) (export a^) (define foo bar)) - ;; No rename on export - (define-values/invoke-unit/infer - (export a^) - (link doesnt@ work@)) - ;; Rename on export - (define-values/invoke-unit/infer - (export (rename a^ [baz foo])) - (link doesnt@ work@)) + (define b-out@ (unit (import) (export b^))) + (define b-in@ + (unit (import b^) (export) a)) + (define result + (invoke-unit + (compound-unit (import) (export) + (link (((B : b^)) b-out@) + (() b-in@ B))))))) + (test 8 (dynamic-require ''scope-check/b-sig 'result))) - (provide results) - (define results (list foo baz))) + ;; ---------------------------------------- -(test '(0 0) (dynamic-require ''check-define-values-invoke-unit-spec 'results)) + (module check-define-values-invoke-unit-spec racket/base + (require racket/unit) -;; ---------------------------------------- + (define-signature a^ (foo)) + (define-signature b^ (bar)) -(displayln "tests passed") + (define-unit works@ + (import) (export a^) (define foo 'foo)) + (define-values/invoke-unit/infer + (export (rename a^ [qux foo])) + works@) + + (define-unit doesnt@ + (import) (export b^) (define bar 0)) + (define-unit work@ + (import b^) (export a^) (define foo bar)) + ;; No rename on export + (define-values/invoke-unit/infer + (export a^) + (link doesnt@ work@)) + ;; Rename on export + (define-values/invoke-unit/infer + (export (rename a^ [baz foo])) + (link doesnt@ work@)) + + (provide results) + (define results (list foo baz))) + + (test '(0 0) (dynamic-require ''check-define-values-invoke-unit-spec 'results)) + + ;; ---------------------------------------- diff --git a/racket/collects/racket/private/unit-contract-syntax.rkt b/racket/collects/racket/private/unit-contract-syntax.rkt index ceb24ad9e9..e4dcd8b2d9 100644 --- a/racket/collects/racket/private/unit-contract-syntax.rkt +++ b/racket/collects/racket/private/unit-contract-syntax.rkt @@ -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))) diff --git a/racket/collects/racket/private/unit-contract.rkt b/racket/collects/racket/private/unit-contract.rkt index 067f17462d..1c69a5bda4 100644 --- a/racket/collects/racket/private/unit-contract.rkt +++ b/racket/collects/racket/private/unit-contract.rkt @@ -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)) diff --git a/racket/collects/racket/unit.rkt b/racket/collects/racket/unit.rkt index 0704489c9f..c9e609c386 100644 --- a/racket/collects/racket/unit.rkt +++ b/racket/collects/racket/unit.rkt @@ -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)