diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test new file mode 100644 index 000000000..c6dbe500f --- /dev/null +++ b/test-suite/tests/weaks.test @@ -0,0 +1,234 @@ +;;;; 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)))))))