Break API compatibility for qt:with-app and qt:exec & spellcheck
Annotate for file src/signal-slot/signal.lisp
2010-01-10 tobias 1 (in-package :cl-smoke.qt-impl)
08:52:49 ' 2
' 3 (defclass qsignal-mixin ()
' 4 ((signal-object :accessor signal-object
' 5 :initarg :signal-object
' 6 :initform (make-instance 'signal-object)))
' 7 (:documentation "in SB-PCL you can not have both
' 8 FUNCALLABLE-STANDARD-CLASS and STANDARD-CLASS,
' 9 thus QSIGNAL is split in three classes.
' 10
' 11 See:
' 12 http://www.sbcl.org/manual/Metaobject-Protocol.html#index-validate_002dsuperclass-164"))
' 13
' 14 (defclass signal-object (qt:object)
' 15 ((argument-types :accessor argument-types
' 16 :initarg :argument-types
' 17 :documentation "List of the argument types"))
' 18 (:documentation "Qt Signal object.")
' 19 (:metaclass cxx:class))
' 20
' 21 #+cmu (defmethod closer-mop:validate-superclass ((class closer-mop:funcallable-standard-class)
' 22 (superclass standard-class))
' 23 t)
' 24
' 25 (defclass qsignal (closer-mop:funcallable-standard-object qsignal-mixin)
' 26 ()
' 27 (:metaclass closer-mop:funcallable-standard-class)
' 28 (:documentation "A funcallable Qt signal.
' 29 The argument types can be supplied by the :METHOD-TYPES initarg.
' 30 Calling an instance emits the signal."))
' 31
' 32 (defun qt:make-signal (&rest argument-types)
' 33 "Returns a funcallable signal. When ARGUMENT-TYPES are not
' 34 specified, they are determined when the first connection is made."
' 35 (if argument-types
' 36 (make-instance 'qsignal :argument-types argument-types)
' 37 (make-instance 'qsignal)))
' 38
' 39 (defmethod id ((qsignal signal-object))
' 40 (cxx:method-count (cxx:meta-object qsignal)))
' 41
' 42 (defmethod initialize-instance :after ((object qsignal) &rest initargs
' 43 &key (argument-types nil arg-types-p)
' 44 &allow-other-keys)
' 45 (declare (ignore initargs))
' 46 (when arg-types-p
' 47 (setf (argument-types (signal-object object))
' 48 argument-types))
' 49 (closer-mop:set-funcallable-instance-function object
' 50 #'(lambda (&rest args)
2009-07-22 tobias 51 (apply #'emit (signal-object object) args)))
22:21:01 ' 52 )
2010-01-10 tobias 53
08:52:49 ' 54 (defun find-slot-id (receiver slot)
' 55 "Returns the ID of RECEIVER from SLOT."
2009-07-01 tobias 56 ;; For efficiency assume that SLOT is normalized and fallback
10:58:06 ' 57 ;; to normalizing when not. (Just like Qt does.)
2010-01-10 tobias 58 (let ((id (cxx:index-of-slot (cxx:meta-object receiver)
08:52:49 ' 59 slot)))
' 60 (when (< id 0)
' 61 (setf id (cxx:index-of-slot (cxx:meta-object receiver)
2009-07-24 tobias 62 (cxx:data (qt:meta-object.normalized-signature slot)))))
2010-01-10 tobias 63 (when (< id 0)
08:52:49 ' 64 (error "No slot ~S for class ~S.
' 65 The valid slots are: ~{~<~%~T~0,75:;~A ~>~}"
' 66 slot (class-of receiver)
' 67 (class-slots (class-of receiver))))
' 68 id))
' 69
' 70
' 71 (defun make-lisp-object (object)
2009-07-22 tobias 72 (smoke::make-cleanup-pointer (make-cxx-lisp-object object)
22:21:01 ' 73 #'qt-smoke-free-lisp-object))
2010-01-10 tobias 74
08:52:49 ' 75
' 76 (defun convert-arguments (arguments types)
' 77 "Returns a list of ARGUMENTS converted to TYPES."
' 78 (mapcar #'(lambda (argument type)
' 79 (if (typep type 'smoke::smoke-type)
' 80 (smoke::convert-argument argument type)
' 81 (progn (assert (typep argument type)
' 82 ()
' 83 "The argument ~S is not of type ~S.")
' 84 (make-lisp-object argument))))
' 85 arguments types))
' 86
' 87 (defun emit (qsignal &rest arguments)
' 88 "Emits the signal QSIGNAL."
2009-07-22 tobias 89 ;;; The first element of args would be used for the return value
22:21:01 ' 90 ;;; by QMetaObject::invokeMethod(), but for signal-slot connection
' 91 ;;; it is ignored.
2009-07-02 tobias 92 (let ((types (argument-types qsignal)))
19:12:45 ' 93 (smoke::with-stack (stack (convert-arguments arguments types)
' 94 types)
' 95 (cffi:with-foreign-object (args :pointer (1+ (length arguments)))
' 96 (loop for i from 1 to (smoke::size stack)
' 97 for type in (argument-types qsignal)
' 98 do
2010-01-10 tobias 99 (setf (mem-aref args :pointer i)
08:52:49 ' 100 (if (or (not (typep type (find-class 'smoke::smoke-type)))
' 101 (= 0 (smoke::type-id type))
' 102 (= 13 (smoke::type-id type)))
' 103 (foreign-slot-value
2009-07-08 tobias 104 (mem-aref (pointer stack)
2010-01-10 tobias 105 'smoke::smoke-stack-item
08:52:49 ' 106 i)
' 107 'smoke::smoke-stack-item 'smoke::voidp)
' 108 (foreign-slot-pointer
2009-07-08 tobias 109 (mem-aref (pointer stack)
2010-01-10 tobias 110 'smoke::smoke-stack-item
08:52:49 ' 111 i)
' 112 'smoke::smoke-stack-item 'smoke::voidp))))
2009-07-02 tobias 113 (setf (mem-aref args :pointer 0)
19:12:45 ' 114 (null-pointer))
' 115 (qt:meta-object.activate qsignal (cxx:meta-object qsignal)
' 116 (id qsignal)
' 117 args)))))
2010-01-10 tobias 118
08:52:49 ' 119 (defmethod qt:disconnect-all ((qsignal qsignal))
' 120 (unless (disconnect-id (signal-object qsignal)
' 121 (id (signal-object qsignal))
' 122 0
' 123 0)))