guile/test-suite/tests/weaks.test

;;;; weaks.test --- tests guile's weaks     -*- scheme -*-
;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program 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 General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.  

;;; {Description} 

;;; This is a semi test suite for weaks; I say semi, because weaks
;;; are pretty non-deterministic given the amount of information we
;;; can infer from scheme.
;;;
;;; In particular, we can't always reliably test the more important
;;; aspects of weaks (i.e., that an object is removed when it's dead)
;;; because we have no way of knowing for certain that the object is
;;; really dead. It tests it anyway, but the failures of any `death'
;;; tests really shouldn't be surprising.
;;;
;;; Interpret failures in the dying functions here as a hint that you
;;; should look at any changes you've made involving weaks
;;; (everything else should always pass), but there are a host of
;;; other reasons why they might not work as tested here, so if you
;;; haven't done anything to weaks, don't sweat it :)

;;; Creation functions 


(with-test-prefix
 "weak-creation"
 (with-test-prefix "make-weak-vector"
  (pass-if "normal"
    (make-weak-vector 10 #f)
    #t)
  (pass-if-exception "bad size"
    exception:wrong-type-arg
    (make-weak-vector 'foo)))

 (with-test-prefix "list->weak-vector"
		   (pass-if "create"
			    (let* ((lst '(a b c d e f g))
				   (wv (list->weak-vector lst)))
			      (and (eq? (vector-ref wv 0) 'a)
				   (eq? (vector-ref wv 1) 'b)
				   (eq? (vector-ref wv 2) 'c)
				   (eq? (vector-ref wv 3) 'd)
				   (eq? (vector-ref wv 4) 'e)
				   (eq? (vector-ref wv 5) 'f)
				   (eq? (vector-ref wv 6) 'g))))
		   (pass-if-exception "bad-args"
		     exception:wrong-type-arg
		     (list->weak-vector 32)))

 (with-test-prefix "make-weak-key-hash-table"
		   (pass-if "create"
		     (make-weak-key-hash-table 17)
		     #t)
		   (pass-if-exception "bad-args"
		     exception:wrong-type-arg
		     (make-weak-key-hash-table '(bad arg))))
 (with-test-prefix "make-weak-value-hash-table"
		   (pass-if "create"
		     (make-weak-value-hash-table 17)
		     #t)
		   (pass-if-exception "bad-args"
		     exception:wrong-type-arg
		     (make-weak-value-hash-table '(bad arg))))

 (with-test-prefix "make-doubly-weak-hash-table"
		   (pass-if "create"
		     (make-doubly-weak-hash-table 17)
		     #t)
		   (pass-if-exception "bad-args"
		     exception:wrong-type-arg
		     (make-doubly-weak-hash-table '(bad arg)))))




;; This should remove most of the non-dying problems associated with
;; trying this inside a closure

(define global-weak (make-weak-vector 10 #f))
(begin
  (vector-set! global-weak 0 "string")
  (vector-set! global-weak 1 "beans")
  (vector-set! global-weak 2 "to")
  (vector-set! global-weak 3 "utah")
  (vector-set! global-weak 4 "yum yum")
  (gc))

;;; Normal weak vectors
(let ((x (make-weak-vector 10 #f))
      (bar "bar"))
  (with-test-prefix 
   "weak-vector"
   (pass-if "lives"
	    (begin
	      (vector-set! x 0 bar)
	      (gc)
	      (and (vector-ref x 0) (eq? bar (vector-ref x 0)))))
   (pass-if "dies"
	    (begin
	      (gc)
	      (or (not (vector-ref global-weak 0))
		  (not (vector-ref global-weak 1))
		  (not (vector-ref global-weak 2))
		  (not (vector-ref global-weak 3))
		  (not (vector-ref global-weak 4)))))))

 (let ((x (make-weak-key-hash-table 17))
      (y (make-weak-value-hash-table 17))
      (z (make-doubly-weak-hash-table 17))
      (test-key "foo")
      (test-value "bar"))
  (with-test-prefix
   "weak-hash"
   (pass-if "lives"
	    (begin
	      (hashq-set! x test-key test-value)
	      (hashq-set! y test-key test-value)
	      (hashq-set! z test-key test-value)
	      (gc)
	      (gc)
	      (and (hashq-ref x test-key)
		   (hashq-ref y test-key)
		   (hashq-ref z test-key)
		   #t)))
   (pass-if "weak-key dies"
	    (begin
	      (hashq-set! x "this" "is")
	      (hashq-set! x "a" "test")
	      (hashq-set! x "of" "the")
	      (hashq-set! x "emergency" "weak")
	      (hashq-set! x "key" "hash system")
	      (gc)
	      (and 
	       (or (not (hashq-ref x "this"))
		   (not (hashq-ref x "a"))
		   (not (hashq-ref x "of"))
		   (not (hashq-ref x "emergency"))
		   (not (hashq-ref x "key")))
	       (hashq-ref x test-key)
	       #t)))

   (pass-if "weak-value dies"
	    (begin
	      (hashq-set! y "this" "is")
	      (hashq-set! y "a" "test")
	      (hashq-set! y "of" "the")
	      (hashq-set! y "emergency" "weak")
	      (hashq-set! y "value" "hash system")
	      (gc)
	      (and (or (not (hashq-ref y "this"))
		       (not (hashq-ref y "a"))
		       (not (hashq-ref y "of"))
		       (not (hashq-ref y "emergency"))
		       (not (hashq-ref y "value")))
		   (hashq-ref y test-key)
		   #t)))
   (pass-if "doubly-weak dies"
	    (begin
	      (hashq-set! z "this" "is")
	      (hashq-set! z "a" "test")
	      (hashq-set! z "of" "the")
	      (hashq-set! z "emergency" "weak")
	      (hashq-set! z "all" "hash system")
	      (gc)
	      (and (or (not (hashq-ref z "this"))
		       (not (hashq-ref z "a"))
		       (not (hashq-ref z "of"))
		       (not (hashq-ref z "emergency"))
		       (not (hashq-ref z "all")))
		   (hashq-ref z test-key)
		   #t)))))