1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; tests.lisp --- trivial-garbage tests.
;;;
;;; This software is placed in the public domain by Luis Oliveira
;;; <loliveira@common-lisp.net> and is provided with absolutely no
;;; warranty.
(defpackage #:trivial-garbage-tests
(:use #:cl #:trivial-garbage #:regression-test)
(:nicknames #:tg-tests)
(:export #:run))
(in-package #:trivial-garbage-tests)
(defun run ()
(let ((*package* (find-package :trivial-garbage-tests)))
(do-tests)
(null (set-difference (regression-test:pending-tests)
rtest::*expected-failures*))))
;;;; Weak Pointers
(deftest pointers.1
(weak-pointer-p (make-weak-pointer 42))
t)
(deftest pointers.2
(weak-pointer-value (make-weak-pointer 42))
42)
;;;; Weak Hashtables
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun sbcl-without-weak-hash-tables-p ()
(if (and (find :sbcl *features*)
(not (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")))
'(:and)
'(:or))))
#+(or corman scl #.(tg-tests::sbcl-without-weak-hash-tables-p))
(progn
(pushnew 'hashtables.weak-key.1 rt::*expected-failures*)
(pushnew 'hashtables.weak-key.2 rt::*expected-failures*)
(pushnew 'hashtables.weak-value.1 rt::*expected-failures*))
(deftest hashtables.weak-key.1
(let ((ht (make-weak-hash-table :weakness :key)))
(values (hash-table-p ht)
(hash-table-weakness ht)))
t :key)
(deftest hashtables.weak-key.2
(let ((ht (make-weak-hash-table :weakness :key :test 'eq)))
(values (hash-table-p ht)
(hash-table-weakness ht)))
t :key)
(deftest hashtables.weak-value.1
(let ((ht (make-weak-hash-table :weakness :value)))
(values (hash-table-p ht)
(hash-table-weakness ht)))
t :value)
(deftest hashtables.not-weak.1
(hash-table-weakness (make-hash-table))
nil)
;;;; Finalizers
;;;
;;; These tests are, of course, not very reliable.
(defun dummy (x)
(declare (ignore x))
nil)
(defun test-finalizers-aux (count extra-action)
(let ((cons (list 0))
(obj (string (gensym))))
(dotimes (i count)
(finalize obj (lambda () (incf (car cons)))))
(when extra-action
(cancel-finalization obj)
(when (eq extra-action :add-again)
(dotimes (i count)
(finalize obj (lambda () (incf (car cons)))))))
(setq obj (gensym))
(setq obj (dummy obj))
cons))
(defvar *result*)
;;; I don't really understand this, but it seems to work, and stems
;;; from the observation that typing the code in sequence at the REPL
;;; achieves the desired result. Superstition at its best.
(defmacro voodoo (string)
`(funcall
(compile nil `(lambda ()
(eval (let ((*package* (find-package :tg-tests)))
(read-from-string ,,string)))))))
(defun test-finalizers (count &optional remove)
(gc :full t)
(voodoo (format nil "(setq *result* (test-finalizers-aux ~S ~S))"
count remove))
(voodoo "(gc :full t)")
;; Normally done by a background thread every 0.3 sec:
#+openmcl (ccl::drain-termination-queue)
;; (an alternative is to sleep a bit)
(voodoo "(car *result*)"))
(deftest finalizers.1
(test-finalizers 1)
1)
(deftest finalizers.2
(test-finalizers 1 t)
0)
(deftest finalizers.3
(test-finalizers 5)
5)
(deftest finalizers.4
(test-finalizers 5 t)
0)
(deftest finalizers.5
(test-finalizers 5 :add-again)
5)
|
