403aaac7d4
The libraries moved were: - mzlib/control => racket/control - mzlib/date => racket/date - mzlib/deflate => file/gzip - mzlib/inflate => file/gunzip - mzlib/port => racket/port - mzlib/process => racket/system - mzlib/runtime-path => racket/runtime-path - mzlib/shared => racket/shared - mzlib/unit => racket/unit - mzlib/unit-exptime => racket/unit-exptime - mzlib/zip => file/zip The old modules in mzlib are now pointers to the new modules. These are all modules that were already redirected in the documentation.
1789 lines
64 KiB
Racket
1789 lines
64 KiB
Racket
(require (for-syntax racket/private/unit-compiletime
|
|
racket/private/unit-syntax))
|
|
(require "test-harness.rkt"
|
|
;unit
|
|
scheme/unit)
|
|
|
|
(define-syntax (lookup-sig-mac stx)
|
|
(parameterize ((error-syntax stx))
|
|
(syntax-case stx ()
|
|
((_ id)
|
|
#`#'#,(let ((s (lookup-signature #'id)))
|
|
(list (map syntax-local-introduce (signature-vars s))
|
|
(map (lambda (def)
|
|
(cons (map syntax-local-introduce (car def))
|
|
(syntax-local-introduce (cdr def))))
|
|
(signature-val-defs s))
|
|
(map (lambda (def)
|
|
(cons (map syntax-local-introduce (car def))
|
|
(syntax-local-introduce (cdr def))))
|
|
(signature-stx-defs s))))))))
|
|
|
|
(define-signature x-sig (x))
|
|
(define-signature x-sig2 (x))
|
|
(define-signature y-sig (y))
|
|
(define-signature z-sig (z))
|
|
|
|
(define-signature yz-sig (y z))
|
|
(define-signature xy-sig (x y))
|
|
(define-signature empty-sig ())
|
|
(define-signature b-sig (b))
|
|
|
|
(define-signature empty-sub extends empty-sig ())
|
|
|
|
(define-signature x-sub extends x-sig (xx))
|
|
(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)
|
|
|
|
;; 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) 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 "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))
|
|
|
|
|
|
;; 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)))))
|
|
|
|
;; define-signature
|
|
(test stx-bound-id=? #'((a b) () ())
|
|
(let ()
|
|
(define-signature x (a b))
|
|
(lookup-sig-mac x)))
|
|
(let ()
|
|
(define s7 (void))
|
|
(define h (void))
|
|
(define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7))))
|
|
(test stx-bound-id=? #'((s1 a b f) (((s2 s3) . s4) ((c d) . e) ((i) . j)) (((s5 s6) . (values #'s7 #'s7)) ((g) . #'h)))
|
|
(let ()
|
|
(define-signature x extends super (a b (define-values (c d) e) f
|
|
(define-syntaxes (g) #'h)
|
|
(define-values (i) j)))
|
|
(lookup-sig-mac x))))
|
|
(let ()
|
|
(define s7 (void))
|
|
(define h (void))
|
|
(define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7))))
|
|
(let ((a 1) (g 2) (j 3) (s1 4) (s2 5))
|
|
(test stx-bound-id=? #'(((#f . s1) a b f) ((((#f . s2) s3) . s4) ((c d) . e) ((i) . j)) (((s5 s6) . (values #'s7 #'s7)) ((g) . #'h)))
|
|
(let ()
|
|
(define-signature x extends super (a b (define-values (c d) e) f
|
|
(define-syntaxes (g) #'h)
|
|
(define-values (i) j)))
|
|
(lookup-sig-mac x)))))
|
|
(let ()
|
|
(define s7 (void))
|
|
(define h (void))
|
|
(define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7))))
|
|
(test stx-bound-id=? #'((s1 a b f) (((s2 s3) . s4) ((c d) . e) ((i) . j)) (((s5 s6) . (values #'s7 #'s7)) ((g) . #'h)))
|
|
(let ()
|
|
(define-signature x extends super (a b (define-values (c d) e) f
|
|
(define-syntaxes (g) #'h)
|
|
(define-values (i) j)))
|
|
(let ((a 1) (g 2) (j 3))
|
|
(lookup-sig-mac x)))))
|
|
(test stx-bound-id=? #'(((#f . a) b f) (((c d) . e) ((i) . (#f . j))) ((((#f . g)) . #'h)))
|
|
(let ((a 1) (g 2) (j 3))
|
|
(define-signature x (a b (define-values (c d) e) f
|
|
(define-syntaxes (g) #'h)
|
|
(define-values (i) j)))
|
|
(lookup-sig-mac x)))
|
|
(let ()
|
|
(define-signature-form (x y)
|
|
(list (cdr (syntax-e y))))
|
|
(test stx-bound-id=? #'((a)
|
|
()
|
|
())
|
|
(let ()
|
|
(define-signature z ((x . a)))
|
|
(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: undefined export"
|
|
(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)))
|
|
(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)))
|
|
|
|
|
|
;; 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))))))
|
|
|
|
;; 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))
|
|
|
|
|
|
;; 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)))
|
|
|
|
(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)))))
|
|
|
|
|
|
;; 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))))))
|
|
|
|
(define-signature even-sig (even))
|
|
(define-signature odd-sig (odd))
|
|
|
|
(define even-unit
|
|
(unit (import odd-sig)
|
|
(export even-sig)
|
|
(define (even x)
|
|
(or (= 0 x) (odd (sub1 x))))))
|
|
|
|
(define odd-unit
|
|
(unit (import even-sig)
|
|
(export odd-sig)
|
|
(define (odd x)
|
|
(and (> x 0) (even (sub1 x))))
|
|
(define x (odd 11))
|
|
x))
|
|
|
|
(define run-unit
|
|
(compound-unit (import)
|
|
(export)
|
|
(link (((EVEN : even-sig)) even-unit ODD)
|
|
(((ODD : odd-sig)) odd-unit EVEN))))
|
|
|
|
(test #t (invoke-unit run-unit))
|
|
|
|
(define-signature is-3x-sig (is-3x))
|
|
(define-signature is-3x+1-sig (is-3x+1))
|
|
(define-signature is-3x+2-sig (is-3x+2))
|
|
|
|
(define is-3x-unit
|
|
(unit (import is-3x+2-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)
|
|
(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)
|
|
(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))))
|
|
|
|
(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))))
|
|
|
|
(define 3x-run-unit
|
|
(unit (import is-3x-sig is-3x+1-sig is-3x+2-sig)
|
|
(export)
|
|
(list (is-3x 1)
|
|
(is-3x 3)
|
|
(is-3x+1 5)
|
|
(is-3x+1 7)
|
|
(is-3x+2 4)
|
|
(is-3x+2 8))))
|
|
|
|
(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))))
|
|
|
|
(test (list #f #t #f #t #f #t)
|
|
(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))))
|
|
(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))))
|
|
(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))))
|
|
|
|
;; 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)))
|
|
(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)))
|
|
(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))))))
|
|
(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)))))))
|
|
|
|
(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? "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? "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)))
|
|
|
|
;; unit creation w/o signatures (including macros and prefixes/renames).
|
|
|
|
;; free vars
|
|
(let ((y 1)
|
|
(z 10))
|
|
(define u (unit (import) (export yz-sig)
|
|
(define y 2)
|
|
(define z 3)))
|
|
(define u1 (unit (import) (export)
|
|
y))
|
|
(define u2 (unit (import (only yz-sig z)) (export)
|
|
y))
|
|
(define u3 (unit (import (except yz-sig y)) (export)
|
|
y))
|
|
(define u4 (unit (import (prefix s: yz-sig)) (export)
|
|
y))
|
|
(define u5 (unit (import (rename yz-sig (r y))) (export)
|
|
y))
|
|
(define u6 (unit (import yz-sig) (export)
|
|
y))
|
|
(define (l x)
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((YZ : yz-sig)) u)
|
|
(() x YZ)))))
|
|
(test 1 (invoke-unit u1))
|
|
(test 1 (l u2))
|
|
(test 1 (l u3))
|
|
(test 1 (l u4))
|
|
(test 1 (l u5))
|
|
(test 2 (l u6))
|
|
(test (letrec ((x x)) x)
|
|
(let ()
|
|
(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)))
|
|
;; 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))
|
|
(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)
|
|
(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)))))
|
|
|
|
|
|
;; Test that internal macros can define exports
|
|
(test 1
|
|
(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))))))
|
|
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)))))
|
|
|
|
(define-signature sx (x))
|
|
(define-signature sy (y))
|
|
(define-signature sz (z))
|
|
|
|
;; 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)))))
|
|
|
|
|
|
;; 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))))))
|
|
(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 ((x 1)
|
|
(v 2))
|
|
(let-syntax ((s (syntax-rules () ((_) (list x v)))))
|
|
(define-signature t (x (define-syntaxes (s)
|
|
(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))))
|
|
(define u3 (unit (import) (export t)
|
|
(define x 3)))
|
|
(define u4 (unit (import) (export t2)
|
|
(define x 4)))
|
|
(define (i u)
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((T3 : t)) u3)
|
|
(((T4 : t2)) u4)
|
|
(() u T3 T4)))))
|
|
;; prefix
|
|
(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 (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)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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)))
|
|
(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)))
|
|
(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)))
|
|
(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)))
|
|
(export)
|
|
(list x v (s) p:x p:v (p:s) q:x q:v (q:s))))))
|
|
)
|
|
|
|
(let ()
|
|
(define-signature x ((define-syntaxes (m)
|
|
(syntax-rules ()
|
|
((_ x) (define-syntax x
|
|
(syntax-rules ()
|
|
((_ y) y))))))
|
|
(define-values (v)
|
|
(let ()
|
|
(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))))))
|
|
(let ()
|
|
(define-signature x ((define-syntaxes (m)
|
|
(syntax-rules ()
|
|
((_ x) (define-syntax x #'1))))
|
|
(define-syntaxes (m2)
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
((_ x) (syntax-local-value #'x)))))
|
|
(define-values (v)
|
|
(let ()
|
|
(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))))))
|
|
|
|
(let ()
|
|
(define-signature x ((define-syntaxes (m) #'1)
|
|
(define-syntaxes (m2)
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
((_ x) (syntax-local-value #'x)))))
|
|
(define-values (v)
|
|
(let ()
|
|
(m2 m)))))
|
|
(test 1
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((X : x)) (unit (import) (export x)))
|
|
(() (unit (import x) (export) v) X))))))
|
|
|
|
|
|
(let ()
|
|
(define-signature s1 (a (define-values (x y) (values 1 2))))
|
|
(define-signature s2 extends s1 ((define-values (z) (list a x))))
|
|
(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))))))
|
|
(let ()
|
|
(define-signature s1 (a (define-values (x y) (values 1 2))))
|
|
(let ((x 12))
|
|
(define-signature s2 extends s1 ((define-values (z) (list a x))))
|
|
(define u1 (unit (import s2) (export) (cons y z)))
|
|
(define u2 (unit (import) (export s2) (define a 123)))
|
|
(test (list 2 123 12) (invoke-unit (compound-unit (import) (export)
|
|
(link (((a : s2)) u2)
|
|
(() u1 a)))))))
|
|
|
|
(let ()
|
|
(define-signature s1 (a (define-values (x y) (values c 2))))
|
|
(define-signature s2 extends s1 (c (define-values (z) (list a x))))
|
|
(define u1 (unit (import s2) (export) (cons y z)))
|
|
(define u2 (unit (import) (export s2) (define a 123) (define c 43)))
|
|
(test (list 2 123 43) (invoke-unit (compound-unit (import) (export)
|
|
(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)))))))
|
|
|
|
|
|
;; 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))))))
|
|
|
|
;; 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)))
|
|
|
|
|
|
(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))))
|
|
(define-values/invoke-unit
|
|
(unit (import) (export sig) (define y 2))
|
|
sig)
|
|
(list y v)))
|
|
|
|
|
|
|
|
;; subtyping
|
|
|
|
(let ()
|
|
(define u1 (unit (import x-sig) (export y-sub) (define y (add1 x)) (define yy 2) (list x y yy)))
|
|
(define u2 (unit (import y-sig) (export x-sub) (define x 3) (define xx 44)))
|
|
(define u3 (compound-unit (import (S1 : x-sig)) (export S4)
|
|
(link (((S4 : y-sub)) u1 S1))))
|
|
(define u4 (compound-unit (import (S3 : y-sig)) (export S2)
|
|
(link (((S2 : x-sub)) u2 S3))))
|
|
(define u5 (compound-unit (import (S2 : y-sub)) (export S1)
|
|
(link (((S1 : x-sig)) u2 S2))))
|
|
(test '(3 4 2)
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((S1 : x-sig)) u2 S2)
|
|
(((S2 : y-sig)) u1 S1)))))
|
|
(test '(3 4 2)
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((S1 : x-sub)) u2 S2)
|
|
(((S2 : y-sub)) u1 S1)))))
|
|
|
|
|
|
(test '(3 4 2)
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((S1 : x-sub)) u4 S4)
|
|
(((S4 : y-sub)) u3 S1)))))
|
|
(test '(3 4 2)
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((S1 : x-sig)) u4 S4)
|
|
(((S4 : y-sig)) u3 S1)))))
|
|
|
|
|
|
(test '(3 4 2)
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((S1 : x-sig)) u5 S2)
|
|
(((S2 : y-sub)) u1 S1))))))
|
|
(let ()
|
|
(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"
|
|
(compound-unit (import) (export)
|
|
(link (((S : x-sub)) u1))))
|
|
|
|
(test-runtime-error exn:fail:contract? "compound-unit: not a subtype"
|
|
(compound-unit (import) (export)
|
|
(link (((S : x-sig)) u1)
|
|
(() u2 S))))
|
|
|
|
(test-runtime-error exn:fail:contract? "compound-unit: not a subtype"
|
|
(compound-unit (import (S : x-sig)) (export)
|
|
(link (() u2 S)))))
|
|
|
|
(let ()
|
|
(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))
|
|
|
|
(let ()
|
|
(define u1 (unit (import) (export x-sig) (define x 1)))
|
|
(test-runtime-error exn:fail:contract? "define-values/invoke-unit: not a subtype"
|
|
(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)))
|
|
(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)))))
|
|
(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 u2 (unit (import x-sig) (export)))
|
|
(define v (unit (import x-sub) (export)
|
|
(+ x xx)))
|
|
(define w (unit (import x-sub2) (export)
|
|
(+ x x2)))
|
|
(define u3 (unit (import x-sub (prefix m: x-sub2)) (export)
|
|
(+ x xx m:x m:x2)))
|
|
(test 3
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((S2 : x-sub)) u)
|
|
(() v S2)))))
|
|
(test 7
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((S3 : x-sub2)) u)
|
|
(() w S3)))))
|
|
(test 10
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((S3 : x-sub2) (S2 : x-sub)) u)
|
|
(() u3 S3 S2)))))
|
|
(test-runtime-error exn:fail:contract? "ambiguous export"
|
|
(compound-unit (import) (export)
|
|
(link (((S1 : x-sig)) u)))))
|
|
(test-runtime-error exn:fail:contract? "ambiguous import"
|
|
(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))))
|
|
;; tags
|
|
(let ()
|
|
(define-signature s1 (a))
|
|
(define-signature s2 extends s1 (b))
|
|
(define-signature s3 extends s2 ())
|
|
(define-signature s4 extends s3 ())
|
|
(define u1
|
|
(unit (import (prefix s1: s1)
|
|
(tag t (prefix s2: s2))
|
|
(prefix bs1: s2)
|
|
(prefix bs2: s3))
|
|
(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 u3
|
|
(unit (import) (export s2)
|
|
(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))))))
|
|
(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 u2
|
|
(unit (import x-sig) (export)
|
|
x))
|
|
(define u3
|
|
(unit (import x-sub) (export)
|
|
(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"
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((S1 : (tag t x-sub)) (S2 : x-sub)) u1)
|
|
(() u2 S1)))))
|
|
)
|
|
|
|
(let ()
|
|
(define u1 (unit (import) (export (tag t1 x-sig) (prefix : x-sig))
|
|
(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)))
|
|
|
|
|
|
(define-signature s1 (x))
|
|
(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: 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 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))))
|
|
|
|
(let ()
|
|
(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-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)
|
|
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)
|
|
make-s) S)))))))
|
|
|
|
;; Dependencies
|
|
|
|
(define-signature s1 (a))
|
|
(define-signature s2 extends s1 ())
|
|
|
|
(define u1 (unit (import s1) (export) (init-depend s1)
|
|
a))
|
|
(define u2 (unit (import) (export s1)
|
|
(define a 12)))
|
|
(define u3 (unit (import (tag t s1)) (export) (init-depend (tag t s1))
|
|
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))))
|
|
|
|
(test 12 (invoke-unit (compound-unit (import) (export)
|
|
(link (((S1 : s1)) u2)
|
|
(() u1 S1)))))
|
|
|
|
(test-runtime-error exn:fail:contract? "Dependency violation"
|
|
(compound-unit (import) (export)
|
|
(link (() u1 S1)
|
|
(((S1 : s1)) u2))))
|
|
|
|
(test-runtime-error exn:fail:contract? "Dependency violation"
|
|
(compound-unit (import) (export)
|
|
(link (() u3 (tag t S1))
|
|
(((S1 : s1)) u2))))
|
|
|
|
|
|
|
|
(test-runtime-error exn:fail:contract? "Dependency violation"
|
|
(compound-unit (import) (export)
|
|
(link (() u4 S2)
|
|
(((S2 : s2)) u5))))
|
|
;; Inference
|
|
|
|
|
|
(define u (unit (import x-sig) (export y-sig) (define y 0) x))
|
|
(define v (unit (import) (export x-sig y-sig) (define x 9) (define y 10)))
|
|
|
|
(test 9
|
|
(let ()
|
|
(define-unit-binding u2 u (import x-sig y-sig) (export))
|
|
(invoke-unit
|
|
(compound-unit (import) (export)
|
|
(link (((A : x-sig) (B : y-sig)) v)
|
|
(() u A B))))))
|
|
|
|
(test-runtime-error exn:fail:contract? "not subunit"
|
|
(let () (define-unit-binding u2 u (import x-sig) (export x-sig)) 1))
|
|
(test-runtime-error exn:fail:contract? "not subunit"
|
|
(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: missing name, import, export"
|
|
(define-unit))
|
|
(test-syntax-error "define-unit: missing import, export"
|
|
(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))))
|
|
|
|
|
|
(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)))
|
|
|
|
(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))
|
|
|
|
(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))))
|
|
(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: 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))
|
|
|
|
(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)))
|
|
(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 ()
|
|
(define-values/invoke-unit/infer (link u v))
|
|
x)
|
|
|
|
|
|
(let ()
|
|
(define-values/invoke-unit/infer (export x-sig) (link u v))
|
|
x)
|
|
(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-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))
|
|
|
|
(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 v@ u@))
|
|
(test-runtime-error exn? "define-values/invoke-unit/infer: init-depend broken"
|
|
(define-values/invoke-unit/infer (export) (link u@ v@))))
|
|
|
|
|
|
(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))
|
|
(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)))
|
|
|
|
|
|
(test 1
|
|
(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))))
|
|
(test 2
|
|
(let ()
|
|
(define-unit x (import) (export) 1)
|
|
(set! x (unit (import) (export) 2))
|
|
(invoke-unit x)))
|
|
|
|
|
|
|
|
(let ()
|
|
(define-signature s1 (a))
|
|
(define-signature s2 extends s1 (b))
|
|
(define-signature s3 (c))
|
|
(define-signature s4 extends s3 (d))
|
|
(define-unit u (import s2) (export s3) (define c (+ a b)))
|
|
(define-unit v (import) (export s2) (define a 1) (define b 3))
|
|
(set! u (unit (import s1) (export s4) (define c (add1 a)) (define d 12)))
|
|
(let ()
|
|
(define-values/invoke-unit (compound-unit/infer (import) (export s2 s3) (link v u))
|
|
(import) (export s2 s3))
|
|
(test '(1 3 2) (list a b c))))
|
|
|
|
|
|
(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))))
|
|
(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 ??))))
|
|
|
|
|
|
(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)
|
|
|
|
(define-unit z
|
|
(import (prefix : x-sig) y-sig)
|
|
(export)
|
|
(+ :x y))
|
|
|
|
(define-unit a
|
|
(import)
|
|
(export x-sig y-sig z-sig)
|
|
(define x 1)
|
|
(define y 2)
|
|
(define z 3))
|
|
|
|
(define-unit b
|
|
(import x-sig y-sig z-sig)
|
|
(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 (letrec ((x x)) x)
|
|
(invoke-unit
|
|
(compound-unit/infer (import) (export)
|
|
(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))))))
|
|
(test 6
|
|
(invoke-unit
|
|
(compound-unit/infer (import) (export)
|
|
(link (((L1 : y-sig)) a)
|
|
x
|
|
(() b L1)))))
|
|
|
|
(let ()
|
|
(define-unit u1 (import (tag t x-sig)) (export)
|
|
(add1 x))
|
|
(define-unit u2 (import) (export x-sig)
|
|
(define x 2))
|
|
(test 3
|
|
(invoke-unit
|
|
(compound-unit/infer (import) (export)
|
|
(link u2 u1)))))
|
|
(let ()
|
|
(define-unit u1 (import x-sig) (export)
|
|
(add1 x))
|
|
(define-unit u2 (import) (export (tag u x-sig))
|
|
(define x 2))
|
|
(test 3
|
|
(invoke-unit
|
|
(compound-unit/infer (import) (export)
|
|
(link u2 u1)))))
|
|
|
|
(let ()
|
|
(define-unit x2 (import) (export x-sig) (define x 44))
|
|
(define-unit x3 (import) (export x-sig) (define x 4400))
|
|
(define-unit z (import x-sig) (export z-sig) (define z (+ 100 x)))
|
|
(define-compound-unit/infer u (import (L : x-sig)) (export L2 y-sig)
|
|
(link x3 (((L2 : z-sig)) z L) (() a L)))
|
|
(test 190
|
|
(invoke-unit
|
|
(compound-unit/infer (import) (export)
|
|
(link x2 u b)))))
|
|
|
|
(let ()
|
|
(define-unit u (import x-sig) (export))
|
|
(define-unit v (import) (export x-sub) (define x 12) (define xx 13))
|
|
(define-compound-unit/infer c (import) (export x-sig) (link v u))
|
|
(define-values/invoke-unit/infer c)
|
|
(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
|
|
(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: 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))
|
|
|
|
|