;;;; weaks.test --- tests guile's weaks -*- scheme -*-
-;;;; Copyright (C) 1999, 2001, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012 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
;;; 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))
+(define-module (test-weaks)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 weak-vector)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26))
+
;;; Creation functions
exception:wrong-type-arg
(list->weak-vector 32)))
- (with-test-prefix "make-weak-key-alist-vector"
+ (with-test-prefix "make-weak-key-hash-table"
(pass-if "create"
- (make-weak-key-alist-vector 17)
+ (make-weak-key-hash-table 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"
+ (make-weak-key-hash-table '(bad arg))))
+ (with-test-prefix "make-weak-value-hash-table"
(pass-if "create"
- (make-weak-value-alist-vector 17)
+ (make-weak-value-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-weak-value-alist-vector '(bad arg))))
+ (make-weak-value-hash-table '(bad arg))))
- (with-test-prefix "make-doubly-weak-alist-vector"
+ (with-test-prefix "make-doubly-weak-hash-table"
(pass-if "create"
- (make-doubly-weak-alist-vector 17)
+ (make-doubly-weak-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-doubly-weak-alist-vector '(bad arg)))))
+ (make-doubly-weak-hash-table '(bad arg)))))
(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")
+ (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
(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))
+\f
+;;;
+;;; Weak hash tables & weak alist vectors.
+;;;
+
+(define (valid? value initial-value)
+ ;; Return true if VALUE is "valid", i.e., if it's either #f or
+ ;; INITIAL-VALUE. The idea is to make sure `hash-ref' doesn't return
+ ;; garbage.
+ (or (not value)
+ (equal? value initial-value)))
+
+ (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)
+ (hash-set! x test-key test-value)
+ (hash-set! y test-key test-value)
+ (hash-set! z test-key test-value)
(gc)
(gc)
- (and (hashq-ref x test-key)
- (hashq-ref y test-key)
- (hashq-ref z test-key)
+ (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
- (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)))
+ (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)
+ (let ((values (map (cut hash-ref x <>)
+ '("this" "a" "of" "emergency" "key"))))
+ (and (every valid? values
+ '("is" "test" "the" "weak" "hash system"))
+ (any not values)
+ (hash-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)))
+ (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)
+ (let ((values (map (cut hash-ref y <>)
+ '("this" "a" "of" "emergency" "key"))))
+ (and (every valid? values
+ '("is" "test" "the" "weak" "hash system"))
+ (any not values)
+ (hash-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)))))
+ (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)
+ (let ((values (map (cut hash-ref z <>)
+ '("this" "a" "of" "emergency" "key"))))
+ (and (every valid? values
+ '("is" "test" "the" "weak" "hash system"))
+ (any not values)
+ (hash-ref z test-key)
+ #t))))
+
+ (pass-if "hash-set!, weak val, im -> im"
+ (let ((t (make-weak-value-hash-table)))
+ (hash-set! t "foo" 1)
+ (hash-set! t "foo" 2)
+ (equal? (hash-ref t "foo") 2)))
+
+ (pass-if "hash-set!, weak val, im -> nim"
+ (let ((t (make-weak-value-hash-table)))
+ (hash-set! t "foo" 1)
+ (hash-set! t "foo" "baz")
+ (equal? (hash-ref t "foo") "baz")))
+
+ (pass-if "hash-set!, weak val, nim -> nim"
+ (let ((t (make-weak-value-hash-table)))
+ (hash-set! t "foo" "bar")
+ (hash-set! t "foo" "baz")
+ (equal? (hash-ref t "foo") "baz")))
+
+ (pass-if "hash-set!, weak val, nim -> im"
+ (let ((t (make-weak-value-hash-table)))
+ (hash-set! t "foo" "bar")
+ (hash-set! t "foo" 1)
+ (equal? (hash-ref t "foo") 1)))
+
+ (pass-if "hash-set!, weak key, returns value"
+ (let ((t (make-weak-value-hash-table))
+ (val (string #\f #\o #\o)))
+ (eq? (hashq-set! t "bar" val)
+ (hashv-set! t "bar" val)
+ (hash-set! t "bar" val)
+ val)))
+
+ (pass-if "assoc can do anything"
+ ;; Until 1.9.12, as hash table's custom ASSOC procedure was
+ ;; called with the GC lock alloc held, which imposed severe
+ ;; restrictions on what it could do (bug #29616). This test
+ ;; makes sure this is no longer the case.
+ (let ((h (make-doubly-weak-hash-table 2))
+ (c 123)
+ (k "GNU"))
+
+ (define (assoc-ci key bucket)
+ (make-list 123) ;; this should be possible
+ (gc) ;; this too
+ (find (lambda (p)
+ (string-ci=? key (car p)))
+ bucket))
+
+ (hashx-set! string-hash-ci assoc-ci h
+ (string-copy "hello") (string-copy "world"))
+ (hashx-set! string-hash-ci assoc-ci h
+ k "Guile")
+
+ (and (every (cut valid? <> "Guile")
+ (unfold (cut >= <> c)
+ (lambda (_)
+ (hashx-ref string-hash-ci assoc-ci
+ h "gnu"))
+ 1+
+ 0))
+ (every (cut valid? <> "world")
+ (unfold (cut >= <> c)
+ (lambda (_)
+ (hashx-ref string-hash-ci assoc-ci
+ h "HELLO"))
+ 1+
+ 0))
+ #t)))))
HCoop / bpt / guile.git / blobdiff