repos
/
qt.tests
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
CCL fixes
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
(gc :full t)
22:48:36 '
70
(qt:with-core-app
'
71
(let ((count (hash-table-count smoke::*object-map*)))
'
72
(eval '(run-gc-child))
'
73
(eval '(gc :full t))
'
74
(qt:core-application.send-posted-events)
'
75
(gc :full t)
'
76
(qt:core-application.send-posted-events)
'
77
(gc :full t)
'
78
(5am:is (>= count (hash-table-count smoke::*object-map*))))))
2009-04-02 tobias
79
2009-06-11 tobias
80
(5am:test (gc-lisp-child :depends-on (and gc-child with-app))
2009-04-02 tobias
81
"Test garbage collection of a qt:object with a parent."
22:17:02 '
82
(gc :full t)
2009-07-01 tobias
83
(qt:with-core-app
2009-04-02 tobias
84
(let ((count (hash-table-count smoke::*object-map*)))
22:17:02 '
85
(eval '(run-gc-my-child))
2009-06-10 tobias
86
;; a.k.a :really-full ;)
2009-04-02 tobias
87
(gc :full t)
22:17:02 '
88
(qt:core-application.send-posted-events)
2009-06-10 tobias
89
(eval '(gc :full t))
12:09:14 '
90
(qt:core-application.send-posted-events)
'
91
(eval '(gc :full t))
'
92
(qt:core-application.send-posted-events)
2009-04-02 tobias
93
(gc :full t)
22:17:02 '
94
(qt:core-application.send-posted-events)
2009-04-06 tobias
95
;; allow some objects to be not collected
11:50:14 '
96
(5am:is (>= (+ count 2) (hash-table-count smoke::*object-map*))))))
2009-06-10 tobias
97
12:09:14 '
98
(defun test-gc-cycle ()
2009-06-11 tobias
99
(dotimes (i 10)
15:04:11 '
100
(let ((timer (make-instance 'qt:timer)))
'
101
(qt:connect (qt:get-signal timer "timeout()")
'
102
#'(lambda ()
'
103
(format *debug-io* "Timeout ~A" timer)))))
'
104
(gc :full t)
'
105
(qt:core-application.send-posted-events)
'
106
(gc :full t)
'
107
(qt:core-application.send-posted-events))
2009-06-10 tobias
108
12:09:14 '
109
(5am:test (gc-cycle :depends-on gc-lisp-child)
2009-07-01 tobias
110
"Test GC a unreacable cycle."
2009-06-10 tobias
111
;; timer -> qslot -> closure(lambda)
12:09:14 '
112
;; ^------------------/
2009-07-01 tobias
113
(qt:with-core-app
11:02:20 '
114
(let ((objects (hash-table-count smoke::*object-map*)))
'
115
(eval '(test-gc-cycle))
'
116
(eval '(gc :full t))
'
117
(qt:core-application.send-posted-events)
'
118
(eval '(gc :full t))
'
119
(qt:core-application.send-posted-events)
'
120
(gc :full t)
'
121
(qt:core-application.send-posted-events)
'
122
(gc :full t)
2009-06-30 tobias
123
(5am:is (>= (+ 2 objects) (hash-table-count smoke::*object-map*))))))
2009-06-10 tobias
124
2009-06-11 tobias
125
(5am:test (ownership-transfer-no-wrapper :depends-on gc-lisp-child)
2009-07-01 tobias
126
"Test ownership tranasfer of a QObject without a wrapper."
2009-06-10 tobias
127
(let ((grand-parent (make-instance 'qt:object)))
12:09:14 '
128
(let* ((parent (make-instance 'qt:object :args (list grand-parent)))
'
129
(object (make-instance 'my-object :args (list parent))))
2009-08-27 tobias
130
(declare (ignore object)))
2009-06-10 tobias
131
(gc :full t)
12:09:14 '
132
(qt:core-application.send-posted-events)
'
133
(gc :full t)
'
134
(qt:core-application.send-posted-events)
'
135
(5am:is (member (find-class 'my-object)
'
136
(loop for c across (cxx:children grand-parent) append
'
137
(map 'list #'class-of
2009-08-27 tobias
138
(cxx:children c)))))))
2009-06-10 tobias
139
2009-08-27 tobias
140
2009-06-11 tobias
141
(5am:test (gc-non-smoke-object :depends-on gc-lisp-child)
2009-07-01 tobias
142
"Test adding a child to a non smoke object."
11:02:20 '
143
(qt:with-app
'
144
(let ((model (make-instance 'qt:string-list-model
'
145
:args (list #("a" "b" "c"))))
'
146
(view (make-instance 'qt:list-view))
'
147
(counter 0))
'
148
(setf (cxx:model view) model)
'
149
(qt:connect (qt:get-signal (cxx:selection-model view)
'
150
"selectionChanged(QItemSelection, QItemSelection)")
'
151
#'(lambda (selected deselected)
'
152
(declare (ignore selected deselected))
'
153
(incf counter)))
'
154
(gc :full t)
'
155
(qt:core-application.send-posted-events)
'
156
(gc :full t)
'
157
(qt:core-application.send-posted-events)
'
158
(5am:is (= 0 counter))
'
159
(cxx:select (cxx:selection-model view)
'
160
(cxx:index model 0)
'
161
qt:item-selection-model.+toggle+)
'
162
(5am:is (= 1 counter))
'
163
(cxx:select (cxx:selection-model view)
'
164
(cxx:index model 1)
'
165
qt:item-selection-model.+toggle+)
'
166
(5am:is (= 2 counter)))))
2009-06-11 tobias
167
2009-06-11 tobias
168
#|
18:52:38 '
169
;; FIXME
'
170
(5am:test (gc-variant-cycle :depends-on gc-lisp-child lisp-variant)
'
171
(let ((finalized-p))
'
172
(let* ((list (list nil))
'
173
(variant (qt:make-lisp-variant list)))
'
174
(setf (first list)
'
175
variant)
'
176
(tg:finalize list #'(lambda () (setf finalized-p t)))
'
177
(5am:is (eq nil finalized-p)))
'
178
(gc :full t)
'
179
(gc :full t)
'
180
(5am:is (eq t finalized-p))))
'
181
'
182
|#