darcs - qt.core

1 (in-package :cl-smoke.qt.core)

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.

11 See:

12 http://www.sbcl.org/manual/Metaobject-Protocol.html#index-validate_002dsuperclass-164"))

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))

21 #+cmu (defmethod closer-mop:validate-superclass ((class closer-mop:funcallable-standard-class)

22 (superclass standard-class))

23 t)

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."))

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)))

39 (defmethod id ((qsignal signal-object))

40 (cxx:method-count (cxx:meta-object qsignal)))

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)

51 (apply #'emit (signal-object object) args))))

53 (defun find-slot-id (receiver slot)

54 "Returns the ID of RECEIVER from SLOT."

55 ;; For efficiency assume that SLOT is normalized and fallback to

56 ;; normalizing when not. (Just like Qt does.)

57 (let ((id (cxx:index-of-slot (cxx:meta-object receiver)

58 slot)))

59 (when (< id 0)

60 (setf id (cxx:index-of-slot (cxx:meta-object receiver)

61 (qt:meta-object.normalized-signature slot))))

62 (when (< id 0)

63 (error "No slot ~S for class ~S.

64 The valid slots are: ~{~<~%~T~0,75:;~A ~>~}"

65 slot (class-of receiver)

66 (class-slots (class-of receiver))))

67 id))

70 (defun make-lisp-object (object)

71 (make-cleanup-pointer (make-cxx-lisp-object object)

72 #'cl-smoke-free-lisp-object))

75 (defun convert-arguments (arguments types)

76 "Returns a list of ARGUMENTS converted to TYPES."

77 (mapcar #'(lambda (argument type)

78 (if (typep type 'smoke-type)

79 (smoke:convert-argument argument type)

80 (progn (assert (typep argument type)

81 ()

82 "The argument ~S is not of type ~S."

83 argument type)

84 (make-lisp-object argument))))

85 arguments types))

87 (defun emit (qsignal &rest arguments)

88 "Emits the signal QSIGNAL."

89 (activate qsignal (id qsignal) (argument-types qsignal) arguments))

91 (defun activate (object id types arguments)

92 ;;; The first element of args would be used for the return value by

93 ;;; QMetaObject::invokeMethod(), but for signal-slot connection it is

94 ;;; ignored.

95 (smoke::with-stack (stack (convert-arguments arguments types)

96 types)

97 (with-foreign-object (args :pointer (1+ (length arguments)))

98 (loop for i from 1 to (smoke:size stack)

99 for type in types

100 do

101 (setf (mem-aref args :pointer i)

102 (if (or (not (typep type (find-class 'smoke-type)))

103 (= 0 (type-id type))

104 (= 13 (type-id type)))

105 (foreign-slot-value

106 (mem-aref (smoke::call-stack-pointer stack)

107 'smoke::smoke-stack-item

108 i)

109 'smoke::smoke-stack-item 'smoke::voidp)

110 (foreign-slot-pointer

111 (mem-aref (smoke::call-stack-pointer stack)

112 'smoke::smoke-stack-item

113 i)

114 'smoke::smoke-stack-item 'smoke::voidp))))

115 (setf (mem-aref args :pointer 0)

116 (null-pointer))

117 (qt:meta-object.activate object id args))))

118

119 (defmethod qt:disconnect-all ((qsignal qsignal))

120 (unless (disconnect-id (signal-object qsignal)

121 (id (signal-object qsignal))

122 0

123 0)))