guile18/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, 2006 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., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 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 (define-module (test-guardians)
  29   :use-module (test-suite lib)
  30   :use-module (ice-9 documentation)
  31   :use-module (ice-9 weak-vector))
  32
  33 \f
  34 ;;;
  35 ;;; miscellaneous
  36 ;;;
  37
  38 (define (documented? object)
  39   (not (not (object-documentation object))))
  40
  41
  42 (gc)
  43
  44 ;;; Who guards the guardian?
  45 (gc)
  46 (define g2 (make-guardian))
  47 (g2 (list 'g2-garbage))
  48 (define g3 (make-guardian))
  49 (g3 (list 'g3-garbage))
  50 (g3 g2)
  51 (pass-if "g2-garbage not collected yet" (equal? (g2) #f))
  52 (pass-if "g3-garbage not collected yet" (equal? (g3) #f))
  53 (set! g2 #f)
  54 (gc)
  55 (let ((seen-g3-garbage #f)
  56       (seen-g2 #f)
  57       (seen-something-else #f))
  58   (let loop ()
  59     (let ((saved (g3)))
  60       (if saved
  61           (begin
  62             (cond
  63              ((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t))
  64              ((procedure? saved) (set! seen-g2 saved))
  65              (else (pk saved) (set! seen-something-else #t)))
  66             (loop)))))
  67   (pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved)))
  68   (pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved)))
  69   (pass-if "nothing else saved" (not seen-something-else))
  70   (pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
  71                                        (equal? (seen-g2) '(g2-garbage)))
  72                                   (throw 'unresolved))))
  73
  74 (with-test-prefix "standard guardian functionality"
  75
  76   (with-test-prefix "make-guardian"
  77
  78     (pass-if "documented?"
  79       (documented? make-guardian))
  80
  81     (pass-if "returns procedure"
  82       (procedure? (make-guardian)))
  83
  84     (pass-if "returns new procedure each time"
  85       (not (equal? (make-guardian) (make-guardian)))))
  86
  87   (with-test-prefix "empty guardian"
  88
  89     (pass-if "returns #f"
  90       (eq? ((make-guardian)) #f))
  91
  92     (pass-if "returns always #f"
  93       (let ((g (make-guardian)))
  94         (and (eq? (g) #f)
  95              (begin (gc) (eq? (g) #f))
  96              (begin (gc) (eq? (g) #f))))))
  97
  98   (with-test-prefix "guarding independent objects"
  99
 100     (pass-if "guarding immediate"
 101       (let ((g (make-guardian)))
 102         (g #f)
 103         (and (eq? (g) #f)
 104              (begin (gc) (eq? (g) #f))
 105              (begin (gc) (eq? (g) #f)))))
 106
 107     (pass-if "guarding non-immediate"
 108       (let ((g (make-guardian)))
 109         (gc)
 110         (g (cons #f #f))
 111         (if (not (eq? (g) #f))
 112             (throw 'unresolved)
 113             (begin
 114               (gc)
 115               (if (not (equal? (g) (cons #f #f)))
 116                   (throw 'unresolved)
 117                   (eq? (g) #f))))))
 118
 119     (pass-if "guarding two non-immediates"
 120       (let ((g (make-guardian)))
 121         (gc)
 122         (g (cons #f #f))
 123         (g (cons #t #t))
 124         (if (not (eq? (g) #f))
 125             (throw 'unresolved)
 126             (begin
 127               (gc)
 128               (let ((l (list (g) (g))))
 129                 (if (not (or (equal? l (list (cons #f #f) (cons #t #t)))
 130                              (equal? l (list (cons #t #t) (cons #f #f)))))
 131                     (throw 'unresolved)
 132                     (eq? (g) #f)))))))
 133
 134     (pass-if "re-guarding non-immediates"
 135       (let ((g (make-guardian)))
 136         (gc)
 137         (g (cons #f #f))
 138         (if (not (eq? (g) #f))
 139             (throw 'unresolved)
 140             (begin
 141               (gc)
 142               (let ((p (g)))
 143                 (if (not (equal? p (cons #f #f)))
 144                     (throw 'unresolved)
 145                     (begin
 146                       (g p)
 147                       (set! p #f)
 148                       (gc)
 149                       (if (not (equal? (g) (cons #f #f)))
 150                           (throw 'unresolved)
 151                           (eq? (g) #f)))))))))
 152
 153     (pass-if "guarding living non-immediate"
 154       (let ((g (make-guardian))
 155             (p (cons #f #f)))
 156         (g p)
 157         (if (not (eq? (g) #f))
 158             (throw 'fail)
 159             (begin
 160               (gc)
 161               (not (eq? (g) p)))))))
 162
 163   (with-test-prefix "guarding weakly referenced objects"
 164
 165     (pass-if "guarded weak vector element gets returned from guardian"
 166       (let ((g (make-guardian))
 167             (v (weak-vector #f)))
 168         (gc)
 169         (let ((p (cons #f #f)))
 170           (g p)
 171           (vector-set! v 0 p))
 172         (if (not (eq? (g) #f))
 173             (throw 'unresolved)
 174             (begin
 175               (gc)
 176               (if (not (equal? (g) (cons #f #f)))
 177                   (throw 'unresolved)
 178                   (eq? (g) #f))))))
 179
 180     (pass-if "guarded element of weak vector gets eventually removed from weak vector"
 181       (let ((g (make-guardian))
 182             (v (weak-vector #f)))
 183         (gc)
 184         (let ((p (cons #f #f)))
 185           (g p)
 186           (vector-set! v 0 p))
 187         (begin
 188           (gc)
 189           (if (not (equal? (g) (cons #f #f)))
 190               (throw 'unresolved)
 191               (begin
 192                 (gc)
 193                 (or (not (vector-ref v 0))
 194                     (throw 'unresolved))))))))
 195
 196   (with-test-prefix "guarding weak containers"
 197
 198     (pass-if "element of guarded weak vector gets collected"
 199       (let ((g (make-guardian))
 200             (v (weak-vector (cons #f #f))))
 201         (g v)
 202         (gc)
 203         (if (equal? (vector-ref v 0) (cons #f #f))
 204             (throw 'unresolved)
 205             #t))))
 206
 207   (with-test-prefix "guarding guardians"
 208     #t)
 209
 210   (with-test-prefix "guarding dependent objects"
 211
 212     ;; We don't make any guarantees about the order objects are
 213     ;; returned from guardians and therefore we skip the following
 214     ;; test.
 215
 216     (if #f
 217         (pass-if "guarding vector and element"
 218           (let ((g (make-guardian)))
 219             (gc)
 220             (let ((p (cons #f #f)))
 221               (g p)
 222               (g (vector p)))
 223             (if (not (eq? (g) #f))
 224                 (throw 'unresolved)
 225                 (begin
 226                   (gc)
 227                   (if (not (equal? (g) (vector (cons #f #f))))
 228                       (throw 'unresolved)
 229                       (if (not (eq? (g) #f))
 230                           (throw 'unresolved)
 231                           (begin
 232                             (gc)
 233                             (if (not (equal? (g) (cons #f #f)))
 234                                 (throw 'unresolved)
 235                                 (eq? (g) #f)))))))))))
 236
 237   (with-test-prefix "guarding objects more than once"
 238
 239     (pass-if "guarding twice in one guardian"
 240        (let ((g (make-guardian)))
 241          (gc)
 242          (let ((p (cons #f #f)))
 243            (g p)
 244            (g p))
 245          (if (not (eq? (g) #f))
 246              (throw 'unresolved)
 247              (begin
 248                (gc)
 249                (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
 250                         (and=> (g) (lambda (o) (equal? o (cons #f #f)))))
 251                    (throw 'unresolved))))))
 252
 253     (pass-if "guarding twice in two guardians"
 254        (let ((g (make-guardian))
 255              (h (make-guardian)))
 256          (gc)
 257          (let ((p (cons #f #f)))
 258            (g p)
 259            (h p))
 260          (if (not (eq? (g) #f))
 261              (throw 'unresolved)
 262              (begin
 263                (gc)
 264                (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
 265                         (and=> (h) (lambda (o) (equal? o (cons #f #f)))))
 266                    (throw 'unresolved)))))))
 267
 268   (with-test-prefix "guarding cyclic dependencies"
 269     #t)
 270
 271   )