repos
/
qt.tests
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Test gc cycle and non cxx:object parent
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))
2009-06-10 tobias
71
(eval '(gc :full t))
2009-06-30 tobias
72
(gc :full t)
22:48:36 '
73
(gc :full t)
2009-06-10 tobias
74
(5am:is (>= count (hash-table-count smoke::*object-map*)))))
2009-04-02 tobias
75
2009-06-10 tobias
76
;(5am:test (gc-lisp-child :depends-on (and gc-child with-app))
12:09:14 '
77
(5am:test gc-lisp-child
2009-04-02 tobias
78
"Test garbage collection of a qt:object with a parent."
22:17:02 '
79
(gc :full t)
2009-07-01 tobias
80
(qt:with-core-app
2009-04-02 tobias
81
(let ((count (hash-table-count smoke::*object-map*)))
22:17:02 '
82
(eval '(run-gc-my-child))
2009-06-10 tobias
83
;; a.k.a :really-full ;)
2009-04-02 tobias
84
(gc :full t)
22:17:02 '
85
(qt:core-application.send-posted-events)
2009-06-10 tobias
86
(eval '(gc :full t))
12:09:14 '
87
(qt:core-application.send-posted-events)
'
88
(eval '(gc :full t))
'
89
(qt:core-application.send-posted-events)
2009-04-02 tobias
90
(gc :full t)
22:17:02 '
91
(qt:core-application.send-posted-events)
2009-04-06 tobias
92
;; allow some objects to be not collected
11:50:14 '
93
(5am:is (>= (+ count 2) (hash-table-count smoke::*object-map*))))))
2009-06-10 tobias
94
12:09:14 '
95
(defun test-gc-cycle ()
'
96
(qt:with-core-app
'
97
(dotimes (i 10)
'
98
(let ((timer (make-instance 'qt:timer)))
'
99
(qt:connect (qt:get-signal timer "timeout()")
'
100
#'(lambda ()
'
101
(format *debug-io* "Timeout ~A" timer)))))
'
102
(gc :full t)
'
103
(qt:core-application.send-posted-events)
'
104
(gc :full t)
'
105
(qt:core-application.send-posted-events)))
'
106
'
107
(5am:test (gc-cycle :depends-on gc-lisp-child)
'
108
"Test GC a unreacable cycle."
'
109
;; timer -> qslot -> closure(lambda)
'
110
;; ^------------------/
'
111
(qt:with-core-app
'
112
(let ((objects (hash-table-count smoke::*object-map*)))
'
113
(eval '(test-gc-cycle))
'
114
(eval '(gc :full t))
'
115
(qt:core-application.send-posted-events)
'
116
(eval '(gc :full t))
'
117
(qt:core-application.send-posted-events)
'
118
(gc :full t)
'
119
(qt:core-application.send-posted-events)
'
120
(gc :full t)
'
121
(5am:is (>= objects (hash-table-count smoke::*object-map*))))))
'
122
'
123
(5am:test ownership-transfer-no-wrapper
'
124
"Test ownership tranasfer of a QObject without a wrapper."
'
125
(let ((grand-parent (make-instance 'qt:object)))
'
126
(let* ((parent (make-instance 'qt:object :args (list grand-parent)))
'
127
(object (make-instance 'my-object :args (list parent))))
'
128
(declare (ignore object)))
'
129
(gc :full t)
'
130
(qt:core-application.send-posted-events)
'
131
(gc :full t)
'
132
(qt:core-application.send-posted-events)
'
133
(5am:is (member (find-class 'my-object)
'
134
(loop for c across (cxx:children grand-parent) append
'
135
(map 'list #'class-of
'
136
(cxx:children c)))))))
'
137