original commit: 4c70cbd201f6eb18f5850809f7e2035eae36b108
This commit is contained in:
Matthew Flatt 1999-05-23 20:11:26 +00:00
parent e15cf6995b
commit 1247d66af0

View File

@ -111,4 +111,85 @@
(let ([=> 17]) (evcase 3 [3 =>]))))
(compile-allow-cond-fallthrough save-comp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require-library "invoke.ss")
(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))
(define m3
(compound-unit
(import)
(link [Z1 (z1 (Z2 z))][Z2 (z2 (Z1 z))])
(export [Z1 (y y1) (z x1)][Z2 (y y2) (z x2)])))
(define-values/invoke-unit (y1 x1 y2 x2) m3)
(test '(-1 1 8 7) 'invoke-open-unit (list (y1) (y2) x1 x2))
; Linking environments
(when (defined? 'x)
(undefine 'x))
(define (make--eval)
(let ([n (make-namespace)])
(lambda (e)
(let ([orig (current-namespace)])
(dynamic-wind
(lambda () (current-namespace n))
(lambda ()
(require-library "invoke.ss")
(eval e))
(lambda () (current-namespace orig)))))))
(define u
(unit
(import)
(export x)
(define x 5)))
(define e (make--eval))
(e (list 'define-values/invoke-unit '(x) u #f))
(test #f defined? 'x)
(test #t e '(defined? 'x))
(define u2
(let ([u u])
(unit
(import)
(export)
(global-define-values/invoke-unit (x) u #f))))
(define e (make--eval))
(e (list 'define-values/invoke-unit '() u2 #f))
(test #f defined? 'x)
(test #t e '(defined? 'x))
; Export var from embedded unit:
(define-signature e ((unit w : (embedded-v))))
(define-values/invoke-unit/sig (embedded-v)
(compound-unit/sig
(import)
(link [E : e ((compound-unit/sig
(import)
(link [w : (embedded-v) ((unit/sig (embedded-v)
(import)
(define embedded-v 0)))])
(export (unit w))))])
(export (var ((E w) embedded-v)))))
(test 0 'embedded-v embedded-v)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)