test-suite/tests/environments.test

   1 ;;;; environments.test                                    -*- scheme -*-
   2 ;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the GNU Lesser General Public
   6 ;;;; License as published by the Free Software Foundation; either
   7 ;;;; version 2.1 of the License, or (at your option) any later version.
   8 ;;;;
   9 ;;;; This library is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;;; Lesser General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU Lesser General Public
  15 ;;;; License along with this library; if not, write to the Free Software
  16 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17
  18 (use-modules (ice-9 documentation))
  19
  20 ;;; environments are currently commented out of libguile, so these
  21 ;;; tests must be commented out also. - NJ 2006-11-02.
  22 (if #f (let ()
  23
  24 ;;;
  25 ;;; miscellaneous
  26 ;;;
  27
  28 (define exception:unbound-symbol
  29   (cons 'misc-error "^Symbol .* not bound in environment"))
  30
  31 (define (documented? object)
  32   (not (not (object-documentation object))))
  33
  34 (define (folder sym val res)
  35   (cons (cons sym val) res))
  36
  37 (define (make-observer-func)
  38   (let* ((counter 0))
  39     (lambda args
  40       (if (null? args)
  41           counter
  42           (set! counter (+ counter 1))))))
  43
  44 (define (make-erroneous-observer-func)
  45   (let* ((func (make-observer-func)))
  46     (lambda args
  47       (if (null? args)
  48           (func)
  49           (begin
  50             (func args)
  51             (error))))))
  52
  53 ;;;
  54 ;;; leaf-environments
  55 ;;;
  56
  57 (with-test-prefix "leaf-environments"
  58
  59   (with-test-prefix "leaf-environment?"
  60
  61     (pass-if "documented?"
  62       (documented? leaf-environment?))
  63
  64     (pass-if "non-environment-object"
  65       (not (leaf-environment? #f))))
  66
  67
  68   (with-test-prefix "make-leaf-environment"
  69
  70     (pass-if "documented?"
  71       (documented? make-leaf-environment))
  72
  73     (pass-if "produces an environment"
  74       (environment? (make-leaf-environment)))
  75
  76     (pass-if "produces a leaf-environment"
  77       (leaf-environment? (make-leaf-environment)))
  78
  79     (pass-if "produces always a new environment"
  80       (not (eq? (make-leaf-environment) (make-leaf-environment)))))
  81
  82
  83   (with-test-prefix "bound, define, ref, set!, cell"
  84
  85     (pass-if "symbols are unbound by default"
  86       (let* ((env (make-leaf-environment)))
  87         (and (not (environment-bound? env 'a))
  88              (not (environment-bound? env 'b))
  89              (not (environment-bound? env 'c)))))
  90
  91     (pass-if "symbol is bound after define"
  92       (let* ((env (make-leaf-environment)))
  93         (environment-bound? env 'a)
  94         (environment-define env 'a #t)
  95         (environment-bound? env 'a)))
  96
  97     (pass-if "ref a defined symbol"
  98       (let* ((env (make-leaf-environment)))
  99         (environment-bound? env 'a)
 100         (environment-bound? env 'b)
 101         (environment-define env 'a #t)
 102         (environment-define env 'b #f)
 103         (and (environment-ref env 'a)
 104              (not (environment-ref env 'b)))))
 105
 106     (pass-if "set! a defined symbol"
 107       (let* ((env (make-leaf-environment)))
 108         (environment-define env 'a #t)
 109         (environment-define env 'b #f)
 110         (environment-ref env 'a)
 111         (environment-ref env 'b)
 112         (environment-set! env 'a #f)
 113         (environment-set! env 'b #t)
 114         (and (not (environment-ref env 'a))
 115              (environment-ref env 'b))))
 116
 117     (pass-if "get a read-only cell"
 118       (let* ((env (make-leaf-environment)))
 119         (environment-define env 'a #t)
 120         (let* ((cell (environment-cell env 'a #f)))
 121           (and (cdr cell)
 122                (begin
 123                  (environment-set! env 'a #f)
 124                  (not (cdr cell)))))))
 125
 126     (pass-if "a read-only cell gets rebound after define"
 127       (let* ((env (make-leaf-environment)))
 128         (environment-define env 'a #t)
 129         (let* ((cell (environment-cell env 'a #f)))
 130           (environment-define env 'a #f)
 131           (not (eq? (environment-cell env 'a #f) cell)))))
 132
 133     (pass-if "get a writable cell"
 134       (let* ((env (make-leaf-environment)))
 135         (environment-define env 'a #t)
 136         (let* ((readable (environment-cell env 'a #f))
 137                (writable (environment-cell env 'a #t)))
 138           (and (eq? readable writable)
 139                (begin
 140                  (environment-set! env 'a #f)
 141                  (not (cdr writable)))
 142                (begin
 143                  (set-cdr! writable #t)
 144                  (environment-ref env 'a))
 145                (begin
 146                  (set-cdr! (environment-cell env 'a #t) #f)
 147                  (not (cdr writable)))))))
 148
 149     (pass-if "a writable cell gets rebound after define"
 150       (let* ((env (make-leaf-environment)))
 151         (environment-define env 'a #t)
 152         (let* ((cell (environment-cell env 'a #t)))
 153           (environment-define env 'a #f)
 154           (not (eq? (environment-cell env 'a #t) cell)))))
 155
 156     (pass-if-exception "reference an unbound symbol"
 157       exception:unbound-symbol
 158       (environment-ref (make-leaf-environment) 'a))
 159
 160     (pass-if-exception "set! an unbound symbol"
 161       exception:unbound-symbol
 162       (environment-set! (make-leaf-environment) 'a #f))
 163
 164     (pass-if-exception "get a readable cell for an unbound symbol"
 165       exception:unbound-symbol
 166       (environment-cell (make-leaf-environment) 'a #f))
 167
 168     (pass-if-exception "get a writable cell for an unbound symbol"
 169       exception:unbound-symbol
 170       (environment-cell (make-leaf-environment) 'a #t)))
 171
 172
 173   (with-test-prefix "undefine"
 174
 175     (pass-if "undefine a defined symbol"
 176       (let* ((env (make-leaf-environment)))
 177         (environment-define env 'a 1)
 178         (environment-ref env 'a)
 179         (environment-undefine env 'a)
 180         (not (environment-bound? env 'a))))
 181
 182     (pass-if "undefine an already undefined symbol"
 183       (environment-undefine (make-leaf-environment) 'a)
 184       #t))
 185
 186
 187   (with-test-prefix "fold"
 188
 189     (pass-if "empty environment"
 190       (let* ((env (make-leaf-environment)))
 191         (eq? 'success (environment-fold env folder 'success))))
 192
 193     (pass-if "one symbol"
 194       (let* ((env (make-leaf-environment)))
 195         (environment-define env 'a #t)
 196         (equal? '((a . #t)) (environment-fold env folder '()))))
 197
 198     (pass-if "two symbols"
 199       (let* ((env (make-leaf-environment)))
 200         (environment-define env 'a #t)
 201         (environment-define env 'b #f)
 202         (let ((folded (environment-fold env folder '())))
 203           (or (equal? folded '((a . #t) (b . #f)))
 204               (equal? folded '((b . #f) (a . #t))))))))
 205
 206
 207   (with-test-prefix "observe"
 208
 209     (pass-if "observe an environment"
 210       (let* ((env (make-leaf-environment)))
 211         (environment-observe env (make-observer-func))
 212         #t))
 213
 214     (pass-if "observe an environment twice"
 215       (let* ((env (make-leaf-environment))
 216              (observer-1 (environment-observe env (make-observer-func)))
 217              (observer-2 (environment-observe env (make-observer-func))))
 218         (not (eq? observer-1 observer-2))))
 219
 220     (pass-if "definition of an undefined symbol"
 221       (let* ((env (make-leaf-environment))
 222              (func (make-observer-func)))
 223         (environment-observe env func)
 224         (environment-define env 'a 1)
 225         (eqv? (func) 1)))
 226
 227     (pass-if "definition of an already defined symbol"
 228       (let* ((env (make-leaf-environment)))
 229         (environment-define env 'a 1)
 230         (let* ((func (make-observer-func)))
 231           (environment-observe env func)
 232           (environment-define env 'a 1)
 233           (eqv? (func) 1))))
 234
 235     (pass-if "set!ing of a defined symbol"
 236       (let* ((env (make-leaf-environment)))
 237         (environment-define env 'a 1)
 238         (let* ((func (make-observer-func)))
 239           (environment-observe env func)
 240           (environment-set! env 'a 1)
 241           (eqv? (func) 0))))
 242
 243     (pass-if "undefining a defined symbol"
 244       (let* ((env (make-leaf-environment)))
 245         (environment-define env 'a 1)
 246         (let* ((func (make-observer-func)))
 247           (environment-observe env func)
 248           (environment-undefine env 'a)
 249           (eqv? (func) 1))))
 250
 251     (pass-if "undefining an already undefined symbol"
 252       (let* ((env (make-leaf-environment))
 253              (func (make-observer-func)))
 254         (environment-observe env func)
 255         (environment-undefine env 'a)
 256         (eqv? (func) 0)))
 257
 258     (pass-if "unobserve an active observer"
 259       (let* ((env (make-leaf-environment))
 260              (func (make-observer-func))
 261              (observer (environment-observe env func)))
 262         (environment-unobserve observer)
 263         (environment-define env 'a 1)
 264         (eqv? (func) 0)))
 265
 266     (pass-if "unobserve an inactive observer"
 267       (let* ((env (make-leaf-environment))
 268              (func (make-observer-func))
 269              (observer (environment-observe env func)))
 270         (environment-unobserve observer)
 271         (environment-unobserve observer)
 272         #t)))
 273
 274
 275   (with-test-prefix "observe-weak"
 276
 277     (pass-if "observe an environment"
 278       (let* ((env (make-leaf-environment)))
 279         (environment-observe-weak env (make-observer-func))
 280         #t))
 281
 282     (pass-if "observe an environment twice"
 283       (let* ((env (make-leaf-environment))
 284              (observer-1 (environment-observe-weak env (make-observer-func)))
 285              (observer-2 (environment-observe-weak env (make-observer-func))))
 286         (not (eq? observer-1 observer-2))))
 287
 288     (pass-if "definition of an undefined symbol"
 289       (let* ((env (make-leaf-environment))
 290              (func (make-observer-func)))
 291         (environment-observe-weak env func)
 292         (environment-define env 'a 1)
 293         (eqv? (func) 1)))
 294
 295     (pass-if "definition of an already defined symbol"
 296       (let* ((env (make-leaf-environment)))
 297         (environment-define env 'a 1)
 298         (let* ((func (make-observer-func)))
 299           (environment-observe-weak env func)
 300           (environment-define env 'a 1)
 301           (eqv? (func) 1))))
 302
 303     (pass-if "set!ing of a defined symbol"
 304       (let* ((env (make-leaf-environment)))
 305         (environment-define env 'a 1)
 306         (let* ((func (make-observer-func)))
 307           (environment-observe-weak env func)
 308           (environment-set! env 'a 1)
 309           (eqv? (func) 0))))
 310
 311     (pass-if "undefining a defined symbol"
 312       (let* ((env (make-leaf-environment)))
 313         (environment-define env 'a 1)
 314         (let* ((func (make-observer-func)))
 315           (environment-observe-weak env func)
 316           (environment-undefine env 'a)
 317           (eqv? (func) 1))))
 318
 319     (pass-if "undefining an already undefined symbol"
 320       (let* ((env (make-leaf-environment))
 321              (func (make-observer-func)))
 322         (environment-observe-weak env func)
 323         (environment-undefine env 'a)
 324         (eqv? (func) 0)))
 325
 326     (pass-if "unobserve an active observer"
 327       (let* ((env (make-leaf-environment))
 328              (func (make-observer-func))
 329              (observer (environment-observe-weak env func)))
 330         (environment-unobserve observer)
 331         (environment-define env 'a 1)
 332         (eqv? (func) 0)))
 333
 334     (pass-if "unobserve an inactive observer"
 335       (let* ((env (make-leaf-environment))
 336              (func (make-observer-func))
 337              (observer (environment-observe-weak env func)))
 338         (environment-unobserve observer)
 339         (environment-unobserve observer)
 340         #t))
 341
 342     (pass-if "weak observer gets collected"
 343       (gc)
 344       (let* ((env (make-leaf-environment))
 345              (func (make-observer-func)))
 346         (environment-observe-weak env func)
 347         (gc)
 348         (environment-define env 'a 1)
 349         (if (not (eqv? (func) 0))
 350             (throw 'unresolved) ; note: conservative scanning
 351             #t))))
 352
 353
 354   (with-test-prefix "erroneous observers"
 355
 356     (pass-if "update continues after error"
 357       (let* ((env (make-leaf-environment))
 358              (func-1 (make-erroneous-observer-func))
 359              (func-2 (make-erroneous-observer-func)))
 360         (environment-observe env func-1)
 361         (environment-observe env func-2)
 362         (catch #t
 363           (lambda ()
 364             (environment-define env 'a 1)
 365             #f)
 366           (lambda args
 367             (and (eq? (func-1) 1)
 368                  (eq? (func-2) 1))))))))
 369
 370
 371 ;;;
 372 ;;; leaf-environment based eval-environments
 373 ;;;
 374
 375 (with-test-prefix "leaf-environment based eval-environments"
 376
 377   (with-test-prefix "eval-environment?"
 378
 379     (pass-if "documented?"
 380       (documented? eval-environment?))
 381
 382     (pass-if "non-environment-object"
 383       (not (eval-environment? #f)))
 384
 385     (pass-if "leaf-environment-object"
 386       (not (eval-environment? (make-leaf-environment)))))
 387
 388
 389   (with-test-prefix "make-eval-environment"
 390
 391     (pass-if "documented?"
 392       (documented? make-eval-environment))
 393
 394     (let* ((local (make-leaf-environment))
 395            (imported (make-leaf-environment)))
 396
 397       (pass-if "produces an environment"
 398         (environment? (make-eval-environment local imported)))
 399
 400       (pass-if "produces an eval-environment"
 401         (eval-environment? (make-eval-environment local imported)))
 402
 403       (pass-if "produces always a new environment"
 404         (not (eq? (make-eval-environment local imported)
 405                   (make-eval-environment local imported))))))
 406
 407
 408   (with-test-prefix "eval-environment-local"
 409
 410     (pass-if "documented?"
 411       (documented? eval-environment-local))
 412
 413     (pass-if "returns local"
 414       (let* ((local (make-leaf-environment))
 415              (imported (make-leaf-environment))
 416              (env (make-eval-environment local imported)))
 417         (eq? (eval-environment-local env) local))))
 418
 419
 420   (with-test-prefix "eval-environment-imported"
 421
 422     (pass-if "documented?"
 423       (documented? eval-environment-imported))
 424
 425     (pass-if "returns imported"
 426       (let* ((local (make-leaf-environment))
 427              (imported (make-leaf-environment))
 428              (env (make-eval-environment local imported)))
 429         (eq? (eval-environment-imported env) imported))))
 430
 431
 432   (with-test-prefix "bound, define, ref, set!, cell"
 433
 434     (pass-if "symbols are unbound by default"
 435       (let* ((local (make-leaf-environment))
 436              (imported (make-leaf-environment))
 437              (env (make-eval-environment local imported)))
 438         (and (not (environment-bound? env 'a))
 439              (not (environment-bound? env 'b))
 440              (not (environment-bound? env 'c)))))
 441
 442     (with-test-prefix "symbols bound in imported"
 443
 444       (pass-if "binding is visible"
 445         (let* ((local (make-leaf-environment))
 446                (imported (make-leaf-environment))
 447                (env (make-eval-environment local imported)))
 448           (environment-bound? env 'a)
 449           (environment-define imported 'a #t)
 450           (environment-bound? env 'a)))
 451
 452       (pass-if "ref works"
 453         (let* ((local (make-leaf-environment))
 454                (imported (make-leaf-environment))
 455                (env (make-eval-environment local imported)))
 456           (environment-bound? env 'a)
 457           (environment-define imported 'a #t)
 458           (environment-ref env 'a)))
 459
 460       (pass-if "set! works"
 461         (let* ((local (make-leaf-environment))
 462                (imported (make-leaf-environment))
 463                (env (make-eval-environment local imported)))
 464           (environment-define imported 'a #f)
 465           (environment-set! env 'a #t)
 466           (environment-ref imported 'a)))
 467
 468       (pass-if "cells are passed through"
 469         (let* ((local (make-leaf-environment))
 470                (imported (make-leaf-environment))
 471                (env (make-eval-environment local imported)))
 472           (environment-define imported 'a #t)
 473           (let* ((imported-cell (environment-cell imported 'a #f))
 474                  (env-cell (environment-cell env 'a #f)))
 475             (eq? env-cell imported-cell)))))
 476
 477     (with-test-prefix "symbols bound in local"
 478
 479       (pass-if "binding is visible"
 480         (let* ((local (make-leaf-environment))
 481                (imported (make-leaf-environment))
 482                (env (make-eval-environment local imported)))
 483           (environment-bound? env 'a)
 484           (environment-define local 'a #t)
 485           (environment-bound? env 'a)))
 486
 487       (pass-if "ref works"
 488         (let* ((local (make-leaf-environment))
 489                (imported (make-leaf-environment))
 490                (env (make-eval-environment local imported)))
 491           (environment-define local 'a #t)
 492           (environment-ref env 'a)))
 493
 494       (pass-if "set! works"
 495         (let* ((local (make-leaf-environment))
 496                (imported (make-leaf-environment))
 497                (env (make-eval-environment local imported)))
 498           (environment-define local 'a #f)
 499           (environment-set! env 'a #t)
 500           (environment-ref local 'a)))
 501
 502       (pass-if "cells are passed through"
 503         (let* ((local (make-leaf-environment))
 504                (imported (make-leaf-environment))
 505                (env (make-eval-environment local imported)))
 506           (environment-define local 'a #t)
 507           (let* ((local-cell (environment-cell local 'a #f))
 508                  (env-cell (environment-cell env 'a #f)))
 509             (eq? env-cell local-cell)))))
 510
 511     (with-test-prefix "symbols bound in local and imported"
 512
 513       (pass-if "binding is visible"
 514         (let* ((local (make-leaf-environment))
 515                (imported (make-leaf-environment))
 516                (env (make-eval-environment local imported)))
 517           (environment-bound? env 'a)
 518           (environment-define imported 'a #t)
 519           (environment-define local 'a #f)
 520           (environment-bound? env 'a)))
 521
 522       (pass-if "ref works"
 523         (let* ((local (make-leaf-environment))
 524                (imported (make-leaf-environment))
 525                (env (make-eval-environment local imported)))
 526           (environment-define imported 'a #f)
 527           (environment-define local 'a #t)
 528           (environment-ref env 'a)))
 529
 530       (pass-if "set! changes local"
 531         (let* ((local (make-leaf-environment))
 532                (imported (make-leaf-environment))
 533                (env (make-eval-environment local imported)))
 534           (environment-define imported 'a #f)
 535           (environment-define local 'a #f)
 536           (environment-set! env 'a #t)
 537           (environment-ref local 'a)))
 538
 539       (pass-if "set! does not touch imported"
 540         (let* ((local (make-leaf-environment))
 541                (imported (make-leaf-environment))
 542                (env (make-eval-environment local imported)))
 543           (environment-define imported 'a #t)
 544           (environment-define local 'a #t)
 545           (environment-set! env 'a #f)
 546           (environment-ref imported 'a)))
 547
 548       (pass-if "cells from local are passed through"
 549         (let* ((local (make-leaf-environment))
 550                (imported (make-leaf-environment))
 551                (env (make-eval-environment local imported)))
 552           (environment-define local 'a #t)
 553           (let* ((local-cell (environment-cell local 'a #f))
 554                  (env-cell (environment-cell env 'a #f)))
 555             (eq? env-cell local-cell)))))
 556
 557     (with-test-prefix "defining symbols"
 558
 559       (pass-if "symbols are bound in local after define"
 560         (let* ((local (make-leaf-environment))
 561                (imported (make-leaf-environment))
 562                (env (make-eval-environment local imported)))
 563           (environment-define env 'a #t)
 564           (environment-bound? local 'a)))
 565
 566       (pass-if "cells in local get rebound after define"
 567         (let* ((local (make-leaf-environment))
 568                (imported (make-leaf-environment))
 569                (env (make-eval-environment local imported)))
 570           (environment-define env 'a #f)
 571           (let* ((old-cell (environment-cell local 'a #f)))
 572             (environment-define env 'a #f)
 573             (let* ((new-cell (environment-cell local 'a #f)))
 574               (not (eq? new-cell old-cell))))))
 575
 576       (pass-if "cells in imported get shadowed after define"
 577         (let* ((local (make-leaf-environment))
 578                (imported (make-leaf-environment))
 579                (env (make-eval-environment local imported)))
 580           (environment-define imported 'a #f)
 581           (environment-define env 'a #t)
 582           (environment-ref local 'a))))
 583
 584     (let* ((local (make-leaf-environment))
 585            (imported (make-leaf-environment))
 586            (env (make-eval-environment local imported)))
 587
 588       (pass-if-exception "reference an unbound symbol"
 589         exception:unbound-symbol
 590         (environment-ref env 'b))
 591
 592       (pass-if-exception "set! an unbound symbol"
 593         exception:unbound-symbol
 594         (environment-set! env 'b #f))
 595
 596       (pass-if-exception "get a readable cell for an unbound symbol"
 597         exception:unbound-symbol
 598         (environment-cell env 'b #f))
 599
 600       (pass-if-exception "get a writable cell for an unbound symbol"
 601         exception:unbound-symbol
 602         (environment-cell env 'b #t))))
 603
 604   (with-test-prefix "eval-environment-set-local!"
 605
 606     (pass-if "documented?"
 607       (documented? eval-environment-set-local!))
 608
 609     (pass-if "new binding becomes visible"
 610       (let* ((old-local (make-leaf-environment))
 611              (new-local (make-leaf-environment))
 612              (imported (make-leaf-environment))
 613              (env (make-eval-environment old-local imported)))
 614         (environment-bound? env 'a)
 615         (environment-define new-local 'a #t)
 616         (eval-environment-set-local! env new-local)
 617         (environment-bound? env 'a)))
 618
 619     (pass-if "existing binding is replaced"
 620       (let* ((old-local (make-leaf-environment))
 621              (new-local (make-leaf-environment))
 622              (imported (make-leaf-environment))
 623              (env (make-eval-environment old-local imported)))
 624         (environment-define old-local 'a #f)
 625         (environment-ref env 'a)
 626         (environment-define new-local 'a #t)
 627         (eval-environment-set-local! env new-local)
 628         (environment-ref env 'a)))
 629
 630     (pass-if "undefined binding is removed"
 631       (let* ((old-local (make-leaf-environment))
 632              (new-local (make-leaf-environment))
 633              (imported (make-leaf-environment))
 634              (env (make-eval-environment old-local imported)))
 635         (environment-define old-local 'a #f)
 636         (environment-ref env 'a)
 637         (eval-environment-set-local! env new-local)
 638         (not (environment-bound? env 'a))))
 639
 640     (pass-if "binding in imported remains shadowed"
 641       (let* ((old-local (make-leaf-environment))
 642              (new-local (make-leaf-environment))
 643              (imported (make-leaf-environment))
 644              (env (make-eval-environment old-local imported)))
 645         (environment-define imported 'a #f)
 646         (environment-define old-local 'a #f)
 647         (environment-ref env 'a)
 648         (environment-define new-local 'a #t)
 649         (eval-environment-set-local! env new-local)
 650         (environment-ref env 'a)))
 651
 652     (pass-if "binding in imported gets shadowed"
 653       (let* ((old-local (make-leaf-environment))
 654              (new-local (make-leaf-environment))
 655              (imported (make-leaf-environment))
 656              (env (make-eval-environment old-local imported)))
 657         (environment-define imported 'a #f)
 658         (environment-ref env 'a)
 659         (environment-define new-local 'a #t)
 660         (eval-environment-set-local! env new-local)
 661         (environment-ref env 'a)))
 662
 663     (pass-if "binding in imported becomes visible"
 664       (let* ((old-local (make-leaf-environment))
 665              (new-local (make-leaf-environment))
 666              (imported (make-leaf-environment))
 667              (env (make-eval-environment old-local imported)))
 668         (environment-define imported 'a #t)
 669         (environment-define old-local 'a #f)
 670         (environment-ref env 'a)
 671         (eval-environment-set-local! env new-local)
 672         (environment-ref env 'a))))
 673
 674   (with-test-prefix "eval-environment-set-imported!"
 675
 676     (pass-if "documented?"
 677       (documented? eval-environment-set-imported!))
 678
 679     (pass-if "new binding becomes visible"
 680       (let* ((local (make-leaf-environment))
 681              (old-imported (make-leaf-environment))
 682              (new-imported (make-leaf-environment))
 683              (env (make-eval-environment local old-imported)))
 684         (environment-bound? env 'a)
 685         (environment-define new-imported 'a #t)
 686         (eval-environment-set-imported! env new-imported)
 687         (environment-bound? env 'a)))
 688
 689     (pass-if "existing binding is replaced"
 690       (let* ((local (make-leaf-environment))
 691              (old-imported (make-leaf-environment))
 692              (new-imported (make-leaf-environment))
 693              (env (make-eval-environment local old-imported)))
 694         (environment-define old-imported 'a #f)
 695         (environment-ref env 'a)
 696         (environment-define new-imported 'a #t)
 697         (eval-environment-set-imported! env new-imported)
 698         (environment-ref env 'a)))
 699
 700     (pass-if "undefined binding is removed"
 701       (let* ((local (make-leaf-environment))
 702              (old-imported (make-leaf-environment))
 703              (new-imported (make-leaf-environment))
 704              (env (make-eval-environment local old-imported)))
 705         (environment-define old-imported 'a #f)
 706         (environment-ref env 'a)
 707         (eval-environment-set-imported! env new-imported)
 708         (not (environment-bound? env 'a))))
 709
 710     (pass-if "binding in imported remains shadowed"
 711       (let* ((local (make-leaf-environment))
 712              (old-imported (make-leaf-environment))
 713              (new-imported (make-leaf-environment))
 714              (env (make-eval-environment local old-imported)))
 715         (environment-define local 'a #t)
 716         (environment-define old-imported 'a #f)
 717         (environment-ref env 'a)
 718         (environment-define new-imported 'a #t)
 719         (eval-environment-set-imported! env new-imported)
 720         (environment-ref env 'a)))
 721
 722     (pass-if "binding in imported gets shadowed"
 723       (let* ((local (make-leaf-environment))
 724              (old-imported (make-leaf-environment))
 725              (new-imported (make-leaf-environment))
 726              (env (make-eval-environment local old-imported)))
 727         (environment-define local 'a #t)
 728         (environment-ref env 'a)
 729         (environment-define new-imported 'a #f)
 730         (eval-environment-set-imported! env new-imported)
 731         (environment-ref env 'a))))
 732
 733   (with-test-prefix "undefine"
 734
 735     (pass-if "undefine an already undefined symbol"
 736       (let* ((local (make-leaf-environment))
 737              (imported (make-leaf-environment))
 738              (env (make-eval-environment local imported)))
 739         (environment-undefine env 'a)
 740         #t))
 741
 742     (pass-if "undefine removes a binding from local"
 743       (let* ((local (make-leaf-environment))
 744              (imported (make-leaf-environment))
 745              (env (make-eval-environment local imported)))
 746         (environment-define local 'a #t)
 747         (environment-undefine env 'a)
 748         (not (environment-bound? local 'a))))
 749
 750     (pass-if "undefine does not influence imported"
 751       (let* ((local (make-leaf-environment))
 752              (imported (make-leaf-environment))
 753              (env (make-eval-environment local imported)))
 754         (environment-define imported 'a #t)
 755         (environment-undefine env 'a)
 756         (environment-bound? imported 'a)))
 757
 758     (pass-if "undefine an imported symbol does not undefine it"
 759       (let* ((local (make-leaf-environment))
 760              (imported (make-leaf-environment))
 761              (env (make-eval-environment local imported)))
 762         (environment-define imported 'a #t)
 763         (environment-undefine env 'a)
 764         (environment-bound? env 'a)))
 765
 766     (pass-if "undefine unshadows an imported symbol"
 767       (let* ((local (make-leaf-environment))
 768              (imported (make-leaf-environment))
 769              (env (make-eval-environment local imported)))
 770         (environment-define imported 'a #t)
 771         (environment-define local 'a #f)
 772         (environment-undefine env 'a)
 773         (environment-ref env 'a))))
 774
 775   (with-test-prefix "fold"
 776
 777     (pass-if "empty environment"
 778       (let* ((local (make-leaf-environment))
 779              (imported (make-leaf-environment))
 780              (env (make-eval-environment local imported)))
 781         (eq? 'success (environment-fold env folder 'success))))
 782
 783     (pass-if "one symbol in local"
 784       (let* ((local (make-leaf-environment))
 785              (imported (make-leaf-environment))
 786              (env (make-eval-environment local imported)))
 787         (environment-define local 'a #t)
 788         (equal? '((a . #t)) (environment-fold env folder '()))))
 789
 790     (pass-if "one symbol in imported"
 791       (let* ((local (make-leaf-environment))
 792              (imported (make-leaf-environment))
 793              (env (make-eval-environment local imported)))
 794         (environment-define imported 'a #t)
 795         (equal? '((a . #t)) (environment-fold env folder '()))))
 796
 797     (pass-if "shadowed symbol"
 798       (let* ((local (make-leaf-environment))
 799              (imported (make-leaf-environment))
 800              (env (make-eval-environment local imported)))
 801         (environment-define local 'a #t)
 802         (environment-define imported 'a #f)
 803         (equal? '((a . #t)) (environment-fold env folder '()))))
 804
 805     (pass-if "one symbol each"
 806       (let* ((local (make-leaf-environment))
 807              (imported (make-leaf-environment))
 808              (env (make-eval-environment local imported)))
 809         (environment-define local 'a #t)
 810         (environment-define imported 'b #f)
 811         (let ((folded (environment-fold env folder '())))
 812           (or (equal? folded '((a . #t) (b . #f)))
 813               (equal? folded '((b . #f) (a . #t))))))))
 814
 815
 816   (with-test-prefix "observe"
 817
 818     (pass-if "observe an environment"
 819       (let* ((local (make-leaf-environment))
 820              (imported (make-leaf-environment))
 821              (env (make-eval-environment local imported)))
 822         (environment-observe env (make-observer-func))
 823         #t))
 824
 825     (pass-if "observe an environment twice"
 826       (let* ((local (make-leaf-environment))
 827              (imported (make-leaf-environment))
 828              (env (make-eval-environment local imported))
 829              (observer-1 (environment-observe env (make-observer-func)))
 830              (observer-2 (environment-observe env (make-observer-func))))
 831         (not (eq? observer-1 observer-2))))
 832
 833     (pass-if "definition of an undefined symbol"
 834       (let* ((local (make-leaf-environment))
 835              (imported (make-leaf-environment))
 836              (env (make-eval-environment local imported))
 837              (func (make-observer-func)))
 838         (environment-observe env func)
 839         (environment-define env 'a 1)
 840         (eqv? (func) 1)))
 841
 842     (pass-if "definition of an already defined symbol"
 843       (let* ((local (make-leaf-environment))
 844              (imported (make-leaf-environment))
 845              (env (make-eval-environment local imported)))
 846         (environment-define env 'a 1)
 847         (let* ((func (make-observer-func)))
 848           (environment-observe env func)
 849           (environment-define env 'a 1)
 850           (eqv? (func) 1))))
 851
 852     (pass-if "set!ing of a defined symbol"
 853       (let* ((local (make-leaf-environment))
 854              (imported (make-leaf-environment))
 855              (env (make-eval-environment local imported)))
 856         (environment-define env 'a 1)
 857         (let* ((func (make-observer-func)))
 858           (environment-observe env func)
 859           (environment-set! env 'a 1)
 860           (eqv? (func) 0))))
 861
 862     (pass-if "undefining a defined symbol"
 863       (let* ((local (make-leaf-environment))
 864              (imported (make-leaf-environment))
 865              (env (make-eval-environment local imported)))
 866         (environment-define env 'a 1)
 867         (let* ((func (make-observer-func)))
 868           (environment-observe env func)
 869           (environment-undefine env 'a)
 870           (eqv? (func) 1))))
 871
 872     (pass-if "undefining an already undefined symbol"
 873       (let* ((local (make-leaf-environment))
 874              (imported (make-leaf-environment))
 875              (env (make-eval-environment local imported))
 876              (func (make-observer-func)))
 877         (environment-observe env func)
 878         (environment-undefine env 'a)
 879         (eqv? (func) 0)))
 880
 881     (pass-if "unobserve an active observer"
 882       (let* ((local (make-leaf-environment))
 883              (imported (make-leaf-environment))
 884              (env (make-eval-environment local imported))
 885              (func (make-observer-func))
 886              (observer (environment-observe env func)))
 887         (environment-unobserve observer)
 888         (environment-define env 'a 1)
 889         (eqv? (func) 0)))
 890
 891     (pass-if "unobserve an inactive observer"
 892       (let* ((local (make-leaf-environment))
 893              (imported (make-leaf-environment))
 894              (env (make-eval-environment local imported))
 895              (func (make-observer-func))
 896              (observer (environment-observe env func)))
 897         (environment-unobserve observer)
 898         (environment-unobserve observer)
 899         #t)))
 900
 901
 902   (with-test-prefix "observe-weak"
 903
 904     (pass-if "observe an environment"
 905       (let* ((local (make-leaf-environment))
 906              (imported (make-leaf-environment))
 907              (env (make-eval-environment local imported)))
 908         (environment-observe-weak env (make-observer-func))
 909         #t))
 910
 911     (pass-if "observe an environment twice"
 912       (let* ((local (make-leaf-environment))
 913              (imported (make-leaf-environment))
 914              (env (make-eval-environment local imported))
 915              (observer-1 (environment-observe-weak env (make-observer-func)))
 916              (observer-2 (environment-observe-weak env (make-observer-func))))
 917         (not (eq? observer-1 observer-2))))
 918
 919     (pass-if "definition of an undefined symbol"
 920       (let* ((local (make-leaf-environment))
 921              (imported (make-leaf-environment))
 922              (env (make-eval-environment local imported))
 923              (func (make-observer-func)))
 924         (environment-observe-weak env func)
 925         (environment-define env 'a 1)
 926         (eqv? (func) 1)))
 927
 928     (pass-if "definition of an already defined symbol"
 929       (let* ((local (make-leaf-environment))
 930              (imported (make-leaf-environment))
 931              (env (make-eval-environment local imported)))
 932         (environment-define env 'a 1)
 933         (let* ((func (make-observer-func)))
 934           (environment-observe-weak env func)
 935           (environment-define env 'a 1)
 936           (eqv? (func) 1))))
 937
 938     (pass-if "set!ing of a defined symbol"
 939       (let* ((local (make-leaf-environment))
 940              (imported (make-leaf-environment))
 941              (env (make-eval-environment local imported)))
 942         (environment-define env 'a 1)
 943         (let* ((func (make-observer-func)))
 944           (environment-observe-weak env func)
 945           (environment-set! env 'a 1)
 946           (eqv? (func) 0))))
 947
 948     (pass-if "undefining a defined symbol"
 949       (let* ((local (make-leaf-environment))
 950              (imported (make-leaf-environment))
 951              (env (make-eval-environment local imported)))
 952         (environment-define env 'a 1)
 953         (let* ((func (make-observer-func)))
 954           (environment-observe-weak env func)
 955           (environment-undefine env 'a)
 956           (eqv? (func) 1))))
 957
 958     (pass-if "undefining an already undefined symbol"
 959       (let* ((local (make-leaf-environment))
 960              (imported (make-leaf-environment))
 961              (env (make-eval-environment local imported))
 962              (func (make-observer-func)))
 963         (environment-observe-weak env func)
 964         (environment-undefine env 'a)
 965         (eqv? (func) 0)))
 966
 967     (pass-if "unobserve an active observer"
 968       (let* ((local (make-leaf-environment))
 969              (imported (make-leaf-environment))
 970              (env (make-eval-environment local imported))
 971              (func (make-observer-func))
 972              (observer (environment-observe-weak env func)))
 973         (environment-unobserve observer)
 974         (environment-define env 'a 1)
 975         (eqv? (func) 0)))
 976
 977     (pass-if "unobserve an inactive observer"
 978       (let* ((local (make-leaf-environment))
 979              (imported (make-leaf-environment))
 980              (env (make-eval-environment local imported))
 981              (func (make-observer-func))
 982              (observer (environment-observe-weak env func)))
 983         (environment-unobserve observer)
 984         (environment-unobserve observer)
 985         #t))
 986
 987     (pass-if "weak observer gets collected"
 988       (gc)
 989       (let* ((local (make-leaf-environment))
 990              (imported (make-leaf-environment))
 991              (env (make-eval-environment local imported))
 992              (func (make-observer-func)))
 993         (environment-observe-weak env func)
 994         (gc)
 995         (environment-define env 'a 1)
 996         (if (not (eqv? (func) 0))
 997             (throw 'unresolved) ; note: conservative scanning
 998             #t))))
 999
1000
1001   (with-test-prefix "erroneous observers"
1002
1003     (pass-if "update continues after error"
1004       (let* ((local (make-leaf-environment))
1005              (imported (make-leaf-environment))
1006              (env (make-eval-environment local imported))
1007              (func-1 (make-erroneous-observer-func))
1008              (func-2 (make-erroneous-observer-func)))
1009         (environment-observe env func-1)
1010         (environment-observe env func-2)
1011         (catch #t
1012           (lambda ()
1013             (environment-define env 'a 1)
1014             #f)
1015           (lambda args
1016             (and (eq? (func-1) 1)
1017                  (eq? (func-2) 1))))))))
1018
1019
1020 ;;;
1021 ;;; leaf-environment based import-environments
1022 ;;;
1023
1024 (with-test-prefix "leaf-environment based import-environments"
1025
1026   (with-test-prefix "import-environment?"
1027
1028     (pass-if "documented?"
1029       (documented? import-environment?))
1030
1031     (pass-if "non-environment-object"
1032       (not (import-environment? #f)))
1033
1034     (pass-if "leaf-environment-object"
1035       (not (import-environment? (make-leaf-environment))))
1036
1037     (pass-if "eval-environment-object"
1038       (let* ((local (make-leaf-environment))
1039              (imported (make-leaf-environment))
1040              (env (make-eval-environment local imported)))
1041         (not (import-environment? (make-leaf-environment))))))
1042
1043
1044   (with-test-prefix "make-import-environment"
1045
1046     (pass-if "documented?"
1047       (documented? make-import-environment))))
1048
1049 ;;; End of commenting out. - NJ 2006-11-02.
1050 ))