Sun Jan 10 09:52:49 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Split up in qt.gui & cleanup name prefix.

--- old-qt.gui/src/signal-slot/signal.lisp 2014-10-30 07:42:40.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)))