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.17 2006/02/06 18:12:19 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) weak-p)
91 (declare (ignore weak-p))
92 (funcall function (funcall reader location offset)))))
94 (defun enum-int (enum type)
95 (funcall (to-alien-function type) enum))
97 (defun int-enum (int type)
98 (funcall (from-alien-function type) int))
100 (defun enum-mapping (type)
101 (rest (type-expand-to 'enum type)))
104 ;;;; Named enum types
106 (defmacro define-enum-type (name &rest args)
107 (let ((enum-int (intern (format nil "~A-TO-INT" name)))
108 (int-enum (intern (format nil "INT-TO-~A" name))))
110 (deftype ,name () '(enum ,@args))
111 (defun ,enum-int (enum)
113 ,@(%map-enum args :symbol-int)
114 (t (error 'type-error :datum enum :expected-type ',name))))
115 (defun ,int-enum (value)
117 ,@(%map-enum args :int-quoted-symbol)))
118 (defmethod to-alien-form (form (type (eql ',name)) &rest args)
119 (declare (ignore type args))
120 (list ',enum-int form))
121 (defmethod from-alien-form (form (type (eql ',name)) &rest args)
122 (declare (ignore type args))
123 (list ',int-enum form))
124 (defmethod to-alien-function ((type (eql ',name)) &rest args)
125 (declare (ignore type args))
127 (defmethod from-alien-function ((type (eql ',name)) &rest args)
128 (declare (ignore type args))
130 (defmethod writer-function ((type (eql ',name)) &rest args)
131 (declare (ignore type args))
132 (let ((writer (writer-function 'signed)))
133 #'(lambda (enum location &optional (offset 0))
134 (funcall writer (,enum-int enum) location offset))))
135 (defmethod reader-function ((type (eql ',name)) &rest args)
136 (declare (ignore type args))
137 (let ((reader (reader-function 'signed)))
138 #'(lambda (location &optional (offset 0) weak-p)
139 (declare (ignore weak-p))
140 (,int-enum (funcall reader location offset))))))))
143 ;;;; Generic flags type
145 (defun %map-flags (mappings op)
147 as value = 1 then (ash value 1)
148 for mapping in mappings
149 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
150 (unless (atom mapping)
151 (setq value (second mapping)))
153 (:symbol-int `(,symbol ,value))
154 (:int-symbol `(,value ,symbol))
155 (:symbols symbol)))))
157 (deftype flags (&rest args)
158 `(or (member ,@(%map-flags args :symbols)) list))
160 (defmethod alien-type ((type (eql 'flags)) &rest args)
161 (declare (ignore type args))
162 (alien-type 'unsigned))
164 (defmethod size-of ((type (eql 'flags)) &rest args)
165 (declare (ignore type args))
168 (defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
169 `(reduce #'logior (mklist ,flags)
170 :key #'(lambda (flag)
172 ,@(%map-flags args :symbol-int)
173 (t (error 'type-error :datum ,flags
174 :expected-type '(,type ,@args)))))))
176 (defmethod from-alien-form (value (type (eql 'flags)) &rest args)
177 (declare (ignore type))
179 for (int symbol) in ',(%map-flags args :int-symbol)
180 when (= (logand ,value int) int)
183 (defmethod to-alien-function ((type (eql 'flags)) &rest args)
184 (declare (ignore type))
185 (let ((mappings (%map-flags args :symbol-int)))
187 (reduce #'logior (mklist flags)
188 :key #'(lambda (flag)
190 (second (assoc flag mappings))
191 (error 'type-error :datum flags
192 :expected-type (cons 'flags args))))))))
194 (defmethod from-alien-function ((type (eql 'flags)) &rest args)
195 (declare (ignore type))
196 (let ((mappings (%map-flags args :int-symbol)))
199 for (int symbol) in mappings
200 when (= (logand value int) int)
203 (defmethod writer-function ((type (eql 'flags)) &rest args)
204 (declare (ignore type))
205 (let ((writer (writer-function 'unsigned))
206 (function (apply #'to-alien-function 'flags args)))
207 #'(lambda (flags location &optional (offset 0))
208 (funcall writer (funcall function flags) location offset))))
210 (defmethod reader-function ((type (eql 'flags)) &rest args)
211 (declare (ignore type))
212 (let ((reader (reader-function 'unsigned))
213 (function (apply #'from-alien-function 'flags args)))
214 #'(lambda (location &optional (offset 0) weak-p)
215 (declare (ignore weak-p))
216 (funcall function (funcall reader location offset)))))
219 ;;;; Named flags types
221 (defmacro define-flags-type (name &rest args)
222 (let ((flags-int (intern (format nil "~A-TO-INT" name)))
223 (int-flags (intern (format nil "INT-TO-~A" name)))
224 (satisfies (intern (format nil "~A-P" name))))
226 (deftype ,name () '(satisfies ,satisfies))
227 (defun ,satisfies (object)
229 (find ob ',(%map-flags args :symbols))))
231 (symbol (valid-p object))
232 (list (every #'valid-p object)))))
233 (defun ,flags-int (flags)
234 (reduce #'logior (mklist flags)
235 :key #'(lambda (flag)
237 ,@(%map-flags args :symbol-int)
238 (t (error 'type-error :datum flags
239 :expected-type ',name))))))
240 (defun ,int-flags (value)
242 for (int symbol) in ',(%map-flags args :int-symbol)
243 when(= (logand value int) int)
245 (defmethod alien-type ((type (eql ',name)) &rest args)
246 (declare (ignore type args))
248 (defmethod size-of ((type (eql ',name)) &rest args)
249 (declare (ignore type args))
251 (defmethod to-alien-form (form (type (eql ',name)) &rest args)
252 (declare (ignore type args))
253 (list ',flags-int form))
254 (defmethod from-alien-form (form (type (eql ',name)) &rest args)
255 (declare (ignore type args))
256 (list ',int-flags form))
257 (defmethod to-alien-function ((type (eql ',name)) &rest args)
258 (declare (ignore type args))
260 (defmethod from-alien-function ((type (eql ',name)) &rest args)
261 (declare (ignore type args))
263 (defmethod writer-function ((type (eql ',name)) &rest args)
264 (declare (ignore type args))
265 (let ((writer (writer-function 'signed)))
266 #'(lambda (flags location &optional (offset 0))
267 (funcall writer (,flags-int flags) location offset))))
268 (defmethod reader-function ((type (eql ',name)) &rest args)
269 (declare (ignore type args))
270 (let ((reader (reader-function 'signed)))
271 #'(lambda (location &optional (offset 0) weak-p)
272 (declare (ignore weak-p))
273 (,int-flags (funcall reader location offset))))))))
277 ;;;; Type definition by introspection
279 (defun %query-enum-or-flags-values (query-function class type)
280 (multiple-value-bind (sap length)
281 (funcall query-function (type-class-ref type))
283 (size (foreign-size (find-class class)))
284 (proxy (ensure-proxy-instance class sap)))
286 (with-slots (location nickname value) proxy
288 (setq sap (sap+ sap size))
291 (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
297 (defclass %enum-value (struct)
298 ((value :allocation :alien :type int)
299 (name :allocation :alien :type string)
300 (nickname :allocation :alien :type string))
301 (:metaclass static-struct-class))
303 (defbinding %enum-class-values () pointer
305 (n-values unsigned-int :out))
307 (defun query-enum-values (type)
308 (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
311 (defclass %flags-value (struct)
312 ((value :allocation :alien :type unsigned-int)
313 (name :allocation :alien :type string)
314 (nickname :allocation :alien :type string))
315 (:metaclass static-struct-class))
317 (defbinding %flags-class-values () pointer
319 (n-values unsigned-int :out))
321 (defun query-flags-values (type)
322 (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
325 (defun expand-enum-type (type-number forward-p options)
326 (declare (ignore forward-p))
327 (let* ((super (supertype type-number))
328 (type (type-from-number type-number))
329 (mappings (getf options :mappings))
335 (assoc (first mapping) mappings)
336 (rassoc (cdr mapping) mappings :test #'equal)))
338 (query-enum-values type-number)
339 (query-flags-values type-number)))
341 #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
343 (register-type ',type ',(find-type-init-function type-number))
345 (enum `(define-enum-type ,type ,@expanded-mappings))
346 (flags `(define-flags-type ,type ,@expanded-mappings))))))
349 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
350 (register-derivable-type 'flags "GFlags" 'expand-enum-type)