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