src/signal-slot
Sun Apr 5 19:56:16 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
diff -rN -u old-qt.core/src/signal-slot/connect.lisp new-qt.core/src/signal-slot/connect.lisp
--- old-qt.core/src/signal-slot/connect.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/connect.lisp 2014-11-11 13:37:33.000000000 +0100
@@ -0,0 +1,168 @@
+(in-package :qt)
+
+(defgeneric connect (qsignal slot &optional type)
+ (:documentation "Connects a signal to a slot."))
+
+(defgeneric disconnect (qsignal slot)
+ (:documentation "Disconnects a connection."))
+
+(defgeneric disconnect-all (qsignal)
+ (:documentation "Disconnects all connections of QSIGNAL."))
+
+(defun check-argument-types (signal-arguments slot-arguments)
+ (assert (= (length signal-arguments) (length slot-arguments)))
+ (loop for signal-arg in signal-arguments
+ for slot-arg in slot-arguments do
+ (assert (subtypep signal-arg slot-arg))))
+
+;;FIXME check argument-types
+(defmethod connect ((qsignal qsignal) (qslot qslot) &optional type)
+ (assert (or (slot-boundp (signal-object qsignal) 'argument-types)
+ (slot-boundp qslot 'arguments))
+ ((slot-value (signal-object qsignal) 'argument-types)
+ (slot-value qslot 'arguments))
+ "Argument types must be specified for at least on of
+~A and ~A." qsignal qslot)
+ (when (not (slot-boundp (signal-object qsignal) 'argument-types))
+ (setf (argument-types (signal-object qsignal))
+ (arguments qslot)))
+ (when (not (slot-boundp qslot 'arguments))
+ (setf (slot-value qslot 'arguments)
+ (argument-types (signal-object qsignal))))
+ (check-argument-types (argument-types (signal-object qsignal))
+ (arguments qslot))
+ (unless (connect-id (signal-object qsignal) (id (signal-object qsignal))
+ qslot (id qslot)
+ type
+ (types (arguments qslot)))
+ (cerror "Failed to connect ~S to ~S." qsignal qslot)))
+
+(defmethod connect ((sender qsignal) (function function) &optional type)
+ (let ((slot (make-instance 'qslot
+ :args (list (signal-object sender))
+ :slot-function function)))
+ (unless (connect-id (signal-object sender) (id (signal-object sender))
+ slot (id slot)
+ type
+ (types (arguments sender)))
+ (cerror "Failed to connect the function ~S to the signal ~S."
+ function sender))))
+
+(defclass qt-signal-slot-name ()
+ ((name :initarg :name
+ :reader name)))
+
+(defclass qt-signal (qt-signal-slot-name)
+ ((sender :initarg :sender
+ :reader qsender))
+ (:documentation "Qt C++ signal."))
+
+(defclass qt-slot (qt-signal-slot-name)
+ ((receiver :initarg :receiver
+ :reader receiver))
+ (:documentation "Qt C++ slot."))
+
+(defun get-slot (receiver name)
+ "Returns the slot of RECEIVER with NAME."
+ (make-instance 'qt-slot :receiver receiver :name name))
+
+(defun get-signal (sender name)
+ "Returns the signal NAME of SENDER."
+ (make-instance 'qt-signal :sender sender :name name))
+
+(defmethod connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)
+ (unless (object.connect (qsender qt-signal) (qsignal (name qt-signal))
+ (receiver qt-slot) (qslot (name qt-slot))
+ (or type +auto-connection+))
+ (cerror "Failed to connect ~A ~A to ~A ~A."
+ (qsender qt-signal) (name qt-signal)
+ (receiver qt-slot) (name qt-slot))))
+
+(defmethod disconnect ((qt-signal qt-signal) (qt-slot qt-slot))
+ (unless (object.disconnect (qsender qt-signal) (qsignal (name qt-signal))
+ (receiver qt-slot) (qslot (name qt-slot)))
+ (cerror "Failed to disconnect ~A ~A from ~A ~A."
+ (receiver qt-slot) (name qt-slot)
+ (qsender qt-signal) (name qt-signal))))
+
+(defmethod disconnect-all ((sender object))
+ (unless (object.disconnect sender 0 0 0)
+ (cerror "Failed to disconnect everything connected to ~A."
+ sender)))
+
+
+(defmethod connect ((qt-signal qt-signal) (function function) &optional type)
+ (let* ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal)))
+ (slot (make-instance 'qslot
+ ;; Set the sender as the slots parent,
+ ;; to ensure it does not get gc'ed.
+ ;; FIXME: unset parent on disconnect
+ ;; this no not critical beause the slot object
+ ;; is hidden from the user, who thus can not
+ ;; connect it to other signals.
+ :args (list (qsender qt-signal))
+ :slot-function function
+ :argument-types
+ (method-arguments-type
+ (cxx:meta-object (qsender qt-signal))
+ signal-id))))
+ (if (connect-id (qsender qt-signal) signal-id
+ slot (id slot)
+ type (types (arguments slot)))
+ (cxx:connect-notify (qsender qt-signal)
+ (name qt-signal))
+ (cerror "Ignore" "Failed to connect the signal ~S of ~S to the function ~S."
+ (name qt-signal) (qsender qt-signal) function))))
+
+(defmethod connect ((qt-signal qt-signal) (slot qslot) &optional type)
+ (let ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal))))
+ (if (slot-boundp slot 'arguments)
+ (check-argument-types (method-arguments-type (cxx:meta-object
+ (qsender qt-signal))
+ signal-id)
+ (arguments slot))
+ (setf (slot-value slot 'arguments)
+ (method-arguments-type (cxx:meta-object (qsender qt-signal))
+ signal-id)))
+ (if (connect-id (qsender qt-signal) signal-id
+ slot (id slot)
+ type (types (arguments slot)))
+ (cxx:connect-notify (qsender qt-signal)
+ (name qt-signal))
+ (cerror "Ignore" "Failed to connect the signal ~S of ~S to the slot ~S."
+ (name qt-signal) (qsender qt-signal) slot))))
+
+(defmethod connect ((qsignal qsignal) (slot qt-slot) &optional type)
+ (let ((slot-id (find-slot-id (receiver slot) (name slot))))
+ (if (slot-boundp (signal-object qsignal) 'argument-types)
+ (check-argument-types (argument-types (signal-object slot))
+ (method-arguments-type (cxx:meta-object
+ (receiver slot))
+ slot-id))
+ (setf (argument-types (signal-object qsignal))
+ (method-arguments-type (cxx:meta-object (receiver slot))
+ slot-id)))
+ (unless (connect-id (signal-object qsignal) (id (signal-object qsignal))
+ (receiver slot) slot-id
+ type
+ (types (argument-types (signal-object qsignal))))
+ (cerror "Failed to connect ~S to ~S." qsignal slot))))
+
+
+(defun connect-id (sender signal-id receiver slot-id type types)
+ (static-call "QMetaObject" "connect#$#$$$"
+ sender
+ signal-id
+ receiver
+ slot-id
+ (if (null type)
+ (value +auto-connection+)
+ (value type))
+ types))
+
+(defun disconnect-id (sender signal-id receiver slot-id)
+ (static-call "QMetaObject" "disconnect#$#$"
+ sender
+ signal-id
+ receiver
+ slot-id))
diff -rN -u old-qt.core/src/signal-slot/signal-slot.lisp new-qt.core/src/signal-slot/signal-slot.lisp
--- old-qt.core/src/signal-slot/signal-slot.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/signal-slot.lisp 2014-11-11 13:37:33.000000000 +0100
@@ -0,0 +1,35 @@
+(in-package :qt)
+
+
+(defclass funcallable-smoke-class (closer-mop:funcallable-standard-class
+ smoke::smoke-wrapper-class)
+ ())
+
+(defmethod closer-mop:validate-superclass ((class funcallable-smoke-class)
+ (superclass closer-mop:funcallable-standard-class))
+ t)
+
+(defgeneric id (method))
+
+(defun munged-name-p (name)
+ "Returns true when NAME is a METHOD, SLOT or SIGNAL."
+ (and (> (length name) 0)
+ (case (aref name 0)
+ ((#\0 #\1 #\2) t)
+ (t nil))))
+
+(defun qmethod (name)
+ "Equivalent of the METHOD(a) CPP macro."
+ (assert (not (munged-name-p name)))
+ (format nil "0~A" name))
+
+(defun qslot (name)
+ "Equivalent of the SLOT(a) CPP macro."
+ (assert (not (munged-name-p name)))
+ (format nil "1~A" name))
+
+(defun qsignal (name)
+ "Equivalent of the SIGNAL(a) CPP macro."
+ (assert (not (munged-name-p name)))
+ (format nil "2~A" name))
+
diff -rN -u old-qt.core/src/signal-slot/signal.lisp new-qt.core/src/signal-slot/signal.lisp
--- 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:33.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)))
diff -rN -u old-qt.core/src/signal-slot/slot.lisp new-qt.core/src/signal-slot/slot.lisp
--- old-qt.core/src/signal-slot/slot.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/slot.lisp 2014-11-11 13:37:33.000000000 +0100
@@ -0,0 +1,84 @@
+(in-package :qt)
+(declaim (optimize (debug 3)))
+
+(defclass qslot (object)
+ ((arguments :reader arguments :initarg :argument-types
+ :documentation "List of the argument types for the slot.")
+ (function :reader slot-function :initarg :slot-function
+ :initform (error "no function specified")
+ :documentation "The function called when the slot is invoked."))
+ (:metaclass smoke::smoke-wrapper-class)
+ (:documentation "A Qt slot that calls its associated function"))
+
+(defun make-slot (function &optional (arguments nil arguments-p))
+ "Returns a slot that calls FUNCTION when it receives a signal."
+ (if arguments-p
+ (make-instance 'qslot
+ :slot-function function
+ :argument-types arguments)
+ (make-instance 'qslot
+ :slot-function function)))
+
+(defmethod id ((slot qslot))
+ (cxx:method-count (cxx:meta-object slot)))
+
+(defparameter *sender* nil)
+(defmacro sender ()
+ "Returns the sender that invoked the slot."
+ `*sender*)
+
+(defun method-argument-count (metaobject index)
+ "Returns the number of arguments for the method INDEX of METAOBJECT."
+ (let ((signature (cxx:signature (cxx:method metaobject index))))
+ (setf signature (subseq signature (1+ (position #\( signature))
+ (position #\) signature :from-end t)))
+ (if (= 0 (length signature))
+ 0
+ (1+ (count #\, signature)))))
+
+(defmethod cxx::qt-metacall ((slot qslot) &rest args
+ &aux (a (third args)))
+ "Invoke the slots function when it is called. The return value
+of the invoked slot function is ignored."
+ (let ((id (call-next-method)))
+ (if (< id 0)
+ id
+ (if (enum= (first args) meta-object.+invoke-meta-method+)
+ (progn
+ (case id
+ (0 (let ((*sender* (cxx:sender slot)))
+ (apply (slot-function slot)
+ (arguments-to-lisp a (arguments slot))))))
+ (1- id))
+ id))))
+
+(defun find-signal-id (sender signal)
+ "Returns the ID of SIGNAL from SENDER."
+ (let ((id (cxx:index-of-signal (cxx:meta-object sender)
+ (cxx:data (meta-object.normalized-signature signal)))))
+ (when (< id 0)
+ (error "No signal ~S for class ~S."
+ signal (class-of sender)))
+ id))
+
+(defun connect-function (sender signal function &optional (type 0))
+ "Connects FUNCTION to the SIGNAL of SENDER.
+The return value of FUNCTION is ignored."
+ (let* ((signal-id (find-signal-id sender signal))
+ (slot (make-instance 'qslot
+ :args (list sender)
+ :slot-function function
+ :argument-types (method-arguments-type
+ (cxx:meta-object sender)
+ signal-id))))
+ (let ((ret (static-call "QMetaObject" "connect#$#$$$"
+ sender
+ signal-id
+ slot
+ (id slot)
+ type
+ (types (arguments slot)))))
+ (if ret
+ (cxx:connect-notify sender signal)
+ (cerror "Failed to connect the signal ~S of ~S to the function ~S."
+ signal sender function)))))
diff -rN -u old-qt.core/src/signal-slot/translate.lisp new-qt.core/src/signal-slot/translate.lisp
--- old-qt.core/src/signal-slot/translate.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/translate.lisp 2014-11-11 13:37:33.000000000 +0100
@@ -0,0 +1,83 @@
+(in-package :qt)
+
+(defun method-argument-count (metaobject index)
+ "Returns the number of arguments the method INDEX of METAOBJECT."
+ (let ((signature (cxx:signature (cxx:method metaobject index))))
+ (setf signature (subseq signature (1+ (position #\( signature))
+ (position #\) signature :from-end t)))
+ (if (= 0 (length signature))
+ 0
+ (1+ (count #\, signature)))))
+
+(defun find-type (name &optional start end)
+ (smoke::make-smoke-type *qt-smoke* (subseq name start end)))
+
+(defun method-arguments-type (metaobject index)
+ "Returns a type name list for the arguments of method INDEX of METAOBJECT."
+ (let* ((signature (cxx:signature (cxx:method metaobject index)))
+ (arguments (subseq signature (1+ (position #\( signature))
+ (position #\) signature :from-end t)))
+ (argument-types ())
+ (last-pos (length arguments)))
+ (loop as pos = (position #\, arguments :from-end t :end last-pos)
+ while pos
+ do
+ (push (find-type arguments (1+ pos) last-pos) argument-types)
+ (setf last-pos pos))
+ (when (> last-pos 0)
+ (push (find-type arguments 0 last-pos) argument-types))))
+
+
+(defun arguments-to-lisp2 (argument types values)
+ (if (null types)
+ values
+ (arguments-to-lisp2 (inc-pointer argument (foreign-type-size :pointer))
+ (rest types)
+ (nconc values
+ (list
+ (typecase (first types)
+ ;(smoke::smoke-standard-object
+ ; (smoke::object-to-lisp
+ ; (mem-ref
+ ; (mem-ref argument
+ ; :pointer) :pointer)
+ ; (first types)))
+ (smoke::smoke-type
+ (smoke::type-to-lisp argument
+ (first types)))
+ (t
+ (translate-cxx-lisp-object
+ (mem-ref argument :pointer)))))))))
+
+(defun arguments-to-lisp (arguments types)
+ (arguments-to-lisp2 (inc-pointer arguments ;; index 0 is for the return value
+ (foreign-type-size :pointer))
+ types ()))
+
+
+(defun get-type (smoke-type)
+ (typecase smoke-type
+ (smoke::smoke-standard-object
+ (if (smoke::pointer-p smoke-type)
+ (error "FOO");;qmetatype.+voidstar+
+ (let ((type (meta-type.type (smoke::name smoke-type))))
+ (assert (/= 0 type)
+ (type)
+ "The type ~S has no QMetaType."
+ (smoke::name smoke-type))
+ type)))
+ (t
+ *cxx-lisp-object-metatype*)))
+
+
+(defun types (smoke-types)
+ ;;FIXME free TYPES on error.
+ (let ((types (cffi:foreign-alloc :int :count (1+ (length smoke-types))))
+ (index 0))
+ (dolist (type smoke-types)
+ (setf (cffi:mem-aref types :int index)
+ (get-type type))
+ (incf index))
+ (setf (cffi:mem-aref types :int index)
+ 0)
+ types))