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