(define (documented? object)
(object-documentation object))
-(define (make-adder)
- (let* ((counter 0))
- (lambda increment
- (if (not (null? increment))
- (set! counter (+ counter (car increment))))
- counter)))
-
(define (folder sym val res)
(cons (cons sym val) res))
+(define (make-observer-func)
+ (let* ((counter 0))
+ (lambda args
+ (if (null? args)
+ counter
+ (set! counter (+ counter 1))))))
+
+(define (make-erroneous-observer-func)
+ (let* ((func (make-observer-func)))
+ (lambda args
+ (if (null? args)
+ (func)
+ (begin
+ (func args)
+ (error))))))
;;;
;;; leaf-environments
(with-test-prefix "bound, define, ref, set!, cell"
- (let* ((env (make-leaf-environment))
- (ctr (make-adder)))
-
- (pass-if "unbound by default"
+ (pass-if "symbols are unbound by default"
+ (let* ((env (make-leaf-environment)))
(and (not (environment-bound? env 'a))
(not (environment-bound? env 'b))
- (not (environment-bound? env 'c))))
-
- (pass-if "bound after define"
- (environment-define env 'a (ctr 1))
- (environment-bound? env 'a))
-
- (pass-if "ref defined"
- (and (begin
- (environment-define env 'a (ctr 1))
- (eq? (environment-ref env 'a) (ctr)))
- (begin
- (environment-define env 'a (ctr 1))
- (eq? (environment-ref env 'a) (ctr)))))
-
- (pass-if "set! defined"
- (and (begin
- (environment-set! env 'a (ctr 1))
- (eq? (environment-ref env 'a) (ctr)))
- (begin
- (environment-set! env 'a (ctr 1))
- (eq? (environment-ref env 'a) (ctr)))))
-
- (pass-if "read-only cell"
+ (not (environment-bound? env 'c)))))
+
+ (pass-if "symbol is bound after define"
+ (let* ((env (make-leaf-environment)))
+ (environment-bound? env 'a)
+ (environment-define env 'a #t)
+ (environment-bound? env 'a)))
+
+ (pass-if "ref a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-bound? env 'a)
+ (environment-bound? env 'b)
+ (environment-define env 'a #t)
+ (environment-define env 'b #f)
+ (and (environment-ref env 'a)
+ (not (environment-ref env 'b)))))
+
+ (pass-if "set! a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (environment-define env 'b #f)
+ (environment-ref env 'a)
+ (environment-ref env 'b)
+ (environment-set! env 'a #f)
+ (environment-set! env 'b #t)
+ (and (not (environment-ref env 'a))
+ (environment-ref env 'b))))
+
+ (pass-if "get a read-only cell"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
(let* ((cell (environment-cell env 'a #f)))
- (and (begin
- (environment-set! env 'a (ctr 1))
- (eq? (cdr cell) (ctr))))))
+ (and (cdr cell)
+ (begin
+ (environment-set! env 'a #f)
+ (not (cdr cell)))))))
- (pass-if "read-only cell rebound after define"
+ (pass-if "a read-only cell gets rebound after define"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
(let* ((cell (environment-cell env 'a #f)))
- (environment-define env 'a (ctr 1))
- (not (eq? (environment-cell env 'a #f) cell))))
+ (environment-define env 'a #f)
+ (not (eq? (environment-cell env 'a #f) cell)))))
- (pass-if "writable cell"
+ (pass-if "get a writable cell"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
(let* ((readable (environment-cell env 'a #f))
(writable (environment-cell env 'a #t)))
(and (eq? readable writable)
(begin
- (environment-set! env 'a (ctr 1))
- (eq? (cdr writable) (ctr)))
+ (environment-set! env 'a #f)
+ (not (cdr writable)))
(begin
- (set-cdr! writable (ctr 1))
- (eq? (environment-ref env 'a) (ctr)))
+ (set-cdr! writable #t)
+ (environment-ref env 'a))
(begin
- (set-cdr! (environment-cell env 'a #t) (ctr 1))
- (eq? (cdr writable) (ctr))))))
+ (set-cdr! (environment-cell env 'a #t) #f)
+ (not (cdr writable)))))))
- (pass-if "writable cell rebound after define"
+ (pass-if "a writable cell gets rebound after define"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
(let* ((cell (environment-cell env 'a #t)))
- (environment-define env 'a (ctr 1))
- (not (eq? (environment-cell env 'a #t) cell))))
+ (environment-define env 'a #f)
+ (not (eq? (environment-cell env 'a #t) cell)))))
+
+ (pass-if "reference an undefined symbol"
+ (catch #t
+ (lambda ()
+ (environment-ref (make-leaf-environment) 'a)
+ #f)
+ (lambda args
+ #t)))
+
+ (pass-if "set! an undefined symbol"
+ (catch #t
+ (lambda ()
+ (environment-set! (make-leaf-environment) 'a)
+ #f)
+ (lambda args
+ #t)))
+
+ (pass-if "get a readable cell for an undefined symbol"
+ (catch #t
+ (lambda ()
+ (environment-cell (make-leaf-environment) 'a #f)
+ #f)
+ (lambda args
+ #t)))
+
+ (pass-if "get a writable cell for an undefined symbol"
+ (catch #t
+ (lambda ()
+ (environment-cell (make-leaf-environment) 'a #t)
+ #f)
+ (lambda args
+ #t))))
+
+
+ (with-test-prefix "undefine"
+
+ (pass-if "undefine a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (environment-ref env 'a)
+ (environment-undefine env 'a)
+ (not (environment-bound? env 'a))))
- (pass-if "referencing undefined"
+ (pass-if "undefine an already undefined symbol"
+ (environment-undefine (make-leaf-environment) 'a)
+ #t))
+
+
+ (with-test-prefix "fold"
+
+ (pass-if "empty environment"
+ (let* ((env (make-leaf-environment)))
+ (eq? 'success (environment-fold env folder 'success))))
+
+ (pass-if "one symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (equal? '((a . #t)) (environment-fold env folder '()))))
+
+ (pass-if "two symbols"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (environment-define env 'b #f)
+ (let ((folded (environment-fold env folder '())))
+ (or (equal? folded '((a . #t) (b . #f)))
+ (equal? folded '((b . #f) (a . #t))))))))
+
+
+ (with-test-prefix "observe"
+
+ (pass-if "observe an environment"
+ (let* ((env (make-leaf-environment)))
+ (environment-observe env (make-observer-func))
+ #t))
+
+ (pass-if "observe an environment twice"
+ (let* ((env (make-leaf-environment))
+ (observer-1 (environment-observe env (make-observer-func)))
+ (observer-2 (environment-observe env (make-observer-func))))
+ (not (eq? observer-1 observer-2))))
+
+ (pass-if "definition of an undefined symbol"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1)))
+
+ (pass-if "definition of an already defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1))))
+
+ (pass-if "set!ing of a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-set! env 'a 1)
+ (eqv? (func) 0))))
+
+ (pass-if "undefining a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 1))))
+
+ (pass-if "undefining an already undefined symbol"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an active observer"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func))
+ (observer (environment-observe env func)))
+ (environment-unobserve observer)
+ (environment-define env 'a 1)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an inactive observer"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func))
+ (observer (environment-observe env func)))
+ (environment-unobserve observer)
+ (environment-unobserve observer)
+ #t)))
+
+
+ (with-test-prefix "observe-weak"
+
+ (pass-if "observe an environment"
+ (let* ((env (make-leaf-environment)))
+ (environment-observe-weak env (make-observer-func))
+ #t))
+
+ (pass-if "observe an environment twice"
+ (let* ((env (make-leaf-environment))
+ (observer-1 (environment-observe-weak env (make-observer-func)))
+ (observer-2 (environment-observe-weak env (make-observer-func))))
+ (not (eq? observer-1 observer-2))))
+
+ (pass-if "definition of an undefined symbol"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1)))
+
+ (pass-if "definition of an already defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1))))
+
+ (pass-if "set!ing of a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-set! env 'a 1)
+ (eqv? (func) 0))))
+
+ (pass-if "undefining a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 1))))
+
+ (pass-if "undefining an already undefined symbol"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an active observer"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func))
+ (observer (environment-observe-weak env func)))
+ (environment-unobserve observer)
+ (environment-define env 'a 1)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an inactive observer"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func))
+ (observer (environment-observe-weak env func)))
+ (environment-unobserve observer)
+ (environment-unobserve observer)
+ #t))
+
+ (pass-if "weak observer gets collected"
+ (gc)
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
+ (gc)
+ (environment-define env 'a 1)
+ (eqv? (func) 0))))
+
+
+ (with-test-prefix "erroneous observers"
+
+ (pass-if "update continues after error"
+ (let* ((env (make-leaf-environment))
+ (func-1 (make-erroneous-observer-func))
+ (func-2 (make-erroneous-observer-func)))
+ (environment-observe env func-1)
+ (environment-observe env func-2)
+ (catch #t
+ (lambda ()
+ (environment-define env 'a 1)
+ #f)
+ (lambda args
+ (and (eq? (func-1) 1)
+ (eq? (func-2) 1))))))))
+
+
+;;;
+;;; leaf-environment based eval-environments
+;;;
+
+(with-test-prefix "leaf-environment based eval-environments"
+
+ (with-test-prefix "eval-environment?"
+
+ (pass-if "documented?"
+ (documented? eval-environment?))
+
+ (pass-if "non-environment-object"
+ (not (eval-environment? #f)))
+
+ (pass-if "leaf-environment-object"
+ (not (eval-environment? (make-leaf-environment)))))
+
+
+ (with-test-prefix "make-eval-environment"
+
+ (pass-if "documented?"
+ (documented? make-eval-environment))
+
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment)))
+
+ (pass-if "produces an environment"
+ (environment? (make-eval-environment local imported)))
+
+ (pass-if "produces an eval-environment"
+ (eval-environment? (make-eval-environment local imported)))
+
+ (pass-if "produces always a new environment"
+ (not (eq? (make-eval-environment local imported)
+ (make-eval-environment local imported))))))
+
+
+ (with-test-prefix "eval-environment-local"
+
+ (pass-if "documented?"
+ (documented? eval-environment-local))
+
+ (pass-if "returns local"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (eq? (eval-environment-local env) local))))
+
+
+ (with-test-prefix "eval-environment-imported"
+
+ (pass-if "documented?"
+ (documented? eval-environment-imported))
+
+ (pass-if "returns imported"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (eq? (eval-environment-imported env) imported))))
+
+
+ (with-test-prefix "bound, define, ref, set!, cell"
+
+ (pass-if "symbols are unbound by default"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (and (not (environment-bound? env 'a))
+ (not (environment-bound? env 'b))
+ (not (environment-bound? env 'c)))))
+
+ (with-test-prefix "symbols bound in imported"
+
+ (pass-if "binding is visible"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-bound? env 'a)
+ (environment-define imported 'a #t)
+ (environment-bound? env 'a)))
+
+ (pass-if "ref works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-bound? env 'a)
+ (environment-define imported 'a #t)
+ (environment-ref env 'a)))
+
+ (pass-if "set! works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #f)
+ (environment-set! env 'a #t)
+ (environment-ref imported 'a)))
+
+ (pass-if "cells are passed through"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (let* ((imported-cell (environment-cell imported 'a #f))
+ (env-cell (environment-cell env 'a #f)))
+ (eq? env-cell imported-cell)))))
+
+ (with-test-prefix "symbols bound in local"
+
+ (pass-if "binding is visible"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-bound? env 'a)
+ (environment-define local 'a #t)
+ (environment-bound? env 'a)))
+
+ (pass-if "ref works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (environment-ref env 'a)))
+
+ (pass-if "set! works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #f)
+ (environment-set! env 'a #t)
+ (environment-ref local 'a)))
+
+ (pass-if "cells are passed through"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (let* ((local-cell (environment-cell local 'a #f))
+ (env-cell (environment-cell env 'a #f)))
+ (eq? env-cell local-cell)))))
+
+ (with-test-prefix "symbols bound in local and imported"
+
+ (pass-if "binding is visible"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-bound? env 'a)
+ (environment-define imported 'a #t)
+ (environment-define local 'a #f)
+ (environment-bound? env 'a)))
+
+ (pass-if "ref works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #f)
+ (environment-define local 'a #t)
+ (environment-ref env 'a)))
+
+ (pass-if "set! changes local"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #f)
+ (environment-define local 'a #f)
+ (environment-set! env 'a #t)
+ (environment-ref local 'a)))
+
+ (pass-if "set! does not touch imported"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (environment-define local 'a #t)
+ (environment-set! env 'a #f)
+ (environment-ref imported 'a)))
+
+ (pass-if "cells from local are passed through"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (let* ((local-cell (environment-cell local 'a #f))
+ (env-cell (environment-cell env 'a #f)))
+ (eq? env-cell local-cell)))))
+
+ (with-test-prefix "defining symbols"
+
+ (pass-if "symbols are bound in local after define"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a #t)
+ (environment-bound? local 'a)))
+
+ (pass-if "cells in local get rebound after define"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a #f)
+ (let* ((old-cell (environment-cell local 'a #f)))
+ (environment-define env 'a #f)
+ (let* ((new-cell (environment-cell local 'a #f)))
+ (not (eq? new-cell old-cell))))))
+
+ (pass-if "cells in imported get shadowed after define"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #f)
+ (environment-define env 'a #t)
+ (environment-ref local 'a))))
+
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+
+ (pass-if "reference an undefined symbol"
(catch #t
(lambda ()
(environment-ref env 'b)
(lambda args
#t)))
- (pass-if "set!ing undefined"
+ (pass-if "set! an undefined symbol"
(catch #t
(lambda ()
(environment-set! env 'b)
(lambda args
#t)))
- (pass-if "readable cell from undefined"
+ (pass-if "get a readable cell for an undefined symbol"
(catch #t
(lambda ()
(environment-cell env 'b #f)
(lambda args
#t)))
- (pass-if "writable cell from undefined"
+ (pass-if "get a writable cell for an undefined symbol"
(catch #t
(lambda ()
(environment-cell env 'b #t)
(lambda args
#t)))))
+ (with-test-prefix "eval-environment-set-local!"
- (with-test-prefix "undefine"
-
- (let* ((env (make-leaf-environment)))
-
- (pass-if "undefine defined"
- (environment-define env 'a 1)
- (and (environment-bound? env 'a)
- (begin
- (environment-undefine env 'a)
- (not (environment-bound? env 'a)))))
-
- (pass-if "undefine undefined"
- (and (not (environment-bound? env 'a))
- (begin
- (environment-undefine env 'a)
- (not (environment-bound? env 'a)))))))
+ (pass-if "documented?"
+ (documented? eval-environment-set-local!))
+
+ (pass-if "new binding becomes visible"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-bound? env 'a)
+ (environment-define new-local 'a #t)
+ (eval-environment-set-local! env new-local)
+ (environment-bound? env 'a)))
+
+ (pass-if "existing binding is replaced"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define old-local 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-local 'a #t)
+ (eval-environment-set-local! env new-local)
+ (environment-ref env 'a)))
+
+ (pass-if "undefined binding is removed"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define old-local 'a #f)
+ (environment-ref env 'a)
+ (eval-environment-set-local! env new-local)
+ (not (environment-bound? env 'a))))
+
+ (pass-if "binding in imported remains shadowed"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define imported 'a #f)
+ (environment-define old-local 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-local 'a #t)
+ (eval-environment-set-local! env new-local)
+ (environment-ref env 'a)))
+
+ (pass-if "binding in imported gets shadowed"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define imported 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-local 'a #t)
+ (eval-environment-set-local! env new-local)
+ (environment-ref env 'a)))
+
+ (pass-if "binding in imported becomes visible"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define imported 'a #t)
+ (environment-define old-local 'a #f)
+ (environment-ref env 'a)
+ (eval-environment-set-local! env new-local)
+ (environment-ref env 'a))))
+
+ (with-test-prefix "eval-environment-set-imported!"
+ (pass-if "documented?"
+ (documented? eval-environment-set-imported!))
+
+ (pass-if "new binding becomes visible"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-bound? env 'a)
+ (environment-define new-imported 'a #t)
+ (eval-environment-set-imported! env new-imported)
+ (environment-bound? env 'a)))
+
+ (pass-if "existing binding is replaced"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-define old-imported 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-imported 'a #t)
+ (eval-environment-set-imported! env new-imported)
+ (environment-ref env 'a)))
+
+ (pass-if "undefined binding is removed"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-define old-imported 'a #f)
+ (environment-ref env 'a)
+ (eval-environment-set-imported! env new-imported)
+ (not (environment-bound? env 'a))))
+
+ (pass-if "binding in imported remains shadowed"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-define local 'a #t)
+ (environment-define old-imported 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-imported 'a #t)
+ (eval-environment-set-imported! env new-imported)
+ (environment-ref env 'a)))
+
+ (pass-if "binding in imported gets shadowed"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-define local 'a #t)
+ (environment-ref env 'a)
+ (environment-define new-imported 'a #f)
+ (eval-environment-set-imported! env new-imported)
+ (environment-ref env 'a))))
- (with-test-prefix "fold"
+ (with-test-prefix "undefine"
- (let* ((env (make-leaf-environment))
- (ctr (make-adder)))
+ (pass-if "undefine an already undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-undefine env 'a)
+ #t))
- (pass-if "fold empty"
- (eq? 'success (environment-fold env folder 'success)))
+ (pass-if "undefine removes a binding from local"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (environment-undefine env 'a)
+ (not (environment-bound? local 'a))))
- (pass-if "after define"
- (environment-define env 'a (ctr 1))
- (equal? `((a . ,(ctr))) (environment-fold env folder '())))
+ (pass-if "undefine does not influence imported"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (environment-undefine env 'a)
+ (environment-bound? imported 'a)))
- (pass-if "after undefine"
+ (pass-if "undefine an imported symbol does not undefine it"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
(environment-undefine env 'a)
- (eq? 'success (environment-fold env folder 'success)))
+ (environment-bound? env 'a)))
+
+ (pass-if "undefine unshadows an imported symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (environment-define local 'a #f)
+ (environment-undefine env 'a)
+ (environment-ref env 'a))))
- (pass-if "after two defines"
- (let* ((i (ctr 1))
- (j (+ i 1)))
- (environment-define env 'a i)
- (environment-define env 'b j)
- (let ((folded (environment-fold env folder '())))
- (or (equal? folded `((a . ,i) (b . ,j)))
- (equal? folded `((b . ,j) (a . ,i)))))))
+ (with-test-prefix "fold"
- (pass-if "after set!"
- (let* ((i (environment-ref env 'a)))
- (environment-set! env 'b i)
- (let ((folded (environment-fold env folder '())))
- (or (equal? folded `((a . ,i) (b . ,i)))
- (equal? folded `((b . ,i) (a . ,i)))))))))
+ (pass-if "empty environment"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (eq? 'success (environment-fold env folder 'success))))
+
+ (pass-if "one symbol in local"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (equal? '((a . #t)) (environment-fold env folder '()))))
+
+ (pass-if "one symbol in imported"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (equal? '((a . #t)) (environment-fold env folder '()))))
+
+ (pass-if "shadowed symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (environment-define imported 'a #f)
+ (equal? '((a . #t)) (environment-fold env folder '()))))
+
+ (pass-if "one symbol each"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (environment-define imported 'b #f)
+ (let ((folded (environment-fold env folder '())))
+ (or (equal? folded '((a . #t) (b . #f)))
+ (equal? folded '((b . #f) (a . #t))))))))
(with-test-prefix "observe"
- (let* ((env (make-leaf-environment))
- (tag #f)
- (func (lambda (env) (set! tag (not tag))))
- (observer #f))
-
- (pass-if "observe unobserved"
- (set! observer (environment-observe env func))
- #t)
-
- (pass-if "define undefined"
- (set! tag #f)
+ (pass-if "observe an environment"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-observe env (make-observer-func))
+ #t))
+
+ (pass-if "observe an environment twice"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (observer-1 (environment-observe env (make-observer-func)))
+ (observer-2 (environment-observe env (make-observer-func))))
+ (not (eq? observer-1 observer-2))))
+
+ (pass-if "definition of an undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
+ (environment-observe env func)
(environment-define env 'a 1)
- tag)
+ (eqv? (func) 1)))
- (pass-if "define defined"
- (set! tag #f)
+ (pass-if "definition of an already defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
(environment-define env 'a 1)
- tag)
-
- (pass-if "set! defined"
- (set! tag #t)
- (environment-set! env 'a 1)
- tag)
-
- (pass-if "undefine defined"
- (set! tag #f)
- (environment-undefine env 'a)
- tag)
-
- (pass-if "undefine undefined"
- (set! tag #t)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1))))
+
+ (pass-if "set!ing of a defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-set! env 'a 1)
+ (eqv? (func) 0))))
+
+ (pass-if "undefining a defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 1))))
+
+ (pass-if "undefining an already undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
+ (environment-observe env func)
(environment-undefine env 'a)
- tag)
-
- (pass-if "unobserve observed"
- (set! tag #t)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an active observer"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func))
+ (observer (environment-observe env func)))
(environment-unobserve observer)
(environment-define env 'a 1)
- tag)
-
- (pass-if "unobserve unobserved"
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an inactive observer"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func))
+ (observer (environment-observe env func)))
+ (environment-unobserve observer)
(environment-unobserve observer)
#t)))
(with-test-prefix "observe-weak"
- (let* ((env (make-leaf-environment))
- (tag #f)
- (func (lambda (env) (set! tag (not tag))))
- (observer #f))
-
- (pass-if "weak-observe unobserved"
- (set! observer (environment-observe-weak env func))
- #t)
-
- (pass-if "define undefined"
- (set! tag #f)
+ (pass-if "observe an environment"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-observe-weak env (make-observer-func))
+ #t))
+
+ (pass-if "observe an environment twice"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (observer-1 (environment-observe-weak env (make-observer-func)))
+ (observer-2 (environment-observe-weak env (make-observer-func))))
+ (not (eq? observer-1 observer-2))))
+
+ (pass-if "definition of an undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
(environment-define env 'a 1)
- tag)
+ (eqv? (func) 1)))
- (pass-if "define defined"
- (set! tag #f)
+ (pass-if "definition of an already defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
(environment-define env 'a 1)
- tag)
-
- (pass-if "set! defined"
- (set! tag #t)
- (environment-set! env 'a 1)
- tag)
-
- (pass-if "undefine defined"
- (set! tag #f)
- (environment-undefine env 'a)
- tag)
-
- (pass-if "undefine undefined"
- (set! tag #t)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1))))
+
+ (pass-if "set!ing of a defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-set! env 'a 1)
+ (eqv? (func) 0))))
+
+ (pass-if "undefining a defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 1))))
+
+ (pass-if "undefining an already undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
(environment-undefine env 'a)
- tag)
-
- (pass-if "unobserve observed"
- (set! tag #t)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an active observer"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func))
+ (observer (environment-observe-weak env func)))
(environment-unobserve observer)
(environment-define env 'a 1)
- tag)
-
- (pass-if "unobserve unobserved"
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an inactive observer"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func))
+ (observer (environment-observe-weak env func)))
(environment-unobserve observer)
- #t)
-
- (pass-if "weak observer gets collected"
- (gc)
+ (environment-unobserve observer)
+ #t))
+
+ (pass-if "weak observer gets collected"
+ (gc)
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
(environment-observe-weak env func)
- (set! tag #f)
+ (gc)
(environment-define env 'a 1)
- (and tag
- (begin
- (gc)
- (environment-define env 'a 1)
- tag)))))
-
-
- (with-test-prefix "observer-errors"
-
- (let* ((env (make-leaf-environment))
- (tag-1 #f)
- (tag-2 #f)
- (func-1 (lambda (env)
- (set! tag-1 (not tag-1))
- (error)))
- (func-2 (lambda (env)
- (set! tag-2 (not tag-2))
- (error))))
-
- (pass-if "update continues after error"
+ (eqv? (func) 0))))
+
+
+ (with-test-prefix "erroneous observers"
+
+ (pass-if "update continues after error"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func-1 (make-erroneous-observer-func))
+ (func-2 (make-erroneous-observer-func)))
(environment-observe env func-1)
(environment-observe env func-2)
(catch #t
(environment-define env 'a 1)
#f)
(lambda args
- (and tag-1 tag-2)))))))
\ No newline at end of file
+ (and (eq? (func-1) 1)
+ (eq? (func-2) 1))))))))
+
+
+;;;
+;;; leaf-environment based import-environments
+;;;
+
+(with-test-prefix "leaf-environment based import-environments"
+
+ (with-test-prefix "import-environment?"
+
+ (pass-if "documented?"
+ (documented? import-environment?))
+
+ (pass-if "non-environment-object"
+ (not (import-environment? #f)))
+
+ (pass-if "leaf-environment-object"
+ (not (import-environment? (make-leaf-environment))))
+
+ (pass-if "eval-environment-object"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (not (import-environment? (make-leaf-environment))))))
+
+
+ (with-test-prefix "make-import-environment"
+
+ (pass-if "documented?"
+ (documented? make-import-environment))))
+
HCoop / bpt / guile.git / commitdiff