src/gc.lisp
Fri Apr 3 00:17:02 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-qt.tests/src/gc.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/gc.lisp 2014-10-30 07:59:42.000000000 +0100
@@ -0,0 +1,86 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+;;; The GC stuff depends on (gc :full t) to collect the consed objects.
+;;; Sometimes calling GC twice helps in sbcl.
+
+(defun test-gc (class)
+ "Returns true when some instances of class get garbage collected
+and false otherwise.
+It is not required that every instance is gc'ed, since this rarly happens
+and is not a bug."
+ (let ((objects nil))
+ (dotimes (x 9)
+ (let ((object (make-instance class)))
+ (push (make-weak-pointer object)
+ objects)))
+ (dotimes (x 2)
+ (gc :full t))
+ (5am:is (eql t
+ (some #'(lambda (o) (null (weak-pointer-value o)))
+ objects)))))
+
+(defclass lisp-object ()
+ ((a :initform (make-array '(1000 1000) :initial-element 3))
+ (b :initform (list 1 2 43)))
+ (:documentation "For the object to be (hopefully) garbage colleted
+we cons up some memory."))
+
+(5am:test gc-lisp-object
+ "Ensure that GC works for plain lisp objects."
+ (test-gc 'lisp-object))
+
+(5am:test (gc-object :depends-on gc-lisp-object)
+ "Test garbage collection of a no QObject class."
+ (test-gc 'qt:byte-array))
+
+(5am:test (gc-qobject :depends-on gc-object)
+ "Test garbage collection of a QObject."
+ (test-gc 'qt:object))
+
+(defclass my-gc-object (qt:object)
+ ()
+ (:metaclass smoke::smoke-wrapper-class))
+
+;; FIXME 5am prevents garbage collection!?
+;; use eval !?
+(defun run-gc-child ()
+ (let ((objects nil))
+ (dotimes (x 10)
+ (let ((object (make-instance 'qt:object)))
+ (make-instance 'qt:object :args (list object))
+ ;(cxx:set-parent (make-instance 'qt:object) object)
+ (push object objects)))
+ (gc :full t)))
+
+(defun run-gc-my-child ()
+ (let ((objects nil))
+ (dotimes (x 10)
+ (let ((object (make-instance 'qt:object)))
+; (cxx:set-parent (make-instance 'my-gc-object) object)
+ (make-instance 'my-gc-object :args (list object))
+ (push object objects)))
+ (gc :full t)))
+
+
+(5am:test (gc-child :depends-on gc-qobject)
+ "Test garbage collection of a qt:object with a parent."
+ (gc :full t)
+ (let ((count (hash-table-count smoke::*object-map*)))
+ (eval '(run-gc-child))
+ (gc :full t)
+ (gc :full t)
+ (5am:is (= count (hash-table-count smoke::*object-map*)))))
+
+(5am:test (gc-lisp-child :depends-on (and gc-child with-app))
+ "Test garbage collection of a qt:object with a parent."
+ (gc :full t)
+ (qt:with-core-app
+ (let ((count (hash-table-count smoke::*object-map*)))
+ (eval '(run-gc-my-child))
+ (gc :full t)
+ (qt:core-application.send-posted-events)
+ (gc :full t)
+ (qt:core-application.send-posted-events)
+ (5am:is (= count (hash-table-count smoke::*object-map*))))))