repos
/
qt.core
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Account for possible lisp-object metatype id change when loading an image.
Annotate for file /src/variant.lisp
2010-01-10 tobias
1
(in-package :cl-smoke.qt.core)
2009-04-05 tobias
2
2009-06-11 tobias
3
(defmethod print-object ((variant qt:variant) stream)
2009-04-05 tobias
4
"Print the type and value of the variant."
2009-05-27 tobias
5
(if (or (not (slot-boundp variant 'pointer))
17:18:41 '
6
(null-pointer-p (pointer variant)))
2009-04-05 tobias
7
(call-next-method)
2009-05-24 tobias
8
(print-unreadable-object (variant stream :type t :identity t)
2009-04-05 tobias
9
(format stream "~A~@[ ~S~]"
17:56:16 '
10
(cxx:type-name variant)
2009-06-11 tobias
11
(handler-case (qt:from-variant variant)
2009-04-05 tobias
12
(error () nil))))))
17:56:16 '
13
2009-06-11 tobias
14
(defun qt:make-variant (&optional (value nil value-p))
2009-05-11 tobias
15
"Returns a new VARIANT containing a C++ version of VALUE
11:09:54 '
16
or an empty variant when VALUE is not specified."
'
17
(if value-p
2009-07-22 tobias
18
(make-instance 'qt:variant :arg0 value)
2009-06-11 tobias
19
(make-instance 'qt:variant)))
2009-05-11 tobias
20
2009-06-11 tobias
21
(defun qt:make-char (character)
2009-05-11 tobias
22
"Returns a char for a lisp CHARACTER."
2009-05-11 tobias
23
(let ((octets (babel:string-to-octets (string character))))
11:09:54 '
24
(case (length octets)
2009-07-22 tobias
25
(1 (make-instance 'qt:char :arg0 (aref octets 0)))
2009-06-11 tobias
26
(2 (make-instance 'qt:char :args (list (aref octets 0)
2009-07-22 tobias
27
(aref octets 1))))
2009-05-11 tobias
28
(t (error "qt:char requires the character ~A to be encoded
11:09:54 '
29
in one or two octets, but it is using ~A."
'
30
character (length octets))))))
'
31
'
32
(defun surrogate-p (char)
'
33
(or (cxx:is-high-surrogate char)
'
34
(cxx:is-low-surrogate char)))
'
35
2009-06-11 tobias
36
(defun qt:from-char (char)
2009-07-22 tobias
37
"Returns the Lisp character represented by CHAR."
2009-05-11 tobias
38
(assert (not (surrogate-p char))
11:09:54 '
39
(char)
'
40
"The char ~A is part of a surrogate.")
'
41
(char
'
42
(babel:octets-to-string (make-array 2 :element-type '(unsigned-byte 8)
'
43
:initial-contents
'
44
(list
'
45
(char-code (cxx:cell char))
'
46
(char-code (cxx:row char)))))
'
47
0))
'
48
2009-06-11 tobias
49
(defmethod print-object ((char qt:char) stream)
2009-05-11 tobias
50
(if (or (null-pointer-p (pointer char))
11:09:54 '
51
(surrogate-p char))
'
52
(call-next-method)
'
53
(print-unreadable-object (char stream :type t)
2009-06-11 tobias
54
(princ (qt:from-char char) stream))))
2009-05-11 tobias
55
2009-04-05 tobias
56
2009-07-22 tobias
57
;; FIXME include in MAKE-VARIANT? how??
2009-06-11 tobias
58
(defun qt:make-lisp-variant (value)
2009-05-14 tobias
59
"Returns a new VARIANT that wraps VALUE.
12:11:11 '
60
2009-07-22 tobias
61
The variant contains the actual Lisp object VALUE
2009-05-14 tobias
62
and not its C++ value like in MAKE-VARIANT."
2009-04-05 tobias
63
(let ((object (make-cxx-lisp-object value)))
17:56:16 '
64
(unwind-protect
2009-06-11 tobias
65
(make-instance 'qt:variant :args (list *cxx-lisp-object-metatype*
14:59:48 '
66
object))
2009-04-05 tobias
67
(free-cxx-lisp-object object))))
17:56:16 '
68
2010-01-10 tobias
69
(defcfun cl-smoke-lisp-object-value :pointer
2009-04-05 tobias
70
(variant :pointer))
17:56:16 '
71
2009-06-11 tobias
72
(defun qt:variant-boundp (variant)
2009-04-05 tobias
73
"Returns true when VARIANT is valid (has a value) and false otherwise."
17:56:16 '
74
(cxx:is-valid variant))
'
75
2010-02-20 tobias
76
(defun copy-object-from-pointer (class pointer)
21:00:30 '
77
(make-instance class :arg0 (make-instance class :pointer pointer)))
2009-06-10 tobias
78
2010-04-03 tobias
79
(eval-startup ()
12:34:21 '
80
;; *cxx-lisp-object-metatype* can change when loading an image
'
81
(eval '
'
82
(macrolet
'
83
((variant-conversions ((variant) &body types)
'
84
(let* ((special-types '(long-long ulong-long map list hash))
'
85
(exclude-types
'
86
(append '(63) ;; ColorGroup
'
87
(mapcar #'(lambda (s)
'
88
(value
'
89
(symbol-value
'
90
(intern (format nil "VARIANT.+~A+" s)
'
91
:qt))))
'
92
special-types)))
'
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
'
96
;; should be LongLong
'
97
(not (member i exclude-types)))
'
98
collect
'
99
(smoke::lispify (qt:variant.type-to-name i)
'
100
:qt))))
'
101
`(ecase (cxx:user-type ,variant)
'
102
,@(loop for type in (append special-types
'
103
(remove nil qt-types))
'
104
collect
'
105
`(,(value (symbol-value
'
106
(let ((*package*
'
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
'
117
collect
'
118
`(,(eval (first type))
'
119
,@(rest 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)
'
125
(values))
'
126
(*cxx-lisp-object-metatype*
'
127
(let* ((lisp-object (cl-smoke-lisp-object-value (pointer variant)))
'
128
(value))
'
129
(setf value (translate-cxx-lisp-object lisp-object))
'
130
(free-cxx-lisp-object lisp-object)
'
131
value)))))))
2009-06-10 tobias
132
2009-06-11 tobias
133
(defmethod qt:value ((variant qt:variant))
2009-05-11 tobias
134
"Returns the value of VARIANT."
2009-06-11 tobias
135
(qt:from-variant variant))
2009-05-11 tobias
136
2009-06-11 tobias
137
(defmethod (setf qt:value) (new-value (variant qt:variant))
14:59:48 '
138
(cxx:operator= variant (qt:make-variant new-value))
2009-05-11 tobias
139
new-value)