;;;; weaks.test --- tests guile's weaks -*- scheme -*- ;;;; Copyright (C) 1999 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., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 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 :) ;;; Utility stuff (maybe these should go in lib? They're pretty useful ;;; at keeping the code size down) ;; Evaluate form inside a catch; if it throws, return false (define-macro (catch-error-returning-false error . form) `(catch ,error (lambda () (begin ,@form #t)) (lambda (key . args) #f))) (define-macro (catch-error-returning-true error . form) `(catch ,error (lambda () (begin ,@form #f)) (lambda args #t))) (define-macro (pass-if-not string form) `(pass-if ,string (not ,form))) ;;; Creation functions (catch-test-errors (with-test-prefix "weak-creation" (with-test-prefix "make-weak-vector" (pass-if "normal" (catch-error-returning-false #t (define x (make-weak-vector 10 #f)))) (pass-if "bad size" (catch-error-returning-true 'wrong-type-arg (define x (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 "bad-args" (catch-error-returning-true 'wrong-type-arg (define x (list->weak-vector 32))))) (with-test-prefix "make-weak-key-hash-table" (pass-if "create" (catch-error-returning-false #t (define x (make-weak-key-hash-table 17)))) (pass-if "bad-args" (catch-error-returning-true 'wrong-type-arg (define x (make-weak-key-hash-table '(bad arg)))))) (with-test-prefix "make-weak-value-hash-table" (pass-if "create" (catch-error-returning-false #t (define x (make-weak-value-hash-table 17)))) (pass-if "bad-args" (catch-error-returning-true 'wrong-type-arg (define x (make-weak-value-hash-table '(bad arg)))))) (with-test-prefix "make-doubly-weak-hash-table" (pass-if "create" (catch-error-returning-false #t (define x (make-doubly-weak-hash-table 17)))) (pass-if "bad-args" (catch-error-returning-true 'wrong-type-arg (define x (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 (catch-test-errors (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)))))))) (catch-test-errors (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)))) (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)))) (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)))) (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)))))))