-;;;; 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
-
-
-(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
-(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))))
- (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))))))
+;;;; weaks.test --- tests guile's weaks -*- scheme -*-
+;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010 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
+
+;;; {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 :)
+
+(use-modules (test-suite lib)
+ (ice-9 weak-vector))
+
+;;; 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-alist-vector"
+ (pass-if "create"
+ (make-weak-key-alist-vector 17)
+ #t)
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (make-weak-key-alist-vector '(bad arg))))
+ (with-test-prefix "make-weak-value-alist-vector"
+ (pass-if "create"
+ (make-weak-value-alist-vector 17)
+ #t)
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (make-weak-value-alist-vector '(bad arg))))
+
+ (with-test-prefix "make-doubly-weak-alist-vector"
+ (pass-if "create"
+ (make-doubly-weak-alist-vector 17)
+ #t)
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (make-doubly-weak-alist-vector '(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-copy "string"))
+ (vector-set! global-weak 1 (string-copy "beans"))
+ (vector-set! global-weak 2 (string-copy "to"))
+ (vector-set! global-weak 3 (string-copy "utah"))
+ (vector-set! global-weak 4 (string-copy "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 (and (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)))
+ (throw 'unresolved))))))
+
+ (let ((x (make-weak-key-alist-vector 17))
+ (y (make-weak-value-alist-vector 17))
+ (z (make-doubly-weak-alist-vector 17))
+ (test-key "foo")
+ (test-value "bar"))
+ (with-test-prefix
+ "weak-hash"
+ (pass-if "lives"
+ (begin
+ (hash-set! x test-key test-value)
+ (hash-set! y test-key test-value)
+ (hash-set! z test-key test-value)
+ (gc)
+ (gc)
+ (and (hash-ref x test-key)
+ (hash-ref y test-key)
+ (hash-ref z test-key)
+ #t)))
+
+ ;; In the tests below we use `string-copy' to avoid the risk of
+ ;; unintended retention of a string that we want to be GC'd.
+
+ (pass-if "weak-key dies"
+ (begin
+ (hash-set! x (string-copy "this") "is")
+ (hash-set! x (string-copy "a") "test")
+ (hash-set! x (string-copy "of") "the")
+ (hash-set! x (string-copy "emergency") "weak")
+ (hash-set! x (string-copy "key") "hash system")
+ (gc)
+ (and
+ (or (not (hash-ref x "this"))
+ (not (hash-ref x "a"))
+ (not (hash-ref x "of"))
+ (not (hash-ref x "emergency"))
+ (not (hash-ref x "key")))
+ (hash-ref x test-key)
+ #t)))
+
+ (pass-if "weak-value dies"
+ (begin
+ (hash-set! y "this" (string-copy "is"))
+ (hash-set! y "a" (string-copy "test"))
+ (hash-set! y "of" (string-copy "the"))
+ (hash-set! y "emergency" (string-copy "weak"))
+ (hash-set! y "value" (string-copy "hash system"))
+ (gc)
+ (and (or (not (hash-ref y "this"))
+ (not (hash-ref y "a"))
+ (not (hash-ref y "of"))
+ (not (hash-ref y "emergency"))
+ (not (hash-ref y "value")))
+ (hash-ref y test-key)
+ #t)))
+
+ (pass-if "doubly-weak dies"
+ (begin
+ (hash-set! z (string-copy "this") (string-copy "is"))
+ (hash-set! z "a" (string-copy "test"))
+ (hash-set! z (string-copy "of") "the")
+ (hash-set! z "emergency" (string-copy "weak"))
+ (hash-set! z (string-copy "all") (string-copy "hash system"))
+ (gc)
+ (and (or (not (hash-ref z "this"))
+ (not (hash-ref z "a"))
+ (not (hash-ref z "of"))
+ (not (hash-ref z "emergency"))
+ (not (hash-ref z "all")))
+ (hash-ref z test-key)
+ #t)))))
HCoop / bpt / guile.git / blobdiff