repos
/
qt.tests
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Support ASDF instead of Mudballs.
Annotate for file /src/gc.lisp
2009-04-02 tobias
1
(in-package :qt.tests)
22:17:02 '
2
'
3
(5am:in-suite :qt.suite)
'
4
;;; The GC stuff depends on (gc :full t) to collect the consed objects.
2009-07-22 tobias
5
;;; Sometimes calling GC twice helps in SBCL.
2009-04-02 tobias
6
22:17:02 '
7
(defun test-gc (class)
'
8
"Returns true when some instances of class get garbage collected
'
9
and false otherwise.
2009-07-01 tobias
10
It is not required that every instance is gc'ed, since this rarely happens
2009-04-02 tobias
11
and is not a bug."
22:17:02 '
12
(let ((objects nil))
2009-12-13 tobias
13
(dotimes (x 30)
2009-04-02 tobias
14
(let ((object (make-instance class)))
22:17:02 '
15
(push (make-weak-pointer object)
'
16
objects)))
'
17
(dotimes (x 2)
'
18
(gc :full t))
2009-08-30 tobias
19
(5am:is (eq t (some #'(lambda (o) (null (weak-pointer-value o)))
14:18:04 '
20
objects)))))
2009-04-02 tobias
21
22:17:02 '
22
(defclass lisp-object ()
'
23
((a :initform (make-array '(1000 1000) :initial-element 3))
'
24
(b :initform (list 1 2 43)))
2009-07-01 tobias
25
(:documentation "For the object to be (hopefully) garbage collected
2009-04-02 tobias
26
we cons up some memory."))
22:17:02 '
27
'
28
(5am:test gc-lisp-object
'
29
"Ensure that GC works for plain lisp objects."
'
30
(test-gc 'lisp-object))
'
31
'
32
(5am:test (gc-object :depends-on gc-lisp-object)
'
33
"Test garbage collection of a no QObject class."
'
34
(test-gc 'qt:byte-array))
'
35
'
36
(5am:test (gc-qobject :depends-on gc-object)
'
37
"Test garbage collection of a QObject."
'
38
(test-gc 'qt:object))
'
39
2009-08-30 tobias
40
(5am:test gc-multi-object
14:18:04 '
41
"Test garbage collection of a custom object that has two C++ superclasses."
'
42
(test-gc 'my-multi-object))
'
43
2009-04-02 tobias
44
(defclass my-gc-object (qt:object)
22:17:02 '
45
()
2009-05-31 tobias
46
(:metaclass cxx:class))
2009-04-02 tobias
47
22:17:02 '
48
;; FIXME 5am prevents garbage collection!?
'
49
;; use eval !?
'
50
(defun run-gc-child ()
'
51
(let ((objects nil))
'
52
(dotimes (x 10)
'
53
(let ((object (make-instance 'qt:object)))
'
54
(make-instance 'qt:object :args (list object))
2009-07-01 tobias
55
;;(cxx:set-parent (make-instance 'qt:object) object)
2009-04-02 tobias
56
(push object objects)))
22:17:02 '
57
(gc :full t)))
'
58
'
59
(defun run-gc-my-child ()
'
60
(let ((objects nil))
'
61
(dotimes (x 10)
'
62
(let ((object (make-instance 'qt:object)))
'
63
(make-instance 'my-gc-object :args (list object))
'
64
(push object objects)))
'
65
(gc :full t)))
'
66
'
67
'
68
(5am:test (gc-child :depends-on gc-qobject)
'
69
"Test garbage collection of a qt:object with a parent."
'
70
(gc :full t)
2009-06-30 tobias
71
(gc :full t)
2009-07-01 tobias
72
(qt:with-core-app ()
2009-06-30 tobias
73
(let ((count (hash-table-count smoke::*object-map*)))
22:48:36 '
74
(eval '(run-gc-child))
'
75
(eval '(gc :full t))
'
76
(qt:core-application.send-posted-events)
'
77
(gc :full t)
'
78
(qt:core-application.send-posted-events)
'
79
(gc :full t)
'
80
(5am:is (>= count (hash-table-count smoke::*object-map*))))))
2009-04-02 tobias
81
2009-06-11 tobias
82
(5am:test (gc-lisp-child :depends-on (and gc-child with-app))
2009-04-02 tobias
83
"Test garbage collection of a qt:object with a parent."
22:17:02 '
84
(gc :full t)
2009-07-01 tobias
85
(qt:with-core-app ()
2009-04-02 tobias
86
(let ((count (hash-table-count smoke::*object-map*)))
22:17:02 '
87
(eval '(run-gc-my-child))
2009-06-10 tobias
88
;; a.k.a :really-full ;)
2009-04-02 tobias
89
(gc :full t)
22:17:02 '
90
(qt:core-application.send-posted-events)
2009-06-10 tobias
91
(eval '(gc :full t))
12:09:14 '
92
(qt:core-application.send-posted-events)
'
93
(eval '(gc :full t))
'
94
(qt:core-application.send-posted-events)
2009-04-02 tobias
95
(gc :full t)
22:17:02 '
96
(qt:core-application.send-posted-events)
2009-04-06 tobias
97
;; allow some objects to be not collected
11:50:14 '
98
(5am:is (>= (+ count 2) (hash-table-count smoke::*object-map*))))))
2009-06-10 tobias
99
12:09:14 '
100
(defun test-gc-cycle ()
2009-06-11 tobias
101
(dotimes (i 10)
15:04:11 '
102
(let ((timer (make-instance 'qt:timer)))
'
103
(qt:connect (qt:get-signal timer "timeout()")
'
104
#'(lambda ()
'
105
(format *debug-io* "Timeout ~A" timer)))))
'
106
(gc :full t)
'
107
(qt:core-application.send-posted-events)
'
108
(gc :full t)
'
109
(qt:core-application.send-posted-events))
2009-06-10 tobias
110
12:09:14 '
111
(5am:test (gc-cycle :depends-on gc-lisp-child)
2009-07-01 tobias
112
"Test GC a unreachable cycle."
2009-06-10 tobias
113
;; timer -> qslot -> closure(lambda)
12:09:14 '
114
;; ^------------------/
2009-07-01 tobias
115
(qt:with-core-app ()
11:02:20 '
116
(let ((objects (hash-table-count smoke::*object-map*)))
'
117
(eval '(test-gc-cycle))
'
118
(eval '(gc :full t))
'
119
(qt:core-application.send-posted-events)
'
120
(eval '(gc :full t))
'
121
(qt:core-application.send-posted-events)
'
122
(gc :full t)
'
123
(qt:core-application.send-posted-events)
'
124
(gc :full t)
'
125
(5am:is (>= (+ 2 objects) (hash-table-count smoke::*object-map*))))))
2009-06-10 tobias
126
2009-06-11 tobias
127
(5am:test (ownership-transfer-no-wrapper :depends-on gc-lisp-child)
2009-07-01 tobias
128
"Test ownership transfer of a QObject without a wrapper."
2009-06-10 tobias
129
(let ((grand-parent (make-instance 'qt:object)))
2009-08-27 tobias
130
(setf (cxx:object-name grand-parent) "grand parent")
2009-06-10 tobias
131
(let* ((parent (make-instance 'qt:object :args (list grand-parent)))
12:09:14 '
132
(object (make-instance 'my-object :args (list parent))))
2009-08-27 tobias
133
(setf (cxx:object-name parent) "parent"
08:41:11 '
134
(cxx:object-name object) "child"))
2009-06-10 tobias
135
(gc :full t)
12:09:14 '
136
(qt:core-application.send-posted-events)
'
137
(gc :full t)
'
138
(qt:core-application.send-posted-events)
'
139
(5am:is (member (find-class 'my-object)
'
140
(loop for c across (cxx:children grand-parent) append
'
141
(map 'list #'class-of
2009-08-27 tobias
142
(cxx:children c)))))))
2009-06-10 tobias
143
2009-06-11 tobias
144
(5am:test (gc-non-smoke-object :depends-on gc-lisp-child)
2009-07-01 tobias
145
"Test adding a child to a non smoke object."
11:02:20 '
146
(qt:with-app ()
2009-08-27 tobias
147
(let ((model (make-instance 'qt:string-list-model :arg0 #("a" "b" "c")))
2009-07-01 tobias
148
(view (make-instance 'qt:list-view))
11:02:20 '
149
(counter 0))
'
150
(setf (cxx:model view) model)
'
151
(qt:connect (qt:get-signal (cxx:selection-model view)
'
152
"selectionChanged(QItemSelection, QItemSelection)")
'
153
#'(lambda (selected deselected)
'
154
(declare (ignore selected deselected))
'
155
(incf counter)))
2009-08-27 tobias
156
(cxx:destroyed (cxx:selection-model view)
08:41:11 '
157
(cxx:selection-model view))
2009-07-01 tobias
158
(gc :full t)
11:02:20 '
159
(qt:core-application.send-posted-events)
'
160
(gc :full t)
'
161
(qt:core-application.send-posted-events)
'
162
(5am:is (= 0 counter))
'
163
(cxx:select (cxx:selection-model view)
'
164
(cxx:index model 0)
'
165
qt:item-selection-model.+toggle+)
'
166
(5am:is (= 1 counter))
'
167
(cxx:select (cxx:selection-model view)
'
168
(cxx:index model 1)
'
169
qt:item-selection-model.+toggle+)
'
170
(5am:is (= 2 counter)))))
2009-06-11 tobias
171
2009-06-11 tobias
172
#|
18:52:38 '
173
;; FIXME
'
174
(5am:test (gc-variant-cycle :depends-on gc-lisp-child lisp-variant)
'
175
(let ((finalized-p))
'
176
(let* ((list (list nil))
'
177
(variant (qt:make-lisp-variant list)))
'
178
(setf (first list)
'
179
variant)
'
180
(tg:finalize list #'(lambda () (setf finalized-p t)))
'
181
(5am:is (eq nil finalized-p)))
'
182
(gc :full t)
'
183
(gc :full t)
'
184
(5am:is (eq t finalized-p))))
'
185
'
186
|#