repos
/
qt.tests
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
initial import
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
'
5
;;; The GC stuff depends on (gc :full t) to collect the consed objects.
'
6
;;; Sometimes calling GC twice helps in sbcl.
'
7
'
8
(defun test-gc (class)
'
9
"Returns true when some instances of class get garbage collected
'
10
and false otherwise.
'
11
It is not required that every instance is gc'ed, since this rarly happens
'
12
and is not a bug."
'
13
(let ((objects nil))
'
14
(dotimes (x 9)
'
15
(let ((object (make-instance class)))
'
16
(push (make-weak-pointer object)
'
17
objects)))
'
18
(dotimes (x 2)
'
19
(gc :full t))
'
20
(5am:is (eql t
'
21
(some #'(lambda (o) (null (weak-pointer-value o)))
'
22
objects)))))
'
23
'
24
(defclass lisp-object ()
'
25
((a :initform (make-array '(1000 1000) :initial-element 3))
'
26
(b :initform (list 1 2 43)))
'
27
(:documentation "For the object to be (hopefully) garbage colleted
'
28
we cons up some memory."))
'
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
()
'
44
(:metaclass smoke::smoke-wrapper-class))
'
45
'
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))
'
53
;(cxx:set-parent (make-instance 'qt:object) object)
'
54
(push object objects)))
'
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
; (cxx:set-parent (make-instance 'my-gc-object) object)
'
62
(make-instance 'my-gc-object :args (list object))
'
63
(push object objects)))
'
64
(gc :full t)))
'
65
'
66
'
67
(5am:test (gc-child :depends-on gc-qobject)
'
68
"Test garbage collection of a qt:object with a parent."
'
69
(gc :full t)
'
70
(let ((count (hash-table-count smoke::*object-map*)))
'
71
(eval '(run-gc-child))
'
72
(gc :full t)
'
73
(gc :full t)
'
74
(5am:is (= count (hash-table-count smoke::*object-map*)))))
'
75
'
76
(5am:test (gc-lisp-child :depends-on (and gc-child with-app))
'
77
"Test garbage collection of a qt:object with a parent."
'
78
(gc :full t)
'
79
(qt:with-core-app
'
80
(let ((count (hash-table-count smoke::*object-map*)))
'
81
(eval '(run-gc-my-child))
'
82
(gc :full t)
'
83
(qt:core-application.send-posted-events)
'
84
(gc :full t)
'
85
(qt:core-application.send-posted-events)
'
86
(5am:is (= count (hash-table-count smoke::*object-map*))))))