mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
8280c8485f
* libguile/weak-table.c: * libguile/weak-table.h: Remove. * libguile.h: Remove weak-table.h include. * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES): (DOT_DOC_FILES): (modinclude_HEADERS): Remove weak-table.[ch]. * libguile/evalext.c: * libguile/fluids.c: * libguile/hash.c: * libguile/init.c: * libguile/print.c: * libguile/scm.h: Remove uses of weak-table.h and free up the tc7. * libguile/hashtab.c: * libguile/hashtab.h: Add deprecated shims to dispatch to (ice-9 weak-tables) when working on weak tables. * module/ice-9/weak-tables.scm: New implementation. Embeds the hash and equality functions in the table itself. * module/ice-9/object-properties.scm: * module/ice-9/poe.scm: * module/ice-9/popen.scm: * module/ice-9/source-properties.scm: * module/language/cps/compile-bytecode.scm: * module/language/ecmascript/array.scm: * module/language/ecmascript/function.scm: * module/oop/goops/save.scm: * module/srfi/srfi-18.scm: * module/srfi/srfi-69.scm: * module/system/base/types.scm: * module/system/base/types/internal.scm: * module/system/foreign.scm: * module/system/vm/assembler.scm: * test-suite/tests/gc.test: * test-suite/tests/hash.test: * test-suite/tests/srfi-69.test: * test-suite/tests/types.test: * test-suite/tests/weaks.test: Update to use new, non-deprecated weak tables API.
268 lines
10 KiB
Scheme
268 lines
10 KiB
Scheme
;;;; weaks.test --- tests guile's weaks -*- scheme -*-
|
||
;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012, 2014, 2025
|
||
;;;; 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 :)
|
||
|
||
(define-module (test-weaks)
|
||
#:use-module (test-suite lib)
|
||
#:use-module (ice-9 weak-vector)
|
||
#:use-module (ice-9 weak-tables)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-26))
|
||
|
||
|
||
;;; 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? (weak-vector-ref wv 0) 'a)
|
||
(eq? (weak-vector-ref wv 1) 'b)
|
||
(eq? (weak-vector-ref wv 2) 'c)
|
||
(eq? (weak-vector-ref wv 3) 'd)
|
||
(eq? (weak-vector-ref wv 4) 'e)
|
||
(eq? (weak-vector-ref wv 5) 'f)
|
||
(eq? (weak-vector-ref wv 6) 'g))))
|
||
(pass-if-exception "bad-args"
|
||
exception:wrong-type-arg
|
||
(list->weak-vector 32)))
|
||
|
||
(with-test-prefix "make-weak-key-hash-table"
|
||
(pass-if "create"
|
||
(make-weak-key-hash-table 17)
|
||
#t)
|
||
(pass-if-exception "bad-args"
|
||
exception:wrong-type-arg
|
||
(make-weak-key-hash-table '(bad arg))))
|
||
(with-test-prefix "make-weak-value-hash-table"
|
||
(pass-if "create"
|
||
(make-weak-value-hash-table 17)
|
||
#t)
|
||
(pass-if-exception "bad-args"
|
||
exception:wrong-type-arg
|
||
(make-weak-value-hash-table '(bad arg))))
|
||
|
||
(with-test-prefix "make-doubly-weak-hash-table"
|
||
(pass-if "create"
|
||
(make-doubly-weak-hash-table 17)
|
||
#t)
|
||
(pass-if-exception "bad-args"
|
||
exception:wrong-type-arg
|
||
(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
|
||
(weak-vector-set! global-weak 0 (string-copy "string"))
|
||
(weak-vector-set! global-weak 1 (string-copy "beans"))
|
||
(weak-vector-set! global-weak 2 (string-copy "to"))
|
||
(weak-vector-set! global-weak 3 (string-copy "utah"))
|
||
(weak-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
|
||
(weak-vector-set! x 0 bar)
|
||
(gc)
|
||
(and (weak-vector-ref x 0) (eq? bar (weak-vector-ref x 0)))))
|
||
(pass-if "dies"
|
||
(begin
|
||
(gc)
|
||
(or (and (not (weak-vector-ref global-weak 0))
|
||
(not (weak-vector-ref global-weak 1))
|
||
(not (weak-vector-ref global-weak 2))
|
||
(not (weak-vector-ref global-weak 3))
|
||
(not (weak-vector-ref global-weak 4)))
|
||
(throw 'unresolved))))))
|
||
|
||
|
||
;;;
|
||
;;; Weak hash tables.
|
||
;;;
|
||
|
||
(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 #:hash hash #:equal? equal?))
|
||
(y (make-weak-value-hash-table #:hash hash #:equal? equal?))
|
||
(z (make-doubly-weak-hash-table #:hash hash #:equal? equal?))
|
||
(test-key "foo")
|
||
(test-value "bar"))
|
||
(with-test-prefix
|
||
"weak-hash"
|
||
(pass-if "lives"
|
||
(begin
|
||
(weak-key-hash-table-set! x test-key test-value)
|
||
(weak-value-hash-table-set! y test-key test-value)
|
||
(doubly-weak-hash-table-set! z test-key test-value)
|
||
(gc)
|
||
(gc)
|
||
(and (weak-key-hash-table-ref x test-key)
|
||
(weak-value-hash-table-ref y test-key)
|
||
(doubly-weak-hash-table-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
|
||
(weak-key-hash-table-set! x (string-copy "this") "is")
|
||
(weak-key-hash-table-set! x (string-copy "a") "test")
|
||
(weak-key-hash-table-set! x (string-copy "of") "the")
|
||
(weak-key-hash-table-set! x (string-copy "emergency") "weak")
|
||
(weak-key-hash-table-set! x (string-copy "key") "hash system")
|
||
(gc)
|
||
(let ((values (map (cut weak-key-hash-table-ref x <>)
|
||
'("this" "a" "of" "emergency" "key"))))
|
||
(and (every valid? values
|
||
'("is" "test" "the" "weak" "hash system"))
|
||
(any not values)
|
||
(weak-key-hash-table-ref x test-key)
|
||
#t))))
|
||
|
||
(pass-if "weak-value dies"
|
||
(begin
|
||
(weak-value-hash-table-set! y "this" (string-copy "is"))
|
||
(weak-value-hash-table-set! y "a" (string-copy "test"))
|
||
(weak-value-hash-table-set! y "of" (string-copy "the"))
|
||
(weak-value-hash-table-set! y "emergency" (string-copy "weak"))
|
||
(weak-value-hash-table-set! y "value" (string-copy "hash system"))
|
||
(gc)
|
||
(let ((values (map (cut weak-value-hash-table-ref y <>)
|
||
'("this" "a" "of" "emergency" "key"))))
|
||
(and (every valid? values
|
||
'("is" "test" "the" "weak" "hash system"))
|
||
(any not values)
|
||
(weak-value-hash-table-ref y test-key)
|
||
#t))))
|
||
|
||
(pass-if "doubly-weak dies"
|
||
(begin
|
||
(doubly-weak-hash-table-set! z (string-copy "this") (string-copy "is"))
|
||
(doubly-weak-hash-table-set! z "a" (string-copy "test"))
|
||
(doubly-weak-hash-table-set! z (string-copy "of") "the")
|
||
(doubly-weak-hash-table-set! z "emergency" (string-copy "weak"))
|
||
(doubly-weak-hash-table-set! z (string-copy "all") (string-copy "hash system"))
|
||
(gc)
|
||
(let ((values (map (cut doubly-weak-hash-table-ref z <>)
|
||
'("this" "a" "of" "emergency" "key"))))
|
||
(and (every valid? values
|
||
'("is" "test" "the" "weak" "hash system"))
|
||
(any not values)
|
||
(doubly-weak-hash-table-ref z test-key)
|
||
#t))))
|
||
|
||
(pass-if "weak-value-hash-table-set!, weak val, im -> im"
|
||
(let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
|
||
(weak-value-hash-table-set! t "foo" 1)
|
||
(weak-value-hash-table-set! t "foo" 2)
|
||
(equal? (weak-value-hash-table-ref t "foo") 2)))
|
||
|
||
(pass-if "weak-value-hash-table-set!, weak val, im -> nim"
|
||
(let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
|
||
(weak-value-hash-table-set! t "foo" 1)
|
||
(weak-value-hash-table-set! t "foo" "baz")
|
||
(equal? (weak-value-hash-table-ref t "foo") "baz")))
|
||
|
||
(pass-if "weak-value-hash-table-set!, weak val, nim -> nim"
|
||
(let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
|
||
(weak-value-hash-table-set! t "foo" "bar")
|
||
(weak-value-hash-table-set! t "foo" "baz")
|
||
(equal? (weak-value-hash-table-ref t "foo") "baz")))
|
||
|
||
(pass-if "weak-value-hash-table-set!, weak val, nim -> im"
|
||
(let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
|
||
(weak-value-hash-table-set! t "foo" "bar")
|
||
(weak-value-hash-table-set! t "foo" 1)
|
||
(equal? (weak-value-hash-table-ref t "foo") 1)))
|
||
|
||
(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
|
||
#:initial-size 2
|
||
#:hash string-hash-ci
|
||
#:equal? (lambda (a b)
|
||
(make-list 123) ;; this should be possible
|
||
(gc) ;; this too
|
||
(string-ci=? a b))))
|
||
(c 123)
|
||
(k "GNU"))
|
||
|
||
(doubly-weak-hash-table-set! h (string-copy "hello")
|
||
(string-copy "world"))
|
||
(doubly-weak-hash-table-set! h k "Guile")
|
||
|
||
(and (every (cut valid? <> "Guile")
|
||
(unfold (cut >= <> c)
|
||
(lambda (_)
|
||
(doubly-weak-hash-table-ref h "gnu"))
|
||
1+
|
||
0))
|
||
(every (cut valid? <> "world")
|
||
(unfold (cut >= <> c)
|
||
(lambda (_)
|
||
(doubly-weak-hash-table-ref h "HELLO"))
|
||
1+
|
||
0))
|
||
#t)))))
|