repos / qt.gui / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | filehistory
normal | plain | shade | zebra
Clozure CL save-application fixes
Annotate for file src/object.lisp
2009-06-11 tobias 1 (in-package :qt)
2009-05-31 tobias 2 (declaim (optimize (debug 3)))
2010-01-10 tobias 3
2009-06-11 tobias 4 (let ((object (make-instance 'object)))
14:59:48 ' 5 (defmethod cxx:static-meta-object ((class (eql (find-class 'object))))
2009-07-02 tobias 6 "No OBJECT.STATIC-META-OBJECT (r558420)."
19:12:45 ' 7 (cxx:meta-object object))
2009-05-31 tobias 8 (defmethod cxx:static-meta-object ((class smoke::smoke-wrapper-class))
2009-07-02 tobias 9 (cxx:static-meta-object (smoke::find-smoke-class class))))
2010-01-10 tobias 10
2009-05-31 tobias 11 (defmethod documentation :around ((class smoke::smoke-standard-class)
2009-06-11 tobias 12 (doc-type t))
14:59:48 ' 13 (if (and (subtypep class (find-class 'object))
2009-05-31 tobias 14 (not (subtypep class (find-class 'smoke::smoke-wrapper-class))))
2010-01-10 tobias 15 (format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
08:52:49 ' 16
' 17 Signals:
' 18 ~{~T~A~%~}
' 19 Slots:
' 20 ~{~T~A~%~}"
2009-06-11 tobias 21 (call-next-method) (sort (class-properties class) #'string<=)
2010-01-10 tobias 22 (sort (class-signals class) #'string<=)
08:52:49 ' 23 (sort (class-slots class) #'string<=))
' 24 (call-next-method)))
' 25
2009-06-11 tobias 26 (defmethod print-object ((object object) stream)
2010-01-10 tobias 27 (if (or (not (slot-boundp object 'pointer))
08:52:49 ' 28 (null-pointer-p (pointer object)))
' 29 (call-next-method)
2009-08-02 tobias 30 (print-unreadable-object (object stream :type t :identity t)
11:29:13 ' 31 (princ (cxx:object-name object) stream))))
2010-01-10 tobias 32
08:52:49 ' 33 (defun meta-object-methods (meta-object &optional (direct-only nil))
' 34 (loop for index from (if direct-only (cxx:method-offset meta-object) 0)
' 35 below (cxx:method-count meta-object)
' 36 collect (cxx:method meta-object index)))
' 37
' 38
2009-06-11 tobias 39 (defun meta-object-signals (meta-object)
2010-01-10 tobias 40 (mapcar #'cxx:signature
08:52:49 ' 41 (remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
' 42 (cxx:method-type m)))
2009-06-11 tobias 43 (meta-object-methods meta-object))))
2010-01-10 tobias 44
2009-06-11 tobias 45 (defun class-signals (class)
14:59:48 ' 46 (meta-object-signals (cxx:static-meta-object class)))
2010-01-10 tobias 47
2009-06-11 tobias 48 (defun meta-object-slots (meta-object)
2010-01-10 tobias 49 (mapcar #'cxx:signature
08:52:49 ' 50 (remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
' 51 (cxx:method-type m)))
2009-06-11 tobias 52 (meta-object-methods meta-object))))
2010-01-10 tobias 53
08:52:49 ' 54
2009-06-11 tobias 55 (defun class-slots (class)
14:59:48 ' 56 (meta-object-slots (cxx:static-meta-object class)))
2010-01-10 tobias 57
08:52:49 ' 58
2009-05-31 tobias 59 (defvar *children* (make-hash-table)
17:33:32 ' 60 "A list of custom subclasses of QObject which have a parent
' 61 and therefor must not be garbage collected.")
' 62
2009-06-11 tobias 63 (defmethod initialize-instance :after ((object object)
2009-06-11 tobias 64 &key pointer &allow-other-keys)
2010-01-10 tobias 65 "Registers the object to the parent when a parent was set in the constructor
08:52:49 ' 66 and the objects metaclass is SMOKE-WRAPPER-CLASS."
2009-06-11 tobias 67 (when (and (null pointer)
2010-01-10 tobias 68 (null-pointer-p (smoke::pointer object)))
08:52:49 ' 69 (error "Object ~A has not been constructed" object))
' 70 (when (and (null pointer)
' 71 (not (null-pointer-p (smoke::pointer object)))
2009-05-31 tobias 72 ; (typep (class-of object) 'smoke::smoke-wrapper-class)
2009-06-11 tobias 73 (not (null-pointer-p (smoke::pointer (cxx:parent object)))))
2009-05-31 tobias 74 (setf (gethash (smoke::pointer object) *children*) object)))
2010-01-10 tobias 75
08:52:49 ' 76 (define-condition wrapper-gc (storage-condition)
2009-08-02 tobias 77 ((class-name :initarg :class-name
11:15:21 ' 78 :documentation "The class name of the gc'ed object.")
2010-01-10 tobias 79 (pointer :initarg :pointer))
08:52:49 ' 80 (:report (lambda (condition stream)
2009-05-31 tobias 81 (format stream "The object ~A ~A of type smoke-wrapper-class
2009-08-02 tobias 82 has a parent but got garbage collected."
11:15:21 ' 83 (slot-value condition 'class-name)
' 84 (slot-value condition 'pointer)))))
2010-01-10 tobias 85
2009-08-02 tobias 86 (smoke:eval-startup (:compile-toplevel :execute)
2009-07-22 tobias 87 (defparameter *get-parent*
2009-06-21 tobias 88 (smoke::make-smoke-method (smoke::make-smoke-class
09:29:25 ' 89 *qt-smoke*
' 90 "QObject")
' 91 "parent"))
2009-07-22 tobias 92 ;; FIXME this leaks memory when QCoreApplication::exec is never called,
22:21:01 ' 93 ;; beause then, deleteLater has no effect.
' 94 (defparameter *delete-later*
2009-06-21 tobias 95 (smoke::make-smoke-method (smoke::make-smoke-class
09:29:25 ' 96 *qt-smoke*
' 97 "QObject")
' 98 "deleteLater")))
2009-06-10 tobias 99
2009-05-31 tobias 100 (defmethod smoke::make-finalize ((object object))
2009-06-21 tobias 101 "Delete the qt:object OBJECT,
2010-01-10 tobias 102 by calling cxx:delete-later iff it has no parent."
2009-06-21 tobias 103 (let ((pointer (pointer object))
2009-05-31 tobias 104 (name (class-name (class-of object)))
2009-06-21 tobias 105 (next (call-next-method)))
2009-05-31 tobias 106 (if (typep (class-of object) 'smoke::smoke-wrapper-class)
2009-06-21 tobias 107 #'(lambda ()
09:29:25 ' 108 (handler-case
' 109 (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
' 110 (smoke::pointer-call *delete-later* pointer)
2009-06-10 tobias 111 (error (make-condition 'wrapper-gc :class-name name
2009-06-21 tobias 112 :pointer pointer)))
2009-05-31 tobias 113 (condition (condition)
17:33:32 ' 114 (format *debug-io* "error: wrap finalize ~A ~A~%" name
' 115 condition))))
2009-06-21 tobias 116 #'(lambda ()
09:29:25 ' 117 (handler-case
2009-05-31 tobias 118 (progn
17:33:32 ' 119 (when (null-pointer-p (smoke::pointer-call *get-parent* pointer))
' 120 (funcall next)))
' 121 (condition (condition)
' 122 (format *debug-io* "error: qfinalize ~A ~A ~A~%" name
' 123 pointer
' 124 condition))))))
' 125 ;(smoke::pointer-call delete-later pointer)))))))
' 126 )
2010-01-10 tobias 127
08:52:49 ' 128 ;;;
2009-07-22 tobias 129 ;;; The event-notify callback get called by QCoreApplication,
22:21:01 ' 130 ;;; on notification of an event.
2010-01-10 tobias 131 ;;;
2009-07-22 tobias 132 ;;; The DATA argument is an array of size three, containing the pointers:
2010-01-10 tobias 133 ;;; void* receiver
08:52:49 ' 134 ;;; void* event
' 135 ;;; void* result
' 136 ;;; in that order.
' 137 ;;;
' 138 ;;; Returning true marks the event as handled; false on the other hand
' 139 ;;; leaves the event processing unchanged.
' 140 ;;;
2009-07-22 tobias 141 ;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent *event)
2010-01-10 tobias 142
08:52:49 ' 143 (cffi:defcallback event-notify smoke:cxx-bool
' 144 ((data :pointer))
' 145 (declare (optimize (speed 3)))
2009-05-31 tobias 146 (let ((event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1)
17:33:32 ' 147 :owned-p nil)))
2010-01-10 tobias 148 (enum-case (cxx:type event)
2009-06-11 tobias 149 (event.+child-added+
2009-06-10 tobias 150 (let* ((child-event (make-instance 'child-event
2009-08-02 tobias 151 :pointer
2009-05-31 tobias 152 (smoke::upcast event (find-class 'child-event))
17:33:32 ' 153 :owned-p nil))
' 154 (child (smoke::get-object
' 155 (smoke::pointer (cxx:child child-event)))))
' 156 ; (when (and child
' 157 ; (typep (class-of child)
' 158 ; 'smoke::smoke-wrapper-class))
' 159 (when child
' 160 (setf (gethash (smoke::pointer child) *children*) child))))
2009-06-11 tobias 161 (event.+child-removed+
14:59:48 ' 162 (let* ((child-event (make-instance 'child-event
2009-08-02 tobias 163 :pointer (smoke::upcast event
2009-05-31 tobias 164 (find-class 'child-event))
17:33:32 ' 165 :owned-p nil)))
' 166 (remhash (smoke::pointer (cxx:child child-event)) *children*)))))
2010-01-10 tobias 167 nil)
08:52:49 ' 168
2009-05-19 tobias 169 (eval-when (:compile-toplevel :load-toplevel :execute)
14:32:42 ' 170 (cffi:defcfun qt-smoke-register-event-notify :boolean
' 171 (event-notify :pointer)))
2010-01-10 tobias 172
08:52:49 ' 173 (defun register-event-notify ()
' 174 (let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
' 175 (unless ret
2009-06-21 tobias 176 (error "The event-notify callback table is full."))))
2010-01-10 tobias 177
2009-08-02 tobias 178 (smoke:eval-startup ()
2010-01-10 tobias 179 (register-event-notify))
Crece desde el pueblo el futuro / crece desde el pie