* tests/weaks.test: Added.

1 files changed, 234 insertions, 0 deletions

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)))))))