test-suite/tests/guardians.test

   1 ;;;; guardians.test --- test suite for Guile Guardians     -*- scheme -*-
   2 ;;;; Jim Blandy <jimb@red-bean.com> --- July 1999
   3 ;;;;
   4 ;;;;    Copyright (C) 1999, 2001 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  19 ;;;; Boston, MA 02111-1307 USA
  20
  21 ;;; These tests make some questionable assumptions.
  22 ;;; - They assume that a GC will find all dead objects, so they
  23 ;;;   will become flaky if we have a generational GC.
  24 ;;; - They assume that objects won't be saved by the guardian until
  25 ;;;   they explicitly invoke GC --- in other words, they assume that GC
  26 ;;;   won't happen too often.
  27
  28 (use-modules (ice-9 documentation))
  29
  30
  31 ;;;
  32 ;;; miscellaneous
  33 ;;;
  34
  35 (define (documented? object)
  36   (not (not (object-documentation object))))
  37
  38
  39 (gc)
  40
  41 ;;; Who guards the guardian?
  42 (gc)
  43 (define g2 (make-guardian))
  44 (g2 (list 'g2-garbage))
  45 (define g3 (make-guardian))
  46 (g3 (list 'g3-garbage))
  47 (g3 g2)
  48 (pass-if "g2-garbage not collected yet" (equal? (g2) #f))
  49 (pass-if "g3-garbage not collected yet" (equal? (g3) #f))
  50 (set! g2 #f)
  51 (gc)
  52 (let ((seen-g3-garbage #f)
  53       (seen-g2 #f)
  54       (seen-something-else #f))
  55   (let loop ()
  56     (let ((saved (g3)))
  57       (if saved
  58           (begin
  59             (cond
  60              ((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t))
  61              ((procedure? saved) (set! seen-g2 saved))
  62              (else (set! seen-something-else #t)))
  63             (loop)))))
  64   (pass-if "g3-garbage saved" seen-g3-garbage)
  65   (pass-if "g2-saved" (procedure? seen-g2))
  66   (pass-if "nothing else saved" (not seen-something-else))
  67   (pass-if "g2-garbage saved" (and (procedure? seen-g2)
  68                                    (equal? (seen-g2) '(g2-garbage)))))
  69
  70 (with-test-prefix "standard guardian functionality"
  71
  72   (with-test-prefix "make-guardian"
  73
  74     (pass-if "documented?"
  75       (documented? make-guardian))
  76
  77     (pass-if "returns procedure"
  78       (procedure? (make-guardian)))
  79
  80     (pass-if "returns new procedure each time"
  81       (not (equal? (make-guardian) (make-guardian)))))
  82
  83   (with-test-prefix "empty guardian"
  84
  85     (pass-if "returns #f"
  86       (eq? ((make-guardian)) #f))
  87
  88     (pass-if "returns always #f"
  89       (let ((g (make-guardian)))
  90         (and (eq? (g) #f)
  91              (begin (gc) (eq? (g) #f))
  92              (begin (gc) (eq? (g) #f))))))
  93
  94   (with-test-prefix "guarding independent objects"
  95
  96     (pass-if "guarding immediate"
  97       (let ((g (make-guardian)))
  98         (g #f)
  99         (and (eq? (g) #f)
 100              (begin (gc) (eq? (g) #f))
 101              (begin (gc) (eq? (g) #f)))))
 102
 103     (pass-if "guarding non-immediate"
 104       (let ((g (make-guardian)))
 105         (gc)
 106         (g (cons #f #f))
 107         (if (not (eq? (g) #f))
 108             (throw 'unresolved)
 109             (begin
 110               (gc)
 111               (if (not (equal? (g) (cons #f #f)))
 112                   (throw 'unresolved)
 113                   (eq? (g) #f))))))
 114
 115     (pass-if "guarding two non-immediates"
 116       (let ((g (make-guardian)))
 117         (gc)
 118         (g (cons #f #f))
 119         (g (cons #t #t))
 120         (if (not (eq? (g) #f))
 121             (throw 'unresolved)
 122             (begin
 123               (gc)
 124               (let ((l (list (g) (g))))
 125                 (if (not (or (equal? l (list (cons #f #f) (cons #t #t)))
 126                              (equal? l (list (cons #t #t) (cons #f #f)))))
 127                     (throw 'unresolved)
 128                     (eq? (g) #f)))))))
 129
 130     (pass-if "re-guarding non-immediates"
 131       (let ((g (make-guardian)))
 132         (gc)
 133         (g (cons #f #f))
 134         (if (not (eq? (g) #f))
 135             (throw 'unresolved)
 136             (begin
 137               (gc)
 138               (let ((p (g)))
 139                 (if (not (equal? p (cons #f #f)))
 140                     (throw 'unresolved)
 141                     (begin
 142                       (g p)
 143                       (set! p #f)
 144                       (gc)
 145                       (if (not (equal? (g) (cons #f #f)))
 146                           (throw 'unresolved)
 147                           (eq? (g) #f)))))))))
 148
 149     (pass-if "guarding living non-immediate"
 150       (let ((g (make-guardian))
 151             (p (cons #f #f)))
 152         (g p)
 153         (if (not (eq? (g) #f))
 154             (throw 'fail)
 155             (begin
 156               (gc)
 157               (not (eq? (g) p)))))))
 158
 159   (with-test-prefix "guarding weakly referenced objects"
 160
 161     (pass-if "guarded weak vector element gets returned from guardian"
 162       (let ((g (make-guardian))
 163             (v (weak-vector #f)))
 164         (gc)
 165         (let ((p (cons #f #f)))
 166           (g p)
 167           (vector-set! v 0 p))
 168         (if (not (eq? (g) #f))
 169             (throw 'unresolved)
 170             (begin
 171               (gc)
 172               (if (not (equal? (g) (cons #f #f)))
 173                   (throw 'unresolved)
 174                   (eq? (g) #f))))))
 175
 176     (pass-if "guarded element of weak vector gets removed from weak vector"
 177       ;; How should this be handled?  Should weak objects be removed from
 178       ;; their containers before they become zombies?  Let's take a look at
 179       ;; the possible scenarios:  a) Weak objects that are also guarded are
 180       ;; not removed from their containers as long as they are guarded.
 181       ;; However, they still can become zombies.  The consequence is, that the
 182       ;; object can be retrieved from its container, thus being alive, while
 183       ;; on the other hand it can at the same time be retrieved from a
 184       ;; guardian.  This is unfortunate, since when retrieving an object from
 185       ;; a guardian one would not expect any other reference to the object.
 186       ;; b) Weak objects are removed from their containers if they are not
 187       ;; referenced any more or if the only references are from guardians.
 188       ;; That means that it is guaranteed that there are no other references
 189       ;; to an object that is retrieved from a guardian.  However, this means
 190       ;; that there is no chance to update containers like weak hash tables
 191       ;; using the information that one of their contained objects will be
 192       ;; removed.  It may be however, that this is not necessary anyway.
 193       (let ((g (make-guardian))
 194             (v (weak-vector #f)))
 195         (gc)
 196         (let ((p (cons #f #f)))
 197           (g p)
 198           (vector-set! v 0 p))
 199         (if (not (equal? (vector-ref v 0) (cons #f #f)))
 200             (throw 'unresolved)
 201             (begin
 202               (gc)
 203               (if (equal? (vector-ref v 0) (cons #f #f))
 204                   (throw 'unresolved)
 205                   #t))))))
 206
 207   (with-test-prefix "guarding weak containers"
 208
 209     (pass-if "element of guarded weak vector gets collected"
 210       (let ((g (make-guardian))
 211             (v (weak-vector (cons #f #f))))
 212         (g v)
 213         (gc)
 214         (if (equal? (vector-ref v 0) (cons #f #f))
 215             (throw 'unresolved)
 216             #t))))
 217
 218   (with-test-prefix "guarding guardians"
 219     #t))
 220
 221 (with-test-prefix "guile guardian functionality"
 222
 223   (with-test-prefix "guarding dependent objects"
 224
 225     (pass-if "guarding vector and element"
 226       (let ((g (make-guardian)))
 227         (gc)
 228         (let ((p (cons #f #f)))
 229           (g p)
 230           (g (vector p)))
 231         (if (not (eq? (g) #f))
 232             (throw 'unresolved)
 233             (begin
 234               (gc)
 235               (if (not (equal? (g) (vector (cons #f #f))))
 236                   (throw 'unresolved)
 237                   (if (not (eq? (g) #f))
 238                       (throw 'unresolved)
 239                       (begin
 240                         (gc)
 241                         (if (not (equal? (g) (cons #f #f)))
 242                             (throw 'unresolved)
 243                             (eq? (g) #f)))))))))
 244
 245     )
 246
 247   (with-test-prefix "guarding objects more than once"
 248     #t)
 249
 250   (with-test-prefix "guarding cyclic dependencies"
 251     #t)
 252
 253   )