test-suite/tests/environments.nottest

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