1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2005 Espen S. Johnsen <espen@users.sf.net>
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 ;; $Id: genums.lisp,v 1.14 2005-04-24 13:24:41 espen Exp $
27 ;;;; Generic enum type
29 (defun %map-enum (mappings op)
31 as value = 0 then (1+ value)
32 for mapping in mappings
33 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
34 (unless (atom mapping)
35 (setq value (second mapping)))
37 (:symbol-int `(,symbol ,value))
38 (:int-symbol `(,value ,symbol))
39 (:int-quoted-symbol `(,value ',symbol))
42 (deftype enum (&rest args)
43 `(member ,@(%map-enum args :symbols)))
45 (defmethod alien-type ((type (eql 'enum)) &rest args)
46 (declare (ignore type args))
49 (defmethod size-of ((type (eql 'enum)) &rest args)
50 (declare (ignore type args))
53 (defmethod to-alien-form (form (type (eql 'enum)) &rest args)
54 (declare (ignore type))
56 ,@(%map-enum args :symbol-int)
57 (t (error 'type-error :datum ,form :expected-type '(enum ,@args)))))
60 (defmethod from-alien-form (form (type (eql 'enum)) &rest args)
61 (declare (ignore type))
63 ,@(%map-enum args :int-quoted-symbol)))
65 (defmethod to-alien-function ((type (eql 'enum)) &rest args)
66 (declare (ignore type))
67 (let ((mappings (%map-enum args :symbol-int)))
70 (second (assoc enum mappings))
71 (error 'type-error :datum enum :expected-type (cons 'enum args))))))
73 (defmethod from-alien-function ((type (eql 'enum)) &rest args)
74 (declare (ignore type))
75 (let ((mappings (%map-enum args :int-symbol)))
77 (second (assoc int mappings)))))
79 (defmethod writer-function ((type (eql 'enum)) &rest args)
80 (declare (ignore type))
81 (let ((writer (writer-function 'signed))
82 (function (apply #'to-alien-function 'enum args)))
83 #'(lambda (enum location &optional (offset 0))
84 (funcall writer (funcall function enum) location offset))))
86 (defmethod reader-function ((type (eql 'enum)) &rest args)
87 (declare (ignore type))
88 (let ((reader (reader-function 'signed))
89 (function (apply #'from-alien-function 'enum args)))
90 #'(lambda (location &optional (offset 0))
91 (funcall function (funcall reader location offset)))))
93 (defun enum-int (enum type)
94 (funcall (to-alien-function type) enum))
96 (defun int-enum (int type)
97 (funcall (from-alien-function type) int))
99 (defun enum-mapping (type)
100 (rest (type-expand-to 'enum type)))
103 ;;;; Named enum types
105 (defmacro define-enum-type (name &rest args)
106 (let ((enum-int (intern (format nil "~A-TO-INT" name)))
107 (int-enum (intern (format nil "INT-TO-~A" name))))
109 (deftype ,name () '(enum ,@args))
110 (defun ,enum-int (enum)
112 ,@(%map-enum args :symbol-int)
113 (t (error 'type-error :datum enum :expected-type ',name))))
114 (defun ,int-enum (value)
116 ,@(%map-enum args :int-quoted-symbol)))
117 (defmethod to-alien-form (form (type (eql ',name)) &rest args)
118 (declare (ignore type args))
119 (list ',enum-int form))
120 (defmethod from-alien-form (form (type (eql ',name)) &rest args)
121 (declare (ignore type args))
122 (list ',int-enum form))
123 (defmethod to-alien-function ((type (eql ',name)) &rest args)
124 (declare (ignore type args))
126 (defmethod from-alien-function ((type (eql ',name)) &rest args)
127 (declare (ignore type args))
129 (defmethod writer-function ((type (eql ',name)) &rest args)
130 (declare (ignore type args))
131 (let ((writer (writer-function 'signed)))
132 #'(lambda (enum location &optional (offset 0))
133 (funcall writer (,enum-int enum) location offset))))
134 (defmethod reader-function ((type (eql ',name)) &rest args)
135 (declare (ignore type args))
136 (let ((reader (reader-function 'signed)))
137 #'(lambda (location &optional (offset 0))
138 (,int-enum (funcall reader location offset))))))))
141 ;;;; Generic flags type
143 (defun %map-flags (mappings op)
145 as value = 1 then (ash value 1)
146 for mapping in mappings
147 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
148 (unless (atom mapping)
149 (setq value (second mapping)))
151 (:symbol-int `(,symbol ,value))
152 (:int-symbol `(,value ,symbol))
153 (:symbols symbol)))))
155 (deftype flags (&rest args)
156 `(or (member ,@(%map-flags args :symbols)) list))
158 (defmethod alien-type ((type (eql 'flags)) &rest args)
159 (declare (ignore type args))
160 (alien-type 'unsigned))
162 (defmethod size-of ((type (eql 'flags)) &rest args)
163 (declare (ignore type args))
166 (defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
167 `(reduce #'logior (mklist ,flags)
168 :key #'(lambda (flag)
170 ,@(%map-flags args :symbol-int)
171 (t (error 'type-error :datum ,flags
172 :expected-type '(,type ,@args)))))))
174 (defmethod from-alien-form (value (type (eql 'flags)) &rest args)
175 (declare (ignore type))
177 for (int symbol) in ',(%map-flags args :int-symbol)
178 when (= (logand ,value int) int)
181 (defmethod to-alien-function ((type (eql 'flags)) &rest args)
182 (declare (ignore type))
183 (let ((mappings (%map-flags args :symbol-int)))
185 (reduce #'logior (mklist flags)
186 :key #'(lambda (flag)
188 (second (assoc flag mappings))
189 (error 'type-error :datum flags
190 :expected-type (cons 'flags args))))))))
192 (defmethod from-alien-function ((type (eql 'flags)) &rest args)
193 (declare (ignore type))
194 (let ((mappings (%map-flags args :int-symbol)))
197 for (int symbol) in mappings
198 when (= (logand value int) int)
201 (defmethod writer-function ((type (eql 'flags)) &rest args)
202 (declare (ignore type))
203 (let ((writer (writer-function 'unsigned))
204 (function (apply #'to-alien-function 'flags args)))
205 #'(lambda (flags location &optional (offset 0))
206 (funcall writer (funcall function flags) location offset))))
208 (defmethod reader-function ((type (eql 'flags)) &rest args)
209 (declare (ignore type))
210 (let ((reader (reader-function 'unsigned))
211 (function (apply #'from-alien-function 'flags args)))
212 #'(lambda (location &optional (offset 0))
213 (funcall function (funcall reader location offset)))))
216 ;;;; Named flags types
218 (defmacro define-flags-type (name &rest args)
219 (let ((flags-int (intern (format nil "~A-TO-INT" name)))
220 (int-flags (intern (format nil "INT-TO-~A" name)))
221 (satisfies (intern (format nil "~A-P" name))))
223 (deftype ,name () '(satisfies ,satisfies))
224 (defun ,satisfies (object)
226 (find ob ',(%map-flags args :symbols))))
228 (symbol (valid-p object))
229 (list (every #'valid-p object)))))
230 (defun ,flags-int (flags)
231 (reduce #'logior (mklist flags)
232 :key #'(lambda (flag)
234 ,@(%map-flags args :symbol-int)
235 (t (error 'type-error :datum flags
236 :expected-type ',name))))))
237 (defun ,int-flags (value)
239 for (int symbol) in ',(%map-flags args :int-symbol)
240 when(= (logand value int) int)
242 (defmethod alien-type ((type (eql ',name)) &rest args)
243 (declare (ignore type args))
245 (defmethod size-of ((type (eql ',name)) &rest args)
246 (declare (ignore type args))
248 (defmethod to-alien-form (form (type (eql ',name)) &rest args)
249 (declare (ignore type args))
250 (list ',flags-int form))
251 (defmethod from-alien-form (form (type (eql ',name)) &rest args)
252 (declare (ignore type args))
253 (list ',int-flags form))
254 (defmethod to-alien-function ((type (eql ',name)) &rest args)
255 (declare (ignore type args))
257 (defmethod from-alien-function ((type (eql ',name)) &rest args)
258 (declare (ignore type args))
260 (defmethod writer-function ((type (eql ',name)) &rest args)
261 (declare (ignore type args))
262 (let ((writer (writer-function 'signed)))
263 #'(lambda (flags location &optional (offset 0))
264 (funcall writer (,flags-int flags) location offset))))
265 (defmethod reader-function ((type (eql ',name)) &rest args)
266 (declare (ignore type args))
267 (let ((reader (reader-function 'signed)))
268 #'(lambda (location &optional (offset 0))
269 (,int-flags (funcall reader location offset))))))))
273 ;;;; Type definition by introspection
275 (defun %query-enum-or-flags-values (query-function class type)
276 (multiple-value-bind (sap length)
277 (funcall query-function (type-class-ref type))
279 (size (proxy-instance-size (find-class class)))
280 (proxy (make-instance class :location sap)))
282 (with-slots (location nickname value) proxy
284 (setq sap (sap+ sap size))
287 (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
293 (defclass %enum-value (struct)
294 ((value :allocation :alien :type int)
295 (name :allocation :alien :type string)
296 (nickname :allocation :alien :type string))
297 (:metaclass static-struct-class))
299 (defbinding %enum-class-values () pointer
301 (n-values unsigned-int :out))
303 (defun query-enum-values (type)
304 (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
307 (defclass %flags-value (struct)
308 ((value :allocation :alien :type unsigned-int)
309 (name :allocation :alien :type string)
310 (nickname :allocation :alien :type string))
311 (:metaclass static-struct-class))
313 (defbinding %flags-class-values () pointer
315 (n-values unsigned-int :out))
317 (defun query-flags-values (type)
318 (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
321 (defun expand-enum-type (type-number forward-p options)
322 (declare (ignore forward-p))
323 (let* ((super (supertype type-number))
324 (type (type-from-number type-number))
325 (mappings (getf options :mappings))
331 (assoc (first mapping) mappings)
332 (rassoc (cdr mapping) mappings :test #'equal)))
334 (query-enum-values type-number)
335 (query-flags-values type-number)))
337 #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
339 (register-type ',type ',(find-type-init-function type-number))
341 (enum `(define-enum-type ,type ,@expanded-mappings))
342 (flags `(define-flags-type ,type ,@expanded-mappings))))))
345 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
346 (register-derivable-type 'flags "GFlags" 'expand-enum-type)