1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2006 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: enums.lisp,v 1.3 2006-09-05 13:15:46 espen Exp $
27 ;;;; Generic enum type
29 (defun %map-enum (mappings op)
32 as value = 0 then (1+ value)
33 for mapping in mappings
34 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
35 (unless (atom mapping)
36 (setq value (second mapping)))
38 (:symbol-int `(,symbol ,value))
39 (:int-symbol `(,value ,symbol))
40 (:int-quoted-symbol `(,value ',symbol)))))
41 :key #'first :from-end t))
43 (defun %map-symbols (mappings)
44 (mapcar #'(lambda (mapping)
45 (first (mklist mapping)))
48 (deftype enum (&rest args)
49 `(member ,@(%map-symbols args)))
51 (define-type-method alien-type ((type enum))
52 (declare (ignore type))
55 (define-type-method size-of ((type enum) &key (inlined t))
56 (assert-inlined type inlined)
59 (define-type-method type-alignment ((type enum) &key (inlined t))
60 (assert-inlined type inlined)
61 (type-alignment 'signed))
63 (define-type-method to-alien-form ((type enum) form &optional copy-p)
64 (declare (ignore copy-p))
66 ,@(%map-enum (rest (type-expand-to 'enum type)) :symbol-int)
67 (t (error 'type-error :datum ,form :expected-type ',type))))
69 (define-type-method from-alien-form ((type enum) form &key ref)
70 (declare (ignore ref))
72 ,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol)))
74 (define-type-method to-alien-function ((type enum) &optional copy-p)
75 (declare (ignore copy-p))
76 (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :symbol-int)))
79 (second (assoc enum mappings))
80 (error 'type-error :datum enum :expected-type type)))))
82 (define-type-method from-alien-function ((type enum) &key ref)
83 (declare (ignore ref))
84 (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :int-symbol)))
86 (second (assoc int mappings)))))
88 (define-type-method writer-function ((type enum) &key temp (inlined t))
89 (declare (ignore temp))
90 (assert-inlined type inlined)
91 (let ((writer (writer-function 'signed))
92 (function (to-alien-function (type-expand-to 'enum type))))
93 #'(lambda (enum location &optional (offset 0))
94 (funcall writer (funcall function enum) location offset))))
96 (define-type-method reader-function ((type enum) &key ref (inlined t))
97 (declare (ignore ref))
98 (assert-inlined type inlined)
99 (let ((reader (reader-function 'signed))
100 (function (from-alien-function (type-expand-to 'enum type))))
101 #'(lambda (location &optional (offset 0))
102 (funcall function (funcall reader location offset)))))
104 (defun enum-int (enum type)
105 (funcall (to-alien-function type) enum))
107 (defun int-enum (int type)
108 (funcall (from-alien-function type) int))
110 (defun enum-mapping (type)
111 (rest (type-expand-to 'enum type)))
114 ;;;; Named enum types
116 (defmacro define-enum-type (name &rest args)
117 (let ((enum-int (intern (format nil "~A-TO-INT" name)))
118 (int-enum (intern (format nil "INT-TO-~A" name))))
120 (deftype ,name () '(enum ,@args))
121 (defun ,enum-int (enum)
123 ,@(%map-enum args :symbol-int)
124 (t (error 'type-error :datum enum :expected-type ',name))))
125 (defun ,int-enum (value)
127 ,@(%map-enum args :int-quoted-symbol)))
128 (eval-when (:compile-toplevel :load-toplevel :execute)
129 (define-type-method to-alien-form ((type ,name) form &optional copy-p)
130 (declare (ignore type copy-p))
131 (list ',enum-int form))
132 (define-type-method from-alien-form ((type ,name) form &key ref)
133 (declare (ignore type ref))
134 (list ',int-enum form))
135 (define-type-method to-alien-function ((type ,name) &optional copy-p)
136 (declare (ignore type copy-p))
138 (define-type-method from-alien-function ((type ,name) &key ref)
139 (declare (ignore type ref))
141 (define-type-method writer-function ((type ,name) &key temp (inlined t))
142 (declare (ignore temp))
143 (assert-inlined type inlined)
144 (let ((writer (writer-function 'signed)))
145 #'(lambda (enum location &optional (offset 0))
146 (funcall writer (,enum-int enum) location offset))))
147 (define-type-method reader-function ((type ,name) &key ref (inlined t))
148 (declare (ignore ref))
149 (assert-inlined type inlined)
150 (let ((reader (reader-function 'signed)))
151 #'(lambda (location &optional (offset 0))
152 (,int-enum (funcall reader location offset)))))))))
155 ;;;; Generic flags type
157 (defun %map-flags (mappings op)
160 as value = 1 then (ash value 1)
161 for mapping in mappings
162 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
163 (unless (atom mapping)
164 (setq value (second mapping)))
166 (:symbol-int `(,symbol ,value))
167 (:int-symbol `(,value ,symbol)))))
168 :key #'first :from-end t))
170 (deftype flags (&rest args) (declare (ignore args)) t)
172 (define-type-method alien-type ((type flags))
173 (declare (ignore type))
174 (alien-type 'unsigned))
176 (define-type-method size-of ((type flags) &key (inlined t))
177 (assert-inlined type inlined)
180 (define-type-method type-alignment ((type flags) &key (inlined t))
181 (assert-inlined type inlined)
182 (type-alignment 'unsigned))
184 (define-type-method to-alien-form ((type flags) flags &optional copy-p)
185 (declare (ignore copy-p))
186 `(reduce #'logior (mklist ,flags)
187 :key #'(lambda (flag)
189 ,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int)
190 (t (error 'type-error :datum ,flags :expected-type ',type))))))
192 (define-type-method from-alien-form ((type flags) value &key ref)
193 (declare (ignore ref))
195 for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol)
196 when (= (logand ,value int) int)
199 (define-type-method to-alien-function ((type flags) &optional copy-p)
200 (declare (ignore copy-p))
201 (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :symbol-int)))
203 (reduce #'logior (mklist flags)
204 :key #'(lambda (flag)
206 (second (assoc flag mappings))
207 (error 'type-error :datum flags :expected-type type)))))))
209 (define-type-method from-alien-function ((type flags) &key ref)
210 (declare (ignore ref))
211 (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :int-symbol)))
214 for (int symbol) in mappings
215 when (= (logand value int) int)
218 (define-type-method writer-function ((type flags) &key temp (inlined t))
219 (declare (ignore temp))
220 (assert-inlined type inlined)
221 (let ((writer (writer-function 'unsigned))
222 (function (to-alien-function (type-expand-to 'flags type))))
223 #'(lambda (flags location &optional (offset 0))
224 (funcall writer (funcall function flags) location offset))))
226 (define-type-method reader-function ((type flags) &key ref (inlined t))
227 (declare (ignore ref))
228 (assert-inlined type inlined)
229 (let ((reader (reader-function 'unsigned))
230 (function (from-alien-function (type-expand-to 'flags type))))
231 #'(lambda (location &optional (offset 0))
232 (funcall function (funcall reader location offset)))))
235 ;;;; Named flags types
237 (defmacro define-flags-type (name &rest args)
238 (let ((flags-int (intern (format nil "~A-TO-INT" name)))
239 (int-flags (intern (format nil "INT-TO-~A" name)))
240 (satisfies (intern (format nil "~A-P" name))))
241 `(eval-when (:compile-toplevel :load-toplevel :execute)
242 ;; (deftype ,name () '(satisfies ,satisfies))
243 (deftype ,name () '(flags ,@args))
244 (defun ,satisfies (object)
246 (find ob ',(%map-symbols args))))
248 (symbol (valid-p object))
249 (list (every #'valid-p object)))))
250 (defun ,flags-int (flags)
251 (reduce #'logior (mklist flags)
252 :key #'(lambda (flag)
254 ,@(%map-flags args :symbol-int)
255 (t (error 'type-error :datum flags :expected-type ',name))))))
256 (defun ,int-flags (value)
258 for (int symbol) in ',(%map-flags args :int-symbol)
259 when(= (logand value int) int)
261 (define-type-method alien-type ((type ,name))
262 (declare (ignore type))
264 (define-type-method size-of ((type ,name) &key (inlined t))
265 (assert-inlined type inlined)
267 (define-type-method type-alignment ((type ,name) &key (inlined t))
268 (assert-inlined type inlined)
269 (type-alignment 'flags))
270 (define-type-method to-alien-form ((type ,name) form &optional copy-p)
271 (declare (ignore type copy-p))
272 (list ',flags-int form))
273 (define-type-method from-alien-form ((type ,name) form &key ref)
274 (declare (ignore type ref))
275 (list ',int-flags form))
276 (define-type-method to-alien-function ((type ,name) &optional copy-p)
277 (declare (ignore type copy-p))
279 (define-type-method from-alien-function ((type ,name) &key ref)
280 (declare (ignore type ref))
282 (define-type-method writer-function ((type ,name) &key temp (inlined t))
283 (declare (ignore temp))
284 (assert-inlined type inlined)
285 (let ((writer (writer-function 'signed)))
286 #'(lambda (flags location &optional (offset 0))
287 (funcall writer (,flags-int flags) location offset))))
288 (define-type-method reader-function ((type ,name) &key ref (inlined t))
289 (declare (ignore ref))
290 (assert-inlined type inlined)
291 (let ((reader (reader-function 'signed)))
292 #'(lambda (location &optional (offset 0))
293 (,int-flags (funcall reader location offset))))))))
296 (defexport define-enum-type (name &rest args)
297 (declare (ignore args))
300 (defexport define-flags-type (name &rest args)
301 (declare (ignore args))