1 (in-package :cl-smoke.qt.core)
3 (defmethod print-object ((variant qt:variant) stream)
4 "Print the type and value of the variant."
5 (if (or (not (slot-boundp variant 'pointer))
6 (null-pointer-p (pointer variant)))
8 (print-unreadable-object (variant stream :type t :identity t)
9 (format stream "~A~@[ ~S~]"
10 (cxx:type-name variant)
11 (handler-case (qt:from-variant variant)
14 (defun qt:make-variant (&optional (value nil value-p))
15 "Returns a new VARIANT containing a C++ version of VALUE
16 or an empty variant when VALUE is not specified."
18 (make-instance 'qt:variant :arg0 value)
19 (make-instance 'qt:variant)))
21 (defun qt:make-char (character)
22 "Returns a char for a lisp CHARACTER."
23 (let ((octets (babel:string-to-octets (string character))))
25 (1 (make-instance 'qt:char :arg0 (aref octets 0)))
26 (2 (make-instance 'qt:char :args (list (aref octets 0)
28 (t (error "qt:char requires the character ~A to be encoded
29 in one or two octets, but it is using ~A."
30 character (length octets))))))
32 (defun surrogate-p (char)
33 (or (cxx:is-high-surrogate char)
34 (cxx:is-low-surrogate char)))
36 (defun qt:from-char (char)
37 "Returns the Lisp character represented by CHAR."
38 (assert (not (surrogate-p char))
40 "The char ~A is part of a surrogate.")
42 (babel:octets-to-string (make-array 2 :element-type '(unsigned-byte 8)
45 (char-code (cxx:cell char))
46 (char-code (cxx:row char)))))
49 (defmethod print-object ((char qt:char) stream)
50 (if (or (null-pointer-p (pointer char))
53 (print-unreadable-object (char stream :type t)
54 (princ (qt:from-char char) stream))))
57 ;; FIXME include in MAKE-VARIANT? how??
58 (defun qt:make-lisp-variant (value)
59 "Returns a new VARIANT that wraps VALUE.
61 The variant contains the actual Lisp object VALUE
62 and not its C++ value like in MAKE-VARIANT."
63 (let ((object (make-cxx-lisp-object value)))
65 (make-instance 'qt:variant :args (list *cxx-lisp-object-metatype*
67 (free-cxx-lisp-object object))))
69 (defcfun cl-smoke-lisp-object-value :pointer
72 (defun qt:variant-boundp (variant)
73 "Returns true when VARIANT is valid (has a value) and false otherwise."
74 (cxx:is-valid variant))
76 (defun copy-object-from-pointer (class pointer)
77 (make-instance class :arg0 (make-instance class :pointer pointer)))
80 ;; *cxx-lisp-object-metatype* can change when loading an image
83 ((variant-conversions ((variant) &body types)
84 (let* ((special-types '(long-long ulong-long map list hash))
86 (append '(63) ;; ColorGroup
90 (intern (format nil "VARIANT.+~A+" s)
93 (qt-types (loop for i from 1 to (value qt:variant.+user-type+)
94 when (and (qt:variant.type-to-name i)
95 ;; type-to-name returns longlong but
97 (not (member i exclude-types)))
99 (smoke::lispify (qt:variant.type-to-name i)
101 `(ecase (cxx:user-type ,variant)
102 ,@(loop for type in (append special-types
103 (remove nil qt-types))
105 `(,(value (symbol-value
107 (find-package :cl-smoke.qt)))
108 (symbolicate 'variant.+ type '+))))
109 ,(if (fboundp (intern (format nil "TO-~A" type) :cxx))
110 `(,(intern (format nil "TO-~A" type) :cxx) ,variant)
111 `(copy-object-from-pointer
112 ;; intern since these types are in
113 ;; qt.gui not qt.core
114 (intern ,(symbol-name type) :qt)
115 (cxx:const-data ,variant)))))
116 ,@(loop for type in types
118 `(,(eval (first type))
120 (defun qt:from-variant (variant)
121 "Returns the value of VARIANT."
122 (variant-conversions (variant)
123 ((value qt:variant.+invalid+)
124 (cerror "Return (VALUES)" "Type of variant ~A is invalid." variant)
126 (*cxx-lisp-object-metatype*
127 (let* ((lisp-object (cl-smoke-lisp-object-value (pointer variant)))
129 (setf value (translate-cxx-lisp-object lisp-object))
130 (free-cxx-lisp-object lisp-object)
133 (defmethod qt:value ((variant qt:variant))
134 "Returns the value of VARIANT."
135 (qt:from-variant variant))
137 (defmethod (setf qt:value) (new-value (variant qt:variant))
138 (cxx:operator= variant (qt:make-variant new-value))