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.18 2006/02/19 22:25:31 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 callback-from-alien-form (form (type (eql 'enum)) &rest args)
61 (apply #'from-alien-form form type args))
63 (defmethod from-alien-form (form (type (eql 'enum)) &rest args)
64 (declare (ignore type))
66 ,@(%map-enum args :int-quoted-symbol)))
68 (defmethod to-alien-function ((type (eql 'enum)) &rest args)
69 (declare (ignore type))
70 (let ((mappings (%map-enum args :symbol-int)))
73 (second (assoc enum mappings))
74 (error 'type-error :datum enum :expected-type (cons 'enum args))))))
76 (defmethod from-alien-function ((type (eql 'enum)) &rest args)
77 (declare (ignore type))
78 (let ((mappings (%map-enum args :int-symbol)))
80 (second (assoc int mappings)))))
82 (defmethod writer-function ((type (eql 'enum)) &rest args)
83 (declare (ignore type))
84 (let ((writer (writer-function 'signed))
85 (function (apply #'to-alien-function 'enum args)))
86 #'(lambda (enum location &optional (offset 0))
87 (funcall writer (funcall function enum) location offset))))
89 (defmethod reader-function ((type (eql 'enum)) &rest args)
90 (declare (ignore type))
91 (let ((reader (reader-function 'signed))
92 (function (apply #'from-alien-function 'enum args)))
93 #'(lambda (location &optional (offset 0) weak-p)
94 (declare (ignore weak-p))
95 (funcall function (funcall reader location offset)))))
97 (defun enum-int (enum type)
98 (funcall (to-alien-function type) enum))
100 (defun int-enum (int type)
101 (funcall (from-alien-function type) int))
103 (defun enum-mapping (type)
104 (rest (type-expand-to 'enum type)))
107 ;;;; Named enum types
109 (defmacro define-enum-type (name &rest args)
110 (let ((enum-int (intern (format nil "~A-TO-INT" name)))
111 (int-enum (intern (format nil "INT-TO-~A" name))))
113 (deftype ,name () '(enum ,@args))
114 (defun ,enum-int (enum)
116 ,@(%map-enum args :symbol-int)
117 (t (error 'type-error :datum enum :expected-type ',name))))
118 (defun ,int-enum (value)
120 ,@(%map-enum args :int-quoted-symbol)))
121 (defmethod to-alien-form (form (type (eql ',name)) &rest args)
122 (declare (ignore type args))
123 (list ',enum-int form))
124 (defmethod from-alien-form (form (type (eql ',name)) &rest args)
125 (declare (ignore type args))
126 (list ',int-enum form))
127 (defmethod to-alien-function ((type (eql ',name)) &rest args)
128 (declare (ignore type args))
130 (defmethod from-alien-function ((type (eql ',name)) &rest args)
131 (declare (ignore type args))
133 (defmethod writer-function ((type (eql ',name)) &rest args)
134 (declare (ignore type args))
135 (let ((writer (writer-function 'signed)))
136 #'(lambda (enum location &optional (offset 0))
137 (funcall writer (,enum-int enum) location offset))))
138 (defmethod reader-function ((type (eql ',name)) &rest args)
139 (declare (ignore type args))
140 (let ((reader (reader-function 'signed)))
141 #'(lambda (location &optional (offset 0) weak-p)
142 (declare (ignore weak-p))
143 (,int-enum (funcall reader location offset))))))))
146 ;;;; Generic flags type
148 (defun %map-flags (mappings op)
150 as value = 1 then (ash value 1)
151 for mapping in mappings
152 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
153 (unless (atom mapping)
154 (setq value (second mapping)))
156 (:symbol-int `(,symbol ,value))
157 (:int-symbol `(,value ,symbol))
158 (:symbols symbol)))))
160 (deftype flags (&rest args)
161 `(or (member ,@(%map-flags args :symbols)) list))
163 (defmethod alien-type ((type (eql 'flags)) &rest args)
164 (declare (ignore type args))
165 (alien-type 'unsigned))
167 (defmethod size-of ((type (eql 'flags)) &rest args)
168 (declare (ignore type args))
171 (defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
172 `(reduce #'logior (mklist ,flags)
173 :key #'(lambda (flag)
175 ,@(%map-flags args :symbol-int)
176 (t (error 'type-error :datum ,flags
177 :expected-type '(,type ,@args)))))))
179 (defmethod callback-from-alien-form (form (type (eql 'flags)) &rest args)
180 (apply #'from-alien-form form type args))
182 (defmethod from-alien-form (value (type (eql 'flags)) &rest args)
183 (declare (ignore type))
185 for (int symbol) in ',(%map-flags args :int-symbol)
186 when (= (logand ,value int) int)
189 (defmethod to-alien-function ((type (eql 'flags)) &rest args)
190 (declare (ignore type))
191 (let ((mappings (%map-flags args :symbol-int)))
193 (reduce #'logior (mklist flags)
194 :key #'(lambda (flag)
196 (second (assoc flag mappings))
197 (error 'type-error :datum flags
198 :expected-type (cons 'flags args))))))))
200 (defmethod from-alien-function ((type (eql 'flags)) &rest args)
201 (declare (ignore type))
202 (let ((mappings (%map-flags args :int-symbol)))
205 for (int symbol) in mappings
206 when (= (logand value int) int)
209 (defmethod writer-function ((type (eql 'flags)) &rest args)
210 (declare (ignore type))
211 (let ((writer (writer-function 'unsigned))
212 (function (apply #'to-alien-function 'flags args)))
213 #'(lambda (flags location &optional (offset 0))
214 (funcall writer (funcall function flags) location offset))))
216 (defmethod reader-function ((type (eql 'flags)) &rest args)
217 (declare (ignore type))
218 (let ((reader (reader-function 'unsigned))
219 (function (apply #'from-alien-function 'flags args)))
220 #'(lambda (location &optional (offset 0) weak-p)
221 (declare (ignore weak-p))
222 (funcall function (funcall reader location offset)))))
225 ;;;; Named flags types
227 (defmacro define-flags-type (name &rest args)
228 (let ((flags-int (intern (format nil "~A-TO-INT" name)))
229 (int-flags (intern (format nil "INT-TO-~A" name)))
230 (satisfies (intern (format nil "~A-P" name))))
232 (deftype ,name () '(satisfies ,satisfies))
233 (defun ,satisfies (object)
235 (find ob ',(%map-flags args :symbols))))
237 (symbol (valid-p object))
238 (list (every #'valid-p object)))))
239 (defun ,flags-int (flags)
240 (reduce #'logior (mklist flags)
241 :key #'(lambda (flag)
243 ,@(%map-flags args :symbol-int)
244 (t (error 'type-error :datum flags
245 :expected-type ',name))))))
246 (defun ,int-flags (value)
248 for (int symbol) in ',(%map-flags args :int-symbol)
249 when(= (logand value int) int)
251 (defmethod alien-type ((type (eql ',name)) &rest args)
252 (declare (ignore type args))
254 (defmethod size-of ((type (eql ',name)) &rest args)
255 (declare (ignore type args))
257 (defmethod to-alien-form (form (type (eql ',name)) &rest args)
258 (declare (ignore type args))
259 (list ',flags-int form))
260 (defmethod from-alien-form (form (type (eql ',name)) &rest args)
261 (declare (ignore type args))
262 (list ',int-flags form))
263 (defmethod to-alien-function ((type (eql ',name)) &rest args)
264 (declare (ignore type args))
266 (defmethod from-alien-function ((type (eql ',name)) &rest args)
267 (declare (ignore type args))
269 (defmethod writer-function ((type (eql ',name)) &rest args)
270 (declare (ignore type args))
271 (let ((writer (writer-function 'signed)))
272 #'(lambda (flags location &optional (offset 0))
273 (funcall writer (,flags-int flags) location offset))))
274 (defmethod reader-function ((type (eql ',name)) &rest args)
275 (declare (ignore type args))
276 (let ((reader (reader-function 'signed)))
277 #'(lambda (location &optional (offset 0) weak-p)
278 (declare (ignore weak-p))
279 (,int-flags (funcall reader location offset))))))))
283 ;;;; Type definition by introspection
285 (defun %query-enum-or-flags-values (query-function class type)
286 (multiple-value-bind (sap length)
287 (funcall query-function (type-class-ref type))
289 (size (foreign-size (find-class class)))
290 (proxy (ensure-proxy-instance class sap)))
292 (with-slots (location nickname value) proxy
294 (setq sap (sap+ sap size))
297 (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
303 (defclass %enum-value (struct)
304 ((value :allocation :alien :type int)
305 (name :allocation :alien :type string)
306 (nickname :allocation :alien :type string))
307 (:metaclass static-struct-class))
309 (defbinding %enum-class-values () pointer
311 (n-values unsigned-int :out))
313 (defun query-enum-values (type)
314 (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
317 (defclass %flags-value (struct)
318 ((value :allocation :alien :type unsigned-int)
319 (name :allocation :alien :type string)
320 (nickname :allocation :alien :type string))
321 (:metaclass static-struct-class))
323 (defbinding %flags-class-values () pointer
325 (n-values unsigned-int :out))
327 (defun query-flags-values (type)
328 (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
331 (defun expand-enum-type (type-number forward-p options)
332 (declare (ignore forward-p))
333 (let* ((super (supertype type-number))
334 (type (type-from-number type-number))
335 (mappings (getf options :mappings))
341 (assoc (first mapping) mappings)
342 (rassoc (cdr mapping) mappings :test #'equal)))
344 (query-enum-values type-number)
345 (query-flags-values type-number)))
347 #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
349 (register-type ',type ',(find-type-init-function type-number))
351 (enum `(define-enum-type ,type ,@expanded-mappings))
352 (flags `(define-flags-type ,type ,@expanded-mappings))))))
355 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
356 (register-derivable-type 'flags "GFlags" 'expand-enum-type)