darcs - qt.core

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

3 (defun find-type (smoke-module name &optional start end)

4 (let ((type (make-smoke-type smoke-module (subseq name start end))))

5 (assert (not (zerop (id type)))

6 ()

7 "No type named ~S found in ~A."

8 (subseq name start end) smoke-module)

9 type))

11 (defun method-arguments-type (object index)

12 "Returns a type name list for the arguments of method INDEX of OBJECTs metaobject."

13 (let* ((metaobject (cxx:meta-object object))

14 (signature (cxx:signature (cxx:method metaobject index)))

15 (arguments (subseq signature (1+ (position #\( signature))

16 (position #\) signature :from-end t)))

17 (argument-types ())

18 (last-pos (length arguments))

19 (smoke-module (smoke (class-of object))))

20 (loop as pos = (position #\, arguments :from-end t :end last-pos)

21 while pos

22 do

23 (push (find-type smoke-module arguments (1+ pos) last-pos) argument-types)

24 (setf last-pos pos))

25 (when (> last-pos 0)

26 (push (find-type smoke-module arguments 0 last-pos) argument-types))))

29 (defun arguments-to-lisp2 (argument types values)

30 (if (null types)

31 values

32 (arguments-to-lisp2 (inc-pointer argument (foreign-type-size :pointer))

33 (rest types)

34 (nconc values

35 (list

36 (typecase (first types)

37 (smoke-type

38 (pointer-to-lisp (mem-ref argument :pointer)

39 (first types)))

41 (t

42 (translate-cxx-lisp-object

43 (mem-ref argument :pointer)))))))))

45 (defun disown-object (object)

46 (tg:cancel-finalization object)

47 (unless (virtual-destructor-p (class-of object))

48 (remove-object (pointer object)))

49 object)

51 (defun pointer-to-lisp (pointer type)

52 "Returns the lisp value or object at POINTER of type TYPE."

53 (if (class-p type)

54 (if (pointer-p type)

55 (object-to-lisp (mem-ref pointer :pointer) type)

56 ;; By-value means that the object at POINTER is allocated by

57 ;; the C++ signal code and has dynamic extend in the

58 ;; slot. The C++ signal code frees the object when the slot

59 ;; returns.

60 (disown-object (object-to-lisp pointer type)))

61 (ecase (type-id type)

62 (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))

63 ;; Do not free stack allocated stuff (e.g.: QString); that is the callers

64 ;; responisbility.

65 (funcall (car translation) pointer)

66 (error "Do not know how to convert the type ~A to Lisp." type)))

67 (1 (mem-ref pointer 'cxx-bool))

68 (2 (code-char (mem-ref pointer :char)))

69 (3 (code-char (mem-ref pointer :unsigned-char)))

70 (4 (code-char (mem-ref pointer :short)))

71 (5 (code-char (mem-ref pointer :unsigned-short)))

72 (6 (mem-ref pointer :int))

73 (7 (mem-ref pointer :unsigned-int))

74 (8 (mem-ref pointer :long))

75 (9 (mem-ref pointer :unsigned-long))

76 (10 (mem-ref pointer :float))

77 (11 (mem-ref pointer :double))

78 (12 (make-instance 'enum

79 :value (mem-ref pointer :long)

80 :type type)))))

83 (defun arguments-to-lisp (arguments types)

84 "Returns ARGUMENTS for a slot invocation as lisp objects."

85 (arguments-to-lisp2

86 (inc-pointer arguments ;; index 0 is for the return value

87 (foreign-type-size :pointer))

88 types ()))

91 (defun get-type (smoke-type)

92 "Returns the QMetaType ID for SMOKE-TYPE."

93 (typecase smoke-type

94 (smoke-standard-object

95 (if (pointer-p smoke-type)

96 (error "Not implemented: pointer type.") ;;qmetatype.+voidstar+

97 (let ((type (qt:meta-type.type (name smoke-type))))

98 (assert (/= 0 type)

99 (type)

100 "The type ~S has no QMetaType."

101 (name smoke-type))

102 type)))

103 (t

104 *cxx-lisp-object-metatype*)))

105

106

107 (defun types (smoke-types)

108 "Returns a newly allocated array of QMetaType IDs of SMOKE-TYPES."

109 ;; FIXME free TYPES on error.

110 (let ((types (cffi:foreign-alloc :int :count (1+ (length smoke-types))))

111 (index 0))

112 (dolist (type smoke-types)

113 (setf (cffi:mem-aref types :int index)

114 (get-type type))

115 (incf index))

116 (setf (cffi:mem-aref types :int index)

117 0)

118 types))