613 lines
16 KiB
Racket
613 lines
16 KiB
Racket
|
|
(load-relative "loadtest.rktl")
|
|
|
|
(Section 'unit)
|
|
(require mzlib/unit200)
|
|
(require racket/undefined)
|
|
|
|
;; Hide keywords from scheme/unit.rkt:
|
|
(define import #f)
|
|
(define export #f)
|
|
(define link #f)
|
|
|
|
(syntax-test #'(unit))
|
|
(syntax-test #'(unit (import)))
|
|
(syntax-test #'(unit (impLort)))
|
|
(syntax-test #'(unit (impLort) (export) 5))
|
|
(syntax-test #'(unit (import) (expLort) 5))
|
|
(syntax-test #'(unit import (export) 5))
|
|
(syntax-test #'(unit (import) export 5))
|
|
(syntax-test #'(unit (import) (export) . 5))
|
|
(syntax-test #'(unit (import 8) (export) 5))
|
|
(syntax-test #'(unit (import . i) (export) 5))
|
|
(syntax-test #'(unit (import (i)) (export) 5))
|
|
(syntax-test #'(unit (import i 8) (export) 5))
|
|
(syntax-test #'(unit (import i . b) (export) 5))
|
|
(syntax-test #'(unit (import i (b)) (export) 5))
|
|
(syntax-test #'(unit (import i) (export 7) 5))
|
|
(syntax-test #'(unit (import i) (export . a) (define a 6)))
|
|
(syntax-test #'(unit (import i) (export a . b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (a x) . b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (a 8) b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export b (a 8)) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (a . x) b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export b (a . x)) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (a x y) b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (a x . y) b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export b (a x . y)) (define a 5) (define b 6)))
|
|
|
|
(syntax-test #'(unit (import i) (export) (begin 1 . 2)))
|
|
(syntax-test #'(unit (import i) (export b a) (begin (define a 5) (define b 6) . x)))
|
|
(syntax-test #'(unit (import i) (export b a) (begin (define a 5) (define b 6)) (define b 6)))
|
|
|
|
(syntax-test #'(unit (import) (export) (define-values (3) 5)))
|
|
|
|
(syntax-test #'(unit (import a) (export (a x) b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import a) (export (a x) (a y)) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i a) (export (a x) b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import b) (export (a x) b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i j i) (export (a x) b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i j j) (export (a x) b) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export a a) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (a x) (b x)) (define a 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (a x) b) (define a 5) (define a 6) (define b 6)))
|
|
(syntax-test #'(unit (import make-i) (export (a x) b) (define a 5) (define-struct i ()) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (make-a x) b) (define make-a 5) (define-struct a ()) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (a x) b) (define a 5) (define r 6) (define r 7) (define b 6)))
|
|
|
|
(syntax-test #'(unit (import i) (export b (a x)) 5))
|
|
(syntax-test #'(unit (import i) (export (a x) b) (define x 5) (define b 6)))
|
|
(syntax-test #'(unit (import i) (export (a x) b) (set! a 5) (define b 6)))
|
|
|
|
(syntax-test #'(unit (import i) (export) (set! i 5)))
|
|
|
|
; Empty exports are syntactically ok::
|
|
(error-test #'(compound-unit (import) (link (A (0))) (export (A))) exn:fail:unit?)
|
|
(error-test #'(compound-unit (import) (link (A (0 (B))) (B (0))) (export)) exn:fail:unit?)
|
|
(error-test #'(compound-unit (import) (link (A (0)) (B (0))) (export (A x) (B))) exn:fail:unit?)
|
|
|
|
; Self-import is now allowed
|
|
; (syntax-test #'(compound-unit (import) (link (A (0 (A)))) (export)))
|
|
; (syntax-test #'(compound-unit (import) (link (A (0 (A x)))) (export)))
|
|
(test (list undefined 5)
|
|
'self-import
|
|
(invoke-unit
|
|
(compound-unit
|
|
(import)
|
|
(link [U ((unit (import a) (export b) (define x a) (define b 5) (list x a))
|
|
(U b))])
|
|
(export))))
|
|
|
|
(error-test #'(invoke-unit (unit (import not-defined) (export) 10) not-defined) exn:fail:contract:variable?)
|
|
|
|
(test #t unit? (unit (import) (export)))
|
|
(test #t unit? (unit (import) (export) 5))
|
|
(test #t unit? (unit (import i) (export (a x)) (define a 8) (define x 5)))
|
|
(test 5 (lambda (f) (invoke-unit f)) (unit (import) (export) 5))
|
|
|
|
(test #t unit? (unit (import i) (export b a) (begin (define a 5) (define b 6))))
|
|
(test #t unit? (unit (import i) (export b a) 'a (begin (define a 5) (define b 6)) 'b))
|
|
(test #t unit? (unit (import i) (export b a) (begin (define a 5)) (define b 6)))
|
|
(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define b 6))))
|
|
(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define y 7) (define b 6)) (+ y b a)))
|
|
|
|
(test 3 'embedded-deeply ((invoke-unit (unit (import) (export) (lambda () (define x 3) x)))))
|
|
(test 1 'embedded-deeply-struct ((invoke-unit (unit (import) (export) (lambda ()
|
|
(define-struct a ())
|
|
make-a
|
|
1)))))
|
|
|
|
; Empty begin is OK in a unit context:
|
|
(test #t unit? (unit (import i) (export) (begin)))
|
|
(test #t unit? (unit (import i) (export) (begin (begin))))
|
|
|
|
(syntax-test #'(compound-unit))
|
|
(syntax-test #'(compound-unit . x))
|
|
(syntax-test #'(compound-unit (import)))
|
|
(syntax-test #'(compound-unit (import) . x))
|
|
(syntax-test #'(compound-unit (import) (link)))
|
|
(syntax-test #'(compound-unit (import) (link) . x))
|
|
(syntax-test #'(compound-unit import (link) (export)))
|
|
(syntax-test #'(compound-unit (import) link (export)))
|
|
(syntax-test #'(compound-unit (import) (link) export))
|
|
(syntax-test #'(compound-unit ((import)) (link) (export)))
|
|
(syntax-test #'(compound-unit (import) ((link)) (export)))
|
|
(syntax-test #'(compound-unit (import) (link) ((export))))
|
|
(syntax-test #'(compound-unit (import . a) (link) (export)))
|
|
(syntax-test #'(compound-unit (import b . a) (link) (export)))
|
|
(syntax-test #'(compound-unit (import 1) (link) (export)))
|
|
(syntax-test #'(compound-unit (import (a)) (link) (export)))
|
|
(syntax-test #'(compound-unit (import (a . b)) (link) (export)))
|
|
(syntax-test #'(compound-unit (import (a (b))) (link) (export)))
|
|
(syntax-test #'(compound-unit (import ((a) b)) (link) (export)))
|
|
(syntax-test #'(compound-unit (import) (link . a) (export)))
|
|
(syntax-test #'(compound-unit (import) (link a) (export)))
|
|
(syntax-test #'(compound-unit (import) (link (a)) (export)))
|
|
(syntax-test #'(compound-unit (import) (link (a (b)) . c) (export)))
|
|
(syntax-test #'(compound-unit (import) (link (a (b) . c)) (export)))
|
|
(syntax-test #'(compound-unit (import) (link (a (b . c)) (c (d))) (export)))
|
|
(syntax-test #'(compound-unit (import) (link (a (b c . e)) (c (d)) (e (f))) (export)))
|
|
(syntax-test #'(compound-unit (import) (link (a (b 1))) (export)))
|
|
(syntax-test #'(compound-unit (import) (link (a (b))) (export . a)))
|
|
(syntax-test #'(compound-unit (import) (link (a (b))) (export a)))
|
|
(syntax-test #'(compound-unit (import) (link (a (b))) (export (a w) . a)))
|
|
(syntax-test #'(compound-unit (import) (link (a (b))) (export (a 1))))
|
|
(syntax-test #'(compound-unit (import) (link (a (b))) (export (a (x)))))
|
|
(syntax-test #'(compound-unit (import) (link (a (b))) (export (1 w))))
|
|
|
|
(test #t unit? (compound-unit (import) (link) (export)))
|
|
|
|
; Simple:
|
|
|
|
(define m1
|
|
(unit
|
|
(import)
|
|
(export x y a? set-a-b!)
|
|
|
|
(define-struct a (b c) #:mutable)
|
|
|
|
(define x 7)
|
|
(define z 8)
|
|
(define y (lambda () (* z x)))
|
|
|
|
(list x y z)))
|
|
|
|
(test #t apply (lambda (x y z) (and (= x 7) (= z 8) (procedure? y) (= 0 (procedure-arity y))))
|
|
(invoke-unit m1))
|
|
|
|
(test #t apply
|
|
(lambda (x y-val a? set-a-b!)
|
|
(and (= x 7) (= y-val 56)
|
|
(= 1 (procedure-arity a?))
|
|
(= 2 (procedure-arity set-a-b!))))
|
|
(invoke-unit
|
|
(compound-unit
|
|
(import)
|
|
(link [M (m1)]
|
|
[N ((unit
|
|
(import x y a? set-a-b!)
|
|
(export)
|
|
(list x (y) a? set-a-b!))
|
|
(M x y a? set-a-b!))])
|
|
(export))))
|
|
|
|
; Structures:
|
|
|
|
|
|
(define m2-1
|
|
(unit
|
|
(import)
|
|
(export x struct:a a? v y)
|
|
|
|
(define x 5)
|
|
(define-struct a (b c) #:mutable)
|
|
(define v (make-a 5 6))
|
|
(define (y v) (a? v))))
|
|
|
|
(define m2-2
|
|
(unit
|
|
(import struct:a a?)
|
|
(export x? make-x x-z both)
|
|
|
|
(define-syntax a (list #'struct:a #f #'a? (list #f) (list #f) #f))
|
|
|
|
(define-struct (x a) (y z) #:mutable)
|
|
(define both (lambda (v)
|
|
(and (a? v) (x? v))))))
|
|
|
|
(define m2-3
|
|
(compound-unit
|
|
(import)
|
|
(link [O (m2-1)][T (m2-2 (O struct:a) (O a?))])
|
|
(export [O x struct:a v y]
|
|
[T x? make-x x-z both])))
|
|
|
|
|
|
(let ([p (open-output-string)])
|
|
(invoke-unit
|
|
(compound-unit
|
|
(import)
|
|
(link [M (m2-3)]
|
|
[N ((unit
|
|
(import x v struct:a y x? make-x x-z both)
|
|
(export)
|
|
(define (filter v)
|
|
(if (procedure? v)
|
|
`(proc: ,(object-name v))
|
|
v))
|
|
(display
|
|
(map filter (list x v struct:a y make-x x? x-z both))
|
|
p)
|
|
(let ([v2 (make-x 1 2 3 4)])
|
|
(display (map filter
|
|
(list x (struct-type? struct:a)
|
|
v (y v) (y x)
|
|
v2
|
|
(y v2)
|
|
(x? v2)
|
|
(both v)
|
|
(both v2)))
|
|
p)))
|
|
(M x v struct:a y x? make-x x-z both))])
|
|
(export)))
|
|
|
|
(test (string-append "(5 #<a> #<struct-type:a> (proc: y)"
|
|
" (proc: x) (proc: x?)"
|
|
" (proc: x-z) (proc: both))"
|
|
"(5 #t #<a> #t #f #<x> #t #t #f #t)")
|
|
get-output-string p))
|
|
|
|
; Compound with circularity
|
|
|
|
(define make-z
|
|
(lambda (x-val)
|
|
(unit
|
|
(import z)
|
|
(export (x z) y)
|
|
|
|
(define x x-val)
|
|
(define y (lambda () (- z x))))))
|
|
|
|
(define z1 (make-z 8))
|
|
(define z2 (make-z 7))
|
|
|
|
; Dynamic linking
|
|
|
|
(let ([u
|
|
(unit
|
|
(import x)
|
|
(export)
|
|
|
|
(+ x 8))])
|
|
|
|
(test 10 'dynamic (invoke-unit
|
|
(unit
|
|
(import)
|
|
(export w)
|
|
|
|
(define w 2)
|
|
|
|
(invoke-unit u w)))))
|
|
|
|
; Misc
|
|
|
|
(test 12 'nested-units
|
|
(invoke-unit
|
|
(compound-unit
|
|
(import)
|
|
(link (a@ ((unit (import) (export s@:a) (define s@:a 5))))
|
|
(u@ ((compound-unit
|
|
(import a@:s@:a)
|
|
(link (r@ ((unit (import a) (export) (+ a 7)) a@:s@:a)))
|
|
(export))
|
|
(a@ s@:a))))
|
|
(export))))
|
|
|
|
; Import linking via invoke-unit
|
|
|
|
(test '(5 7 (7 7)) 'invoke-unit-linking
|
|
(let ([u (unit (import x) (export) x)]
|
|
[v (unit (import x) (export) (lambda () x))]
|
|
[x 5])
|
|
(list (invoke-unit u x)
|
|
(begin
|
|
(set! x 7)
|
|
(invoke-unit u x))
|
|
(let ([f (invoke-unit v x)])
|
|
(list
|
|
(f)
|
|
(begin
|
|
(set! x 2)
|
|
(f)))))))
|
|
|
|
|
|
; Multiple values
|
|
(test '(1 2 3)
|
|
call-with-values
|
|
(lambda () (invoke-unit (unit (import) (export) (values 1 2 3))))
|
|
list)
|
|
|
|
; Units within units:
|
|
|
|
(define u (unit
|
|
(import)
|
|
(export)
|
|
(define y 10)
|
|
(define x 5)
|
|
(unit
|
|
(import)
|
|
(export)
|
|
x)))
|
|
(test #t unit? u)
|
|
(define u2 (invoke-unit u))
|
|
(test #t unit? u2)
|
|
(test 5 'invoke-unit-in-unit (invoke-unit u2))
|
|
|
|
|
|
; Units and objects combined:
|
|
|
|
(require scheme/class)
|
|
|
|
(define u@
|
|
(unit (import x) (export)
|
|
(class* object% ()
|
|
(public y)
|
|
(define y (lambda () x))
|
|
(super-make-object))))
|
|
(define v (invoke-unit u@ car))
|
|
(test #t class? v)
|
|
(define w (make-object v))
|
|
(test car 'ivar (send w y))
|
|
|
|
(define c%
|
|
(class* object% ()
|
|
(init x)
|
|
(define -x x)
|
|
(public z)
|
|
(define (z) (unit (import) (export) -x))
|
|
(super-make-object)))
|
|
(define u (send (make-object c% car) z))
|
|
(test #t unit? u)
|
|
(test car 'invoke (invoke-unit u))
|
|
|
|
(define c%
|
|
(class* object% ()
|
|
(init x)
|
|
(define -x x)
|
|
(public y z)
|
|
(define (y) -x)
|
|
(define (z) (unit (import) (export) (y)))
|
|
(super-make-object)))
|
|
(define u (make-object c% 3))
|
|
(define u2 (send u z))
|
|
(test #t unit? u2)
|
|
(test 3 'invoke (invoke-unit u2))
|
|
|
|
(test undefined #;(letrec ([x y][y 0]) x) 'invoke
|
|
(invoke-unit (unit (import) (export) (define x y) (define y 7) x)))
|
|
|
|
; Can shadow syntax/macros in unit
|
|
(test #t unit? (unit
|
|
(import)
|
|
(export)
|
|
(define define 10)))
|
|
(test #t unit? (unit
|
|
(import)
|
|
(export)
|
|
(define lambda 10)))
|
|
|
|
; Shadowing also ok if it's in the export list:
|
|
(test #t unit? (unit
|
|
(import)
|
|
(export define-values)
|
|
(define define-values 10)))
|
|
(test #t unit? (unit
|
|
(import)
|
|
(export lambda)
|
|
(define lambda 10)))
|
|
(test #t unit? (unit
|
|
(import)
|
|
(export [lambda l])
|
|
(define lambda 10)))
|
|
|
|
; These are ok, too:
|
|
(test #t unit? (unit
|
|
(import define)
|
|
(export)
|
|
(define define 10)))
|
|
(test #t unit? (let ([define-values 5])
|
|
(unit
|
|
(import)
|
|
(export)
|
|
(define define-values 10))))
|
|
(test 10 'invoke-w/shadowed
|
|
(let ([define-values 5])
|
|
(invoke-unit
|
|
(unit
|
|
(import)
|
|
(export define-values)
|
|
(define define-values 10)
|
|
define-values))))
|
|
|
|
; Check set! of shadowed variable:
|
|
(test #t unit? (unit
|
|
(import x)
|
|
(export)
|
|
(let ([x 10])
|
|
(set! x 5))))
|
|
(test #t unit? (unit
|
|
(import x)
|
|
(export)
|
|
(class object%
|
|
(field
|
|
[x 10])
|
|
(set! x 5))))
|
|
(syntax-test #'(let ([x 10])
|
|
(unit
|
|
(import x)
|
|
(export)
|
|
(set! x 5))))
|
|
|
|
; Especially for zodiac:
|
|
(test '(b c 10 b a (c a b) (c b a) (c . c) (a) #t
|
|
(nested-b a b c) (a 2 b) (10 b c) (cl-unit-a 12 c))
|
|
'invoke-w/shadowed-a-lot
|
|
(let ([a 'bad-a]
|
|
[b 'bad-b]
|
|
[c 'bad-c]
|
|
[struct:d 'bad-d]
|
|
[i 'bad-i])
|
|
(invoke-unit
|
|
(unit
|
|
(import)
|
|
(export b)
|
|
(define a 'a)
|
|
(define b 'b)
|
|
(begin
|
|
(define c 'c)
|
|
(define-struct d (w)))
|
|
(define x '...)
|
|
|
|
(define-struct (e d) ())
|
|
(set! x (cons c c))
|
|
|
|
(define i (interface ()))
|
|
|
|
(list
|
|
(if (eq? a 'a)
|
|
b
|
|
c)
|
|
(if (eq? a 'bad-a)
|
|
b
|
|
c)
|
|
(d-w (make-e 10))
|
|
(begin a b)
|
|
(begin0 a b)
|
|
(let ([ab (list a b)])
|
|
(cons c ab))
|
|
(letrec ([mk-ba (lambda ()
|
|
(list b a))])
|
|
(cons c (mk-ba)))
|
|
x
|
|
(with-continuation-mark
|
|
b a
|
|
(continuation-mark-set->list (current-continuation-marks) b))
|
|
(interface? (interface (i)))
|
|
(invoke-unit
|
|
(unit
|
|
(import w a)
|
|
(export)
|
|
(define b 'nested-b)
|
|
(list b w a c))
|
|
a b)
|
|
(invoke-unit
|
|
(compound-unit
|
|
(import a)
|
|
(link [u ((unit (import c) (export (xa a) (b xb))
|
|
(define xa 1)
|
|
(define b 2)
|
|
(list a b c))
|
|
a)])
|
|
(export))
|
|
b)
|
|
(send
|
|
(make-object
|
|
(class object%
|
|
(field [a 10])
|
|
(public tester)
|
|
(define tester
|
|
(lambda () (list a b c)))
|
|
(super-make-object)))
|
|
tester)
|
|
(send
|
|
(make-object
|
|
(class object%
|
|
(field
|
|
[a 10]
|
|
[b 12])
|
|
(public tester)
|
|
(define tester
|
|
(lambda ()
|
|
(invoke-unit
|
|
(unit
|
|
(import)
|
|
(export)
|
|
(define a 'cl-unit-a)
|
|
(list a b c)))))
|
|
(super-make-object)))
|
|
tester))))))
|
|
|
|
; Not ok if defining an imported name, but error should be about
|
|
; redefining an imported name. (This behavior is not actually tested.)
|
|
(syntax-test #'(unit
|
|
(import define-values)
|
|
(export)
|
|
(define define-values 10)))
|
|
|
|
(test #t unit? (unit
|
|
(import define-values)
|
|
(export)
|
|
(let () (define define-values 10) define-values)))
|
|
|
|
;; Invoke-unit linking in let-bound variables
|
|
(test '(the-x 10) 'invoke
|
|
(let ([x 'the-x])
|
|
(invoke-unit
|
|
(unit (import w) (export)
|
|
(list w 10))
|
|
x)))
|
|
|
|
;; ----------------------------------------
|
|
;; Macro definitions in units
|
|
|
|
(test 5 'stx-def
|
|
(invoke-unit
|
|
(unit
|
|
(import)
|
|
(export)
|
|
|
|
(define-syntax (five stx) #'5)
|
|
five)))
|
|
|
|
(test 5 'stx-def
|
|
(let ()
|
|
(define-values/invoke-unit (x)
|
|
(unit
|
|
(import)
|
|
(export x)
|
|
|
|
(define-syntax (five stx) #'5)
|
|
(define x five)))
|
|
x))
|
|
|
|
(test 50 'stx-def
|
|
(let ()
|
|
(define-values/invoke-unit (x)
|
|
(unit
|
|
(import)
|
|
(export x)
|
|
|
|
(define-syntax (five stx) #'fifty)
|
|
(define fifty 50)
|
|
(define x five)))
|
|
x))
|
|
|
|
(test 60 'stx-def
|
|
(let ()
|
|
(define-values/invoke-unit (x)
|
|
(unit
|
|
(import)
|
|
(export x sixty)
|
|
|
|
(define-syntax (five stx) #'sixty)
|
|
(define sixty 60)
|
|
(define x five)))
|
|
x))
|
|
|
|
(test 70 'stx-def
|
|
(let ([y 70])
|
|
(define-values/invoke-unit (x)
|
|
(unit
|
|
(import seventy)
|
|
(export x)
|
|
|
|
(define-syntax (five stx) #'seventy)
|
|
(define x five))
|
|
#f y)
|
|
x))
|
|
|
|
(test 55 'namespace
|
|
(parameterize ([current-namespace (make-base-namespace)])
|
|
(namespace-variable-bind/invoke-unit
|
|
(x)
|
|
(unit
|
|
(import)
|
|
(export x)
|
|
|
|
(define-syntax (five stx) #'55)
|
|
(define x five)))
|
|
(eval 'x)))
|
|
|
|
|
|
(report-errs)
|