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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10 -*-
;;;; The above modeline is required for Genera. Do not change.
;;;
;;; 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*))
#+clasp
(progn
(pushnew 'pointers.1 rt::*expected-failures*)
(pushnew 'pointers.2 rt::*expected-failures*)
(pushnew 'hashtables.weak-value.1 rt::*expected-failures*))
#+genera
(progn
(pushnew 'hashtables.weak-key.1 rt::*expected-failures*)
(pushnew 'hashtables.weak-key.2 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))
;; lbd should not be defined in a lexical scope where obj is
;; present to prevent closing over the variable on compilers
;; which does not optimize away unused lexenv variables (i.e
;; ecl's bytecmp).
(lbd (lambda () (incf (car cons))))
(obj (string (gensym))))
(dotimes (i count)
(finalize obj lbd))
(when extra-action
(cancel-finalization obj)
(when (eq extra-action :add-again)
(dotimes (i count)
(finalize obj lbd))))
(setq obj (gensym))
(setq obj (dummy obj))
cons))
(defvar *result*)
#+genera
(progn
(pushnew 'finalizers.1 rt::*expected-failures*)
(pushnew 'finalizers.2 rt::*expected-failures*)
(pushnew 'finalizers.3 rt::*expected-failures*)
(pushnew 'finalizers.4 rt::*expected-failures*)
(pushnew 'finalizers.5 rt::*expected-failures*))
;;; 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)
|
