src/signal-slot
Sun Jan 10 09:52:49 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Split up in qt.gui & cleanup name prefix.
diff -rN -u old-qt.gui/src/signal-slot/connect.lisp new-qt.gui/src/signal-slot/connect.lisp
--- old-qt.gui/src/signal-slot/connect.lisp 2014-10-30 07:42:32.000000000 +0100
+++ new-qt.gui/src/signal-slot/connect.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,204 +0,0 @@
-(in-package :cl-smoke.qt-impl)
-
-(defgeneric qt:connect (qsignal slot &optional type)
- (:documentation "Connects a signal to a slot."))
-
-(defgeneric qt:disconnect (qsignal slot)
- (:documentation "Disconnects a connection."))
-
-(defgeneric qt: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
- (if (typep signal-arg 'smoke::smoke-type)
- (assert (smoke-type= signal-arg slot-arg))
- (assert (subtypep signal-arg slot-arg)))))
-
-;;FIXME check argument-types
-(defmethod qt: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 qt:connect ((sender qsignal) (function function) &optional type)
- (let ((slot (make-instance 'qslot
- :arg0 (signal-object sender)
- :argument-types (argument-types (signal-object sender))
- :slot-function function)))
-
- (unless (connect-id (signal-object sender) (id (signal-object sender))
- slot (id slot)
- type
- (types (argument-types (signal-object 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."))
-
-(defmethod print-object ((qt-signal qt-signal) stream)
- (print-unreadable-object (qt-signal stream :type t :identity t)
- (when (slot-boundp qt-signal 'sender)
- (princ (qsender qt-signal) stream))
- (princ " " stream)
- (when (slot-boundp qt-signal 'name)
- (princ (name qt-signal) stream))))
-
-(defgeneric qt:get-slot (receiver name)
- (:documentation "Returns the slot of RECEIVER with NAME.")
- (:method (receiver name)
- (make-instance 'qt-slot :receiver receiver :name name))
- (:method (receiver (function function))
- "Returns a slot for RECEIVER that calls function
-with RECEIVER as the first argument."
- (make-instance 'qslot
- :arg0 receiver
- :slot-function #'(lambda (&rest args)
- (apply function (cxx:parent *this*)
- args)))))
-
-(define-compiler-macro qt:get-slot (&whole form receiver name)
- "Normalize the slot name."
- (if (stringp name)
- (let ((normalized-name (cxx:data
- (qt:meta-object.normalized-signature name))))
- (if (string= name normalized-name) ;; Avoid infinite recursion
- form
- `(qt:get-slot ,receiver ,normalized-name)))
- form))
-
-(defun qt:get-signal (sender name)
- "Returns the signal NAME of SENDER."
- (make-instance 'qt-signal :sender sender :name name))
-
-(define-compiler-macro qt:get-signal (&whole form sender name)
- "Normalize the signal name."
- (if (stringp name)
- (let ((normalized-name (cxx:data
- (qt:meta-object.normalized-signature name))))
- (if (string= name normalized-name) ;; Avoid infinite recursion
- form
- `(qt:get-signal ,sender ,normalized-name)))
- form))
-
-(defmethod qt:connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)
- (unless (qt:object.connect (qsender qt-signal) (qt:qsignal (name qt-signal))
- (receiver qt-slot) (qt:qslot (name qt-slot))
- (or type qt:+auto-connection+))
- (cerror "Failed to connect ~A ~A to ~A ~A."
- (qsender qt-signal) (name qt-signal)
- (receiver qt-slot) (name qt-slot))))
-
-(defmethod qt:disconnect ((qt-signal qt-signal) (qt-slot qt-slot))
- (unless (qt:object.disconnect (qsender qt-signal) (qt:qsignal (name qt-signal))
- (receiver qt-slot) (qt: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 qt:disconnect-all ((sender qt:object))
- (unless (qt:object.disconnect sender 0 0 0)
- (cerror "Failed to disconnect everything connected to ~A."
- sender)))
-
-
-(defmethod qt: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
- :arg0 (qsender qt-signal)
- :slot-function function
- :argument-types
- (method-arguments-type
- (cxx:meta-object (qsender qt-signal))
- signal-id))))
- ;; Ensure that the slot is not gc'ed as long as the QT-SIGNAL
- ;; exists.
- ;;
- ;; FIXME: remove on disconnect.
- ;; This no not critical because the slot
- ;; object is not accessible to the user,
- ;; who thus can not connect it to other
- ;; signals.
- (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 qt: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 qt: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)
- (qt:meta-object.connect sender signal-id
- receiver slot-id
- (if (null type)
- qt:+auto-connection+
- type)
- types))
-
-(defun disconnect-id (sender signal-id receiver slot-id)
- (qt:meta-object.disconnect sender signal-id receiver slot-id))
diff -rN -u old-qt.gui/src/signal-slot/signal-slot.lisp new-qt.gui/src/signal-slot/signal-slot.lisp
--- old-qt.gui/src/signal-slot/signal-slot.lisp 2014-10-30 07:42:32.000000000 +0100
+++ new-qt.gui/src/signal-slot/signal-slot.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,35 +0,0 @@
-(in-package :cl-smoke.qt-impl)
-
-
-(defclass funcallable-smoke-class (closer-mop:funcallable-standard-class
- cxx: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 qt:qmethod (name)
- "Equivalent of the METHOD(a) CPP macro."
- (assert (not (munged-name-p name)))
- (format nil "0~A" name))
-
-(defun qt:qslot (name)
- "Equivalent of the SLOT(a) CPP macro."
- (assert (not (munged-name-p name)))
- (format nil "1~A" name))
-
-(defun qt: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.gui/src/signal-slot/signal.lisp new-qt.gui/src/signal-slot/signal.lisp
--- old-qt.gui/src/signal-slot/signal.lisp 2014-10-30 07:42:32.000000000 +0100
+++ new-qt.gui/src/signal-slot/signal.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,122 +0,0 @@
-(in-package :cl-smoke.qt-impl)
-
-(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 (qt:object)
- ((argument-types :accessor argument-types
- :initarg :argument-types
- :documentation "List of the argument types"))
- (:documentation "Qt Signal object.")
- (:metaclass cxx:class))
-
-#+cmu (defmethod closer-mop:validate-superclass ((class closer-mop:funcallable-standard-class)
- (superclass standard-class))
- t)
-
-(defclass qsignal (closer-mop:funcallable-standard-object qsignal-mixin)
- ()
- (: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 qt: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."
- ;; For efficiency assume that SLOT is normalized and fallback to
- ;; normalizing when not. (Just like Qt does.)
- (let ((id (cxx:index-of-slot (cxx:meta-object receiver)
- slot)))
- (when (< id 0)
- (setf id (cxx:index-of-slot (cxx:meta-object receiver)
- (qt: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 make-lisp-object (object)
- (smoke:make-cleanup-pointer (make-cxx-lisp-object object)
- #'qt-smoke-free-lisp-object))
-
-
-(defun convert-arguments (arguments types)
- "Returns a list of ARGUMENTS converted to TYPES."
- (mapcar #'(lambda (argument type)
- (if (typep type 'smoke::smoke-type)
- (smoke::convert-argument argument type)
- (progn (assert (typep argument type)
- ()
- "The argument ~S is not of type ~S.")
- (make-lisp-object argument))))
- arguments types))
-
-(defun emit (qsignal &rest arguments)
- "Emits the signal QSIGNAL."
- (activate qsignal (id qsignal) (argument-types qsignal) arguments))
-
-(defun activate (object id types arguments)
- ;;; 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 (convert-arguments arguments types)
- types)
- (with-foreign-object (args :pointer (1+ (length arguments)))
- (loop for i from 1 to (smoke::size stack)
- for type in types
- 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 (smoke::call-stack-pointer stack)
- 'smoke::smoke-stack-item
- i)
- 'smoke::smoke-stack-item 'smoke::voidp)
- (foreign-slot-pointer
- (mem-aref (smoke::call-stack-pointer stack)
- 'smoke::smoke-stack-item
- i)
- 'smoke::smoke-stack-item 'smoke::voidp))))
- (setf (mem-aref args :pointer 0)
- (null-pointer))
- (qt:meta-object.activate object id args))))
-
-(defmethod qt:disconnect-all ((qsignal qsignal))
- (unless (disconnect-id (signal-object qsignal)
- (id (signal-object qsignal))
- 0
- 0)))
diff -rN -u old-qt.gui/src/signal-slot/slot.lisp new-qt.gui/src/signal-slot/slot.lisp
--- old-qt.gui/src/signal-slot/slot.lisp 2014-10-30 07:42:32.000000000 +0100
+++ new-qt.gui/src/signal-slot/slot.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,63 +0,0 @@
-(in-package :cl-smoke.qt-impl)
-
-(defclass qslot (qt: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 slot function specified")
- :documentation "The function called when the slot is invoked."))
- (:metaclass cxx:class)
- (:documentation "A Qt slot that calls its associated function"))
-
-(defun qt: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 "The sender of the signal.")
-(defparameter *this* nil "The slot that is invoked.")
-(defmacro qt:sender ()
- "Returns the sender that invoked the slot."
- `*sender*)
-
-(defmethod cxx:qt-metacall ((slot qslot) call id arguments)
- "Invoke the slots function when it is called. The return value
-of the invoked slot function is ignored."
- (declare (ignore id))
- (let ((id (call-next-method)))
- (if (< id 0)
- id
- (if (enum= call qt:meta-object.+invoke-meta-method+)
- (progn
- (ccase id
- (0 (let ((*sender* (cxx:sender slot))
- (*this* slot))
- (with-simple-restart
- (continue "Skip the function ~A of slot ~A."
- (slot-function slot) slot)
- (apply (slot-function slot)
- (arguments-to-lisp arguments (arguments slot)))))))
- (1- id))
- id))))
-
-(defun find-signal-id (sender signal)
- "Returns the ID of SIGNAL from SENDER."
- ;; For efficiency assume that SIGNAL is normalized and fallback to
- ;; normalizing when not. (Just like Qt does.)
- (let ((id (cxx:index-of-signal (cxx:meta-object sender)
- signal)))
- (when (< id 0)
- (setf id (cxx:index-of-signal (cxx:meta-object sender)
- (qt:meta-object.normalized-signature signal))))
- (when (< id 0)
- (error "No signal ~S for class ~S."
- signal (class-of sender)))
- id))
-
diff -rN -u old-qt.gui/src/signal-slot/translate.lisp new-qt.gui/src/signal-slot/translate.lisp
--- old-qt.gui/src/signal-slot/translate.lisp 2014-10-30 07:42:32.000000000 +0100
+++ new-qt.gui/src/signal-slot/translate.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,111 +0,0 @@
-(in-package :cl-smoke.qt-impl)
-
-(defun find-type (name &optional start end)
- (smoke::make-smoke-type *smoke-module* (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-type
- (pointer-to-lisp (mem-ref argument :pointer)
- (first types)))
-
- (t
- (translate-cxx-lisp-object
- (mem-ref argument :pointer)))))))))
-
-(defun disown-object (object)
- (tg:cancel-finalization object)
- (unless (smoke::virtual-destructor-p (class-of object))
- (smoke::remove-object (pointer object)))
- object)
-
-(defun pointer-to-lisp (pointer type)
- "Returns the lisp value or object at POINTER of type TYPE."
- (if (smoke::class-p type)
- (if (smoke::pointer-p type)
- (smoke::object-to-lisp (mem-ref pointer :pointer) type)
- ;; By-value means that the object at POINTER is allocated by
- ;; the C++ signal code and has dynamic extend in the
- ;; slot. The C++ signal code frees the object when the slot
- ;; returns.
- (disown-object (smoke::object-to-lisp pointer type)))
- (ecase (smoke::type-id type)
- (0 (if-let ((translation (gethash (name type) smoke::*to-lisp-translations*)))
- ;; Do not free stack allocated stuff (e.g.: QString); that is the callers
- ;; responisbility.
- (funcall (car translation) pointer)
- (error "Do not know how to convert the type ~A to Lisp." type)))
- (1 (mem-ref pointer 'cxx-bool))
- (2 (code-char (mem-ref pointer :char)))
- (3 (code-char (mem-ref pointer :unsigned-char)))
- (4 (code-char (mem-ref pointer :short)))
- (5 (code-char (mem-ref pointer :unsigned-short)))
- (6 (mem-ref pointer :int))
- (7 (mem-ref pointer :unsigned-int))
- (8 (mem-ref pointer :long))
- (9 (mem-ref pointer :unsigned-long))
- (10 (mem-ref pointer :float))
- (11 (mem-ref pointer :double))
- (12 (make-instance 'enum
- :value (mem-ref pointer :long)
- :type type)))))
-
-
-(defun arguments-to-lisp (arguments types)
- "Returns ARGUMENTS for a slot invocation as lisp objects."
- (arguments-to-lisp2
- (inc-pointer arguments ;; index 0 is for the return value
- (foreign-type-size :pointer))
- types ()))
-
-
-(defun get-type (smoke-type)
- "Returns the QMetaType ID for SMOKE-TYPE."
- (typecase smoke-type
- (smoke::smoke-standard-object
- (if (smoke::pointer-p smoke-type)
- (error "Not implemented: pointer type.") ;;qmetatype.+voidstar+
- (let ((type (qt: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)
- "Returns a newly allocated array of QMetaType IDs of 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))