repos
/
qt.tests
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Make unit tests work & run tests on darcs record
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 smoke::smoke-wrapper-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)))
2009-06-10 tobias
61
; (cxx:set-parent (make-instance 'my-gc-object) object)
2009-04-02 tobias
62
(make-instance 'my-gc-object :args (list object))
22:17:02 '
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)
2009-06-30 tobias
70
(let ((count (hash-table-count smoke::*object-map*)))
22:48:36 '
71
(eval '(run-gc-child))
'
72
(gc :full t)
'
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))
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))
'
82
(gc :full t)
'
83
(qt:core-application.send-posted-events)
'
84
(gc :full t)
'
85
(qt:core-application.send-posted-events)
2009-04-06 tobias
86
11:50:14 '
87
;; allow some objects to be not collected
'
88
(5am:is (>= (+ count 2) (hash-table-count smoke::*object-map*))))))