src/signal-slot/signal.lisp
Sun Apr 5 19:56:16 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-qt.core/src/signal-slot/signal.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/signal.lisp 2014-11-11 13:37:53.000000000 +0100
@@ -0,0 +1,156 @@
+(in-package :qt)
+(declaim (optimize (debug 3)))
+
+(defclass qsignal-mixin ()
+ ((signal-object :accessor signal-object
+ :initarg :signal-object
+ :initform (make-instance 'signal-object)))
+ (:documentation "in SB-PCL you can not have both
+FUNCALLABLE-STANDARD-CLASS and STANDARD-CLASS,
+thus QSIGNAL is split in three classes.
+
+See:
+ http://www.sbcl.org/manual/Metaobject-Protocol.html#index-validate_002dsuperclass-164"))
+
+(defclass signal-object (object)
+ ((argument-types :accessor argument-types
+ :initarg :argument-types
+ :documentation "List of the argument types"))
+ (:documentation "Qt Signal object.")
+ (:metaclass smoke::smoke-wrapper-class))
+
+(defclass qsignal (qsignal-mixin closer-mop:funcallable-standard-object)
+ ()
+ (:metaclass closer-mop:funcallable-standard-class)
+ (:documentation "A funcallable Qt signal.
+The argument types can be supplied by the :METHOD-TYPES initarg.
+Calling an instance emits the signal."))
+
+(defun make-signal (&rest argument-types)
+ "Returns a funcallable signal. When ARGUMENT-TYPES are not
+specified, they are determined when the first connection is made."
+ (if argument-types
+ (make-instance 'qsignal :argument-types argument-types)
+ (make-instance 'qsignal)))
+
+(defmethod id ((qsignal signal-object))
+ (cxx:method-count (cxx:meta-object qsignal)))
+
+(defmethod initialize-instance :after ((object qsignal) &rest initargs
+ &key (argument-types nil arg-types-p)
+ &allow-other-keys)
+ (declare (ignore initargs))
+ (when arg-types-p
+ (setf (argument-types (signal-object object))
+ argument-types))
+ (closer-mop:set-funcallable-instance-function object
+ #'(lambda (&rest args)
+ (apply #'emit (signal-object object) args)))
+ )
+
+(defun find-slot-id (receiver slot)
+ "Returns the ID of RECEIVER from SLOT."
+ (let ((id (cxx:index-of-slot (cxx:meta-object receiver)
+ (cxx:data (meta-object.normalized-signature slot)))))
+ (when (< id 0)
+ (error "No slot ~S for class ~S.
+The valid slots are: ~{~<~%~T~0,75:;~A ~>~}"
+ slot (class-of receiver)
+ (class-slots (class-of receiver))))
+ id))
+
+(defun connect-signal (qsignal receiver slot &optional (type 0))
+ "Connects a signal to a slot. Returns T on success and NIL otherwise."
+
+ (let ((qsignal (signal-object qsignal))
+ (slot-id (find-slot-id receiver slot)))
+ (when (not (slot-boundp qsignal 'argument-types))
+ (setf (argument-types qsignal)
+ (method-arguments-type (cxx:meta-object receiver)
+ slot-id)))
+ (assert (>= slot-id 0)
+ ()
+ "No slot ~S for class ~S."
+ slot (class-name receiver))
+ (assert (static-call "QMetaObject" "connect#$#$$$"
+ qsignal
+ (id qsignal)
+ receiver
+ slot-id
+ type
+ ;; QMetaObject::connect is responsible for freeing
+ ;; the types array.
+ (types (method-arguments-type
+ (cxx:meta-object receiver)
+ slot-id)))
+ ()
+ "Failed to connect ~S to the slot ~S of ~S."
+ qsignal slot receiver)))
+
+(defun disconnect-signal (qsignal receiver slot)
+ (let ((qsignal (signal-object qsignal))
+ (slot-id (cxx:index-of-slot (cxx:meta-object receiver)
+ (cxx:data
+ (meta-object.normalized-signature slot)))))
+ (assert (>= slot-id 0)
+ ()
+ "No slot ~S for class ~S."
+ slot (class-name receiver))
+ (assert (static-call "QMetaObject" "disconnect#$#$"
+ qsignal
+ (id qsignal)
+ receiver
+ slot-id)
+ ()
+ "Failed to disconnect ~S to the slot ~S of ~S."
+ qsignal slot receiver)))
+
+(defmethod smoke::push-lisp-object (stack object class)
+ (let ((cxx-object (make-cxx-lisp-object object)))
+ (smoke::push-cleanup stack
+
+ #'(lambda ()
+ (qt-smoke-free-lisp-object cxx-object)))
+ (smoke::push-stack2 stack
+ cxx-object
+ 0)))
+
+
+(defun emit (qsignal &rest arguments)
+ "Emits the signal QSIGNAL."
+;;; The first element of args would be used for the return value
+;;; by QMetaObject::invokeMethod(), but for signal-slot connection
+;;; it is ignored.
+ (smoke::with-stack (stack arguments
+ (argument-types qsignal))
+ (cffi:with-foreign-object (args :pointer (1+ (length arguments)))
+ (loop for i from 1 to (smoke::size stack)
+ for type in (argument-types qsignal)
+ do
+ (setf (mem-aref args :pointer i)
+ (if (or (not (typep type (find-class 'smoke::smoke-type)))
+ (= 0 (smoke::type-id type))
+ (= 13 (smoke::type-id type)))
+ (foreign-slot-value
+ (mem-aref (pointer stack)
+ 'smoke::smoke-stack-item
+ i)
+ 'smoke::smoke-stack-item 'smoke::voidp)
+ (foreign-slot-pointer
+ (mem-aref (pointer stack)
+ 'smoke::smoke-stack-item
+ i)
+ 'smoke::smoke-stack-item 'smoke::voidp))))
+ (setf (mem-aref args :pointer 0)
+ (null-pointer))
+ (smoke::static-call *qt-smoke* "QMetaObject" "activate##$?"
+ qsignal
+ (cxx:meta-object qsignal)
+ (id qsignal)
+ args))))
+
+(defmethod disconnect-all ((qsignal qsignal))
+ (unless (disconnect-id (signal-object qsignal)
+ (id (signal-object qsignal))
+ 0
+ 0)))