[bpt/guile.git] / test-suite / tests / guardians.test

;;;; guardians.test --- test suite for Guile Guardians     -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- July 1999
;;;;
;;;; 	Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; These tests make some questionable assumptions.
;;;
;;; - They assume that a GC will find all dead objects, so they
;;;   will become flaky if we have a generational GC.
;;;
;;; - More generally, when a weakly referenced object doesn't disappear as
;;;   expected, it's hard to tell whether that's because of a guardian bug of
;;;   because a reference to it is being held somewhere, e.g., one some part
;;;   of the stack that hasn't been overwritten.  Thus, most tests cannot
;;;   fail, they can just throw `unresolved'.  We try hard to clear
;;;   references that may have been left on the stacks (see "clear refs left
;;;   on the stack" lines).
;;;
;;; - They assume that objects won't be saved by the guardian until
;;;   they explicitly invoke GC --- in other words, they assume that GC
;;;   won't happen too often.

(define-module (test-guardians)
  :use-module (test-suite lib)
  :use-module (ice-9 documentation)
  :use-module (ice-9 weak-vector))

\f
;;;
;;; miscellaneous
;;;

(define (documented? object)
  (not (not (object-documentation object))))


(gc)

;;; Who guards the guardian?

;;; Note: We use strings rather than symbols because symbols are usually
;;; ``interned'', i.e., kept in a weakly-keyed hash table, thus making them
;;; inappropriate for the tests below.  Furthermore, we use `string-copy' in
;;; order to make sure that no string is kept around in the interpreter
;;; unwillingly (e.g., in the source-property weak hash table).

(gc)
(define g2 (make-guardian))
(g2 (list (string-copy "g2-garbage")))
(define g3 (make-guardian))
(g3 (list (string-copy "g3-garbage")))
(g3 g2)
(pass-if "g2-garbage not collected yet" (equal? (g2) #f))
(pass-if "g3-garbage not collected yet" (equal? (g3) #f))
(set! g2 #f)
(gc)
(let ((seen-g3-garbage #f)
      (seen-g2 #f)
      (seen-something-else #f))
  (let loop ()
    (let ((saved (g3)))
      (if saved
	  (begin
	    (cond
	     ((equal? saved (list (string-copy "g3-garbage")))
	      (set! seen-g3-garbage #t))
	     ((procedure? saved) (set! seen-g2 saved))
	     (else (pk 'junk saved) (set! seen-something-else #t)))
	    (loop)))))
  (pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved)))
  (pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved)))
  (pass-if "nothing else saved" (not seen-something-else))

  ;; FIXME: The following test fails because the guardian for `g2-garbage'
  ;; disappared from the weak-car guardian list of `g2-garbage' right before
  ;; `g2-garbage' was finalized (in `finalize_guarded ()').  Sample session
  ;; (compiled with `-DDEBUG_GUARDIANS'):
  ;;
  ;; guile> (define g (make-guardian))
  ;; guile> (let ((g2 (make-guardian)))
  ;;          (format #t "g2 = ~x~%" (object-address g2))
  ;;          (g2 (string-copy "foo"))
  ;;          (g g2))
  ;; g2 = 81fde18
  ;; guile> (gc)
  ;; finalizing guarded 0x827f6a0 (1 guardians)
  ;;   guardian for 0x827f6a0 vanished
  ;; end of finalize (0x827f6a0)
  ;; finalizing guarded 0x81fde18 (1 guardians)
  ;; end of finalize (0x81fde18)

  (pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
				       (equal? (seen-g2)
					       (list (string-copy
						      "g2-garbage"))))
				  (throw 'unresolved))))

(with-test-prefix "standard guardian functionality"

  (with-test-prefix "make-guardian"

    (pass-if "documented?"
      (documented? make-guardian))

    (pass-if "returns procedure"
      (procedure? (make-guardian)))

    (pass-if "returns new procedure each time"
      (not (equal? (make-guardian) (make-guardian)))))

  (with-test-prefix "empty guardian"

    (pass-if "returns #f"
      (eq? ((make-guardian)) #f))

    (pass-if "returns always #f"
      (let ((g (make-guardian)))
	(and (eq? (g) #f)
	     (begin (gc) (eq? (g) #f))
	     (begin (gc) (eq? (g) #f))))))

  (with-test-prefix "guarding independent objects"

    (pass-if "guarding immediate"
      (let ((g (make-guardian)))
	(g #f)
	(and (eq? (g) #f)
	     (begin (gc) (eq? (g) #f))
	     (begin (gc) (eq? (g) #f)))))

    (pass-if "guarding non-immediate"
      (let ((g (make-guardian)))
	(gc)
	(g (cons #f #f))
        (cons 'clear 'stack)  ;; clear refs left on the stack
	(if (not (eq? (g) #f))
	    (throw 'unresolved)
	    (begin
	      (gc)
	      (if (not (equal? (g) (cons #f #f)))
		  (throw 'unresolved)
		  (eq? (g) #f))))))

    (pass-if "guarding two non-immediates"
      (let ((g (make-guardian)))
	(gc)
	(g (cons #f #f))
	(g (cons #t #t))
        (cons 'clear 'stack)  ;; clear refs left on the stack
	(if (not (eq? (g) #f))
	    (throw 'unresolved)
	    (begin
	      (gc)
	      (let ((l (list (g) (g))))
		(if (not (or (equal? l (list (cons #f #f) (cons #t #t)))
			     (equal? l (list (cons #t #t) (cons #f #f)))))
		    (throw 'unresolved)
		    (eq? (g) #f)))))))

    (pass-if "re-guarding non-immediates"
      (let ((g (make-guardian)))
	(gc)
	(g (cons #f #f))
        (cons 'clear 'stack)  ;; clear refs left on the stack
	(if (not (eq? (g) #f))
	    (throw 'unresolved)
	    (begin
	      (gc)
	      (let ((p (g)))
		(if (not (equal? p (cons #f #f)))
		    (throw 'unresolved)
		    (begin
		      (g p)
		      (set! p #f)
		      (gc)
		      (if (not (equal? (g) (cons #f #f)))
			  (throw 'unresolved)
			  (eq? (g) #f)))))))))

    (pass-if "guarding living non-immediate"
      (let ((g (make-guardian))
	    (p (cons #f #f)))
	(g p)
	(if (not (eq? (g) #f))
	    (throw 'fail)
	    (begin
	      (gc)
	      (not (eq? (g) p)))))))

  (with-test-prefix "guarding weakly referenced objects"

    (pass-if "guarded weak vector element gets returned from guardian"
      (let ((g (make-guardian))
	    (v (weak-vector #f)))
	(gc)
	(let ((p (cons #f #f)))
	  (g p)
	  (vector-set! v 0 p)
          (set! p #f))           ;; clear refs left on the stack
	(if (not (eq? (g) #f))
	    (throw 'unresolved)
	    (begin
	      (gc)
	      (if (not (equal? (g) (cons #f #f)))
		  (throw 'unresolved)
		  (eq? (g) #f))))))

    (pass-if "guarded element of weak vector gets eventually removed from weak vector"
      (let ((g (make-guardian))
	    (v (weak-vector #f)))
	(gc)
	(let ((p (cons #f #f)))
	  (g p)
	  (vector-set! v 0 p)
          (set! p #f))        ;; clear refs left on the stack
	(begin
	  (gc)
	  (if (not (equal? (g) (cons #f #f)))
	      (throw 'unresolved)
	      (begin
		(gc)
		(or (not (vector-ref v 0))
		    (throw 'unresolved))))))))

  (with-test-prefix "guarding weak containers"

    (pass-if "element of guarded weak vector gets collected"
      (let ((g (make-guardian))
	    (v (weak-vector #f)))
        ;; Note: We don't pass `(cons #f #f)' as an argument to `weak-vector'
        ;; otherwise references to it are likely to be left on the stack.
        (vector-set! v 0 (cons #f #f))

	(g v)
	(gc)
	(if (equal? (vector-ref v 0) (cons #f #f))
	    (throw 'unresolved)
	    #t))))

  (with-test-prefix "guarding guardians"
    #t)

  (with-test-prefix "guarding dependent objects"

    ;; We don't make any guarantees about the order objects are
    ;; returned from guardians and therefore we skip the following
    ;; test.

    (if #f
	(pass-if "guarding vector and element"
          (let ((g (make-guardian)))
	    (gc)
	    (let ((p (cons #f #f)))
	      (g p)
	      (g (vector p)))
	    (if (not (eq? (g) #f))
		(throw 'unresolved)
		(begin
		  (gc)
		  (if (not (equal? (g) (vector (cons #f #f))))
		      (throw 'unresolved)
		      (if (not (eq? (g) #f))
			  (throw 'unresolved)
			  (begin
			    (gc)
			    (if (not (equal? (g) (cons #f #f)))
				(throw 'unresolved)
				(eq? (g) #f)))))))))))

  (with-test-prefix "guarding objects more than once"

    (pass-if "guarding twice in one guardian"
       (let ((g (make-guardian)))
	 (gc)
	 (let ((p (cons #f #f)))
	   (g p)
	   (g p)
           (set! p #f))       ;; clear refs left on the stack
	 (if (not (eq? (g) #f))
	     (throw 'unresolved)
	     (begin
	       (gc)
	       (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
			(and=> (g) (lambda (o) (equal? o (cons #f #f)))))
		   (throw 'unresolved))))))

    (pass-if "guarding twice in two guardians"
       (let ((g (make-guardian))
	     (h (make-guardian)))
	 (gc)
	 (let ((p (cons #f #f)))
	   (g p)
	   (h p)
           (set! p #f))         ;; clear refs left on the stack
	 (if (not (eq? (g) #f))
	     (throw 'unresolved)
	     (begin
	       (gc)
	       (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
			(and=> (h) (lambda (o) (equal? o (cons #f #f)))))
		   (throw 'unresolved)))))))

  (with-test-prefix "guarding cyclic dependencies"
    #t)

  )
Commit	Line	Data
2e109b65 JB	1	;;;; guardians.test --- test suite for Guile Guardians -- scheme --
	2	;;;; Jim Blandy <jimb@red-bean.com> --- July 1999
	3	;;;;
6e7d5622	4	;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
2e109b65	5	;;;;
53befeb7 NJ	6	;;;; This library is free software; you can redistribute it and/or
	7	;;;; modify it under the terms of the GNU Lesser General Public
	8	;;;; License as published by the Free Software Foundation; either
	9	;;;; version 3 of the License, or (at your option) any later version.
2e109b65	10	;;;;
53befeb7	11	;;;; This library is distributed in the hope that it will be useful,
2e109b65	12	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
53befeb7 NJ	13	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
53befeb7 NJ	14	;;;; Lesser General Public License for more details.
2e109b65	15	;;;;
53befeb7 NJ	16	;;;; You should have received a copy of the GNU Lesser General Public
	17	;;;; License along with this library; if not, write to the Free Software
	18	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
2e109b65 JB	19
2e109b65 JB	20	;;; These tests make some questionable assumptions.
6a7489ac	21	;;;
2e109b65 JB	22	;;; - They assume that a GC will find all dead objects, so they
2e109b65 JB	23	;;; will become flaky if we have a generational GC.
6a7489ac LC	24	;;;
	25	;;; - More generally, when a weakly referenced object doesn't disappear as
	26	;;; expected, it's hard to tell whether that's because of a guardian bug of
	27	;;; because a reference to it is being held somewhere, e.g., one some part
	28	;;; of the stack that hasn't been overwritten. Thus, most tests cannot
	29	;;; fail, they can just throw `unresolved'. We try hard to clear
	30	;;; references that may have been left on the stacks (see "clear refs left
	31	;;; on the stack" lines).
	32	;;;
2e109b65 JB	33	;;; - They assume that objects won't be saved by the guardian until
	34	;;; they explicitly invoke GC --- in other words, they assume that GC
	35	;;; won't happen too often.
	36
1eefa363 LC	37	(define-module (test-guardians)
	38	:use-module (test-suite lib)
	39	:use-module (ice-9 documentation)
	40	:use-module (ice-9 weak-vector))
9247b5bc	41
1eefa363	42	\f
9247b5bc DH	43	;;;
	44	;;; miscellaneous
	45	;;;
	46
	47	(define (documented? object)
	48	(not (not (object-documentation object))))
	49
2e109b65	50
2e109b65	51	(gc)
2e109b65 JB	52
2e109b65 JB	53	;;; Who guards the guardian?
e13f1cbd LC	54
	55	;;; Note: We use strings rather than symbols because symbols are usually
	56	;;; ``interned'', i.e., kept in a weakly-keyed hash table, thus making them
	57	;;; inappropriate for the tests below. Furthermore, we use `string-copy' in
	58	;;; order to make sure that no string is kept around in the interpreter
	59	;;; unwillingly (e.g., in the source-property weak hash table).
	60
2e109b65 JB	61	(gc)
2e109b65 JB	62	(define g2 (make-guardian))
e13f1cbd	63	(g2 (list (string-copy "g2-garbage")))
2e109b65	64	(define g3 (make-guardian))
e13f1cbd	65	(g3 (list (string-copy "g3-garbage")))
2e109b65 JB	66	(g3 g2)
	67	(pass-if "g2-garbage not collected yet" (equal? (g2) #f))
	68	(pass-if "g3-garbage not collected yet" (equal? (g3) #f))
	69	(set! g2 #f)
	70	(gc)
	71	(let ((seen-g3-garbage #f)
	72	(seen-g2 #f)
	73	(seen-something-else #f))
	74	(let loop ()
	75	(let ((saved (g3)))
	76	(if saved
	77	(begin
	78	(cond
e13f1cbd LC	79	((equal? saved (list (string-copy "g3-garbage")))
e13f1cbd LC	80	(set! seen-g3-garbage #t))
2e109b65	81	((procedure? saved) (set! seen-g2 saved))
e13f1cbd	82	(else (pk 'junk saved) (set! seen-something-else #t)))
2e109b65	83	(loop)))))
2924541b MV	84	(pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved)))
2924541b MV	85	(pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved)))
2e109b65	86	(pass-if "nothing else saved" (not seen-something-else))
6a7489ac LC	87
	88	;; FIXME: The following test fails because the guardian for `g2-garbage'
	89	;; disappared from the weak-car guardian list of `g2-garbage' right before
	90	;; `g2-garbage' was finalized (in `finalize_guarded ()'). Sample session
	91	;; (compiled with `-DDEBUG_GUARDIANS'):
	92	;;
	93	;; guile> (define g (make-guardian))
	94	;; guile> (let ((g2 (make-guardian)))
	95	;; (format #t "g2 = ~x~%" (object-address g2))
	96	;; (g2 (string-copy "foo"))
	97	;; (g g2))
	98	;; g2 = 81fde18
	99	;; guile> (gc)
	100	;; finalizing guarded 0x827f6a0 (1 guardians)
	101	;; guardian for 0x827f6a0 vanished
	102	;; end of finalize (0x827f6a0)
	103	;; finalizing guarded 0x81fde18 (1 guardians)
	104	;; end of finalize (0x81fde18)
	105
2924541b	106	(pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
e13f1cbd LC	107	(equal? (seen-g2)
	108	(list (string-copy
	109	"g2-garbage"))))
2924541b	110	(throw 'unresolved))))
9247b5bc DH	111
	112	(with-test-prefix "standard guardian functionality"
	113
	114	(with-test-prefix "make-guardian"
	115
	116	(pass-if "documented?"
	117	(documented? make-guardian))
	118
	119	(pass-if "returns procedure"
	120	(procedure? (make-guardian)))
	121
	122	(pass-if "returns new procedure each time"
	123	(not (equal? (make-guardian) (make-guardian)))))
	124
	125	(with-test-prefix "empty guardian"
	126
	127	(pass-if "returns #f"
	128	(eq? ((make-guardian)) #f))
	129
	130	(pass-if "returns always #f"
	131	(let ((g (make-guardian)))
	132	(and (eq? (g) #f)
	133	(begin (gc) (eq? (g) #f))
	134	(begin (gc) (eq? (g) #f))))))
	135
	136	(with-test-prefix "guarding independent objects"
	137
	138	(pass-if "guarding immediate"
	139	(let ((g (make-guardian)))
	140	(g #f)
	141	(and (eq? (g) #f)
	142	(begin (gc) (eq? (g) #f))
	143	(begin (gc) (eq? (g) #f)))))
	144
	145	(pass-if "guarding non-immediate"
	146	(let ((g (make-guardian)))
	147	(gc)
	148	(g (cons #f #f))
6a7489ac	149	(cons 'clear 'stack) ;; clear refs left on the stack
9247b5bc DH	150	(if (not (eq? (g) #f))
	151	(throw 'unresolved)
	152	(begin
	153	(gc)
	154	(if (not (equal? (g) (cons #f #f)))
	155	(throw 'unresolved)
	156	(eq? (g) #f))))))
	157
	158	(pass-if "guarding two non-immediates"
	159	(let ((g (make-guardian)))
	160	(gc)
	161	(g (cons #f #f))
	162	(g (cons #t #t))
6a7489ac	163	(cons 'clear 'stack) ;; clear refs left on the stack
9247b5bc DH	164	(if (not (eq? (g) #f))
	165	(throw 'unresolved)
	166	(begin
	167	(gc)
	168	(let ((l (list (g) (g))))
	169	(if (not (or (equal? l (list (cons #f #f) (cons #t #t)))
	170	(equal? l (list (cons #t #t) (cons #f #f)))))
	171	(throw 'unresolved)
	172	(eq? (g) #f)))))))
	173
	174	(pass-if "re-guarding non-immediates"
	175	(let ((g (make-guardian)))
	176	(gc)
	177	(g (cons #f #f))
6a7489ac	178	(cons 'clear 'stack) ;; clear refs left on the stack
9247b5bc DH	179	(if (not (eq? (g) #f))
	180	(throw 'unresolved)
	181	(begin
	182	(gc)
	183	(let ((p (g)))
	184	(if (not (equal? p (cons #f #f)))
	185	(throw 'unresolved)
	186	(begin
	187	(g p)
	188	(set! p #f)
	189	(gc)
	190	(if (not (equal? (g) (cons #f #f)))
	191	(throw 'unresolved)
	192	(eq? (g) #f)))))))))
	193
	194	(pass-if "guarding living non-immediate"
	195	(let ((g (make-guardian))
	196	(p (cons #f #f)))
	197	(g p)
	198	(if (not (eq? (g) #f))
	199	(throw 'fail)
	200	(begin
	201	(gc)
	202	(not (eq? (g) p)))))))
	203
	204	(with-test-prefix "guarding weakly referenced objects"
	205
	206	(pass-if "guarded weak vector element gets returned from guardian"
	207	(let ((g (make-guardian))
	208	(v (weak-vector #f)))
	209	(gc)
	210	(let ((p (cons #f #f)))
	211	(g p)
6a7489ac LC	212	(vector-set! v 0 p)
6a7489ac LC	213	(set! p #f)) ;; clear refs left on the stack
9247b5bc DH	214	(if (not (eq? (g) #f))
	215	(throw 'unresolved)
	216	(begin
	217	(gc)
	218	(if (not (equal? (g) (cons #f #f)))
	219	(throw 'unresolved)
	220	(eq? (g) #f))))))
	221
2924541b	222	(pass-if "guarded element of weak vector gets eventually removed from weak vector"
9247b5bc DH	223	(let ((g (make-guardian))
	224	(v (weak-vector #f)))
	225	(gc)
	226	(let ((p (cons #f #f)))
	227	(g p)
6a7489ac LC	228	(vector-set! v 0 p)
6a7489ac LC	229	(set! p #f)) ;; clear refs left on the stack
2924541b MV	230	(begin
	231	(gc)
	232	(if (not (equal? (g) (cons #f #f)))
	233	(throw 'unresolved)
	234	(begin
	235	(gc)
	236	(or (not (vector-ref v 0))
	237	(throw 'unresolved))))))))
9247b5bc DH	238
	239	(with-test-prefix "guarding weak containers"
	240
	241	(pass-if "element of guarded weak vector gets collected"
	242	(let ((g (make-guardian))
6a7489ac LC	243	(v (weak-vector #f)))
	244	;; Note: We don't pass `(cons #f #f)' as an argument to `weak-vector'
	245	;; otherwise references to it are likely to be left on the stack.
	246	(vector-set! v 0 (cons #f #f))
	247
9247b5bc DH	248	(g v)
	249	(gc)
	250	(if (equal? (vector-ref v 0) (cons #f #f))
	251	(throw 'unresolved)
	252	#t))))
	253
	254	(with-test-prefix "guarding guardians"
2924541b	255	#t)
9247b5bc DH	256
	257	(with-test-prefix "guarding dependent objects"
	258
2924541b MV	259	;; We don't make any guarantees about the order objects are
	260	;; returned from guardians and therefore we skip the following
	261	;; test.
	262
	263	(if #f
	264	(pass-if "guarding vector and element"
	265	(let ((g (make-guardian)))
	266	(gc)
	267	(let ((p (cons #f #f)))
	268	(g p)
	269	(g (vector p)))
	270	(if (not (eq? (g) #f))
	271	(throw 'unresolved)
	272	(begin
	273	(gc)
	274	(if (not (equal? (g) (vector (cons #f #f))))
9247b5bc	275	(throw 'unresolved)
2924541b MV	276	(if (not (eq? (g) #f))
	277	(throw 'unresolved)
	278	(begin
	279	(gc)
	280	(if (not (equal? (g) (cons #f #f)))
	281	(throw 'unresolved)
	282	(eq? (g) #f)))))))))))
9247b5bc DH	283
9247b5bc DH	284	(with-test-prefix "guarding objects more than once"
2924541b MV	285
	286	(pass-if "guarding twice in one guardian"
	287	(let ((g (make-guardian)))
	288	(gc)
	289	(let ((p (cons #f #f)))
	290	(g p)
6a7489ac LC	291	(g p)
6a7489ac LC	292	(set! p #f)) ;; clear refs left on the stack
2924541b MV	293	(if (not (eq? (g) #f))
	294	(throw 'unresolved)
	295	(begin
	296	(gc)
	297	(or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
	298	(and=> (g) (lambda (o) (equal? o (cons #f #f)))))
	299	(throw 'unresolved))))))
	300
	301	(pass-if "guarding twice in two guardians"
	302	(let ((g (make-guardian))
	303	(h (make-guardian)))
	304	(gc)
	305	(let ((p (cons #f #f)))
	306	(g p)
6a7489ac LC	307	(h p)
6a7489ac LC	308	(set! p #f)) ;; clear refs left on the stack
2924541b MV	309	(if (not (eq? (g) #f))
	310	(throw 'unresolved)
	311	(begin
	312	(gc)
	313	(or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
	314	(and=> (h) (lambda (o) (equal? o (cons #f #f)))))
	315	(throw 'unresolved)))))))
9247b5bc DH	316
	317	(with-test-prefix "guarding cyclic dependencies"
	318	#t)
	319
	320	)