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.1 2006-04-25 20:37:49 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 to-alien-form ((type enum) form &optional copy-p)
60 (declare (ignore copy-p))
62 ,@(%map-enum (rest (type-expand-to 'enum type)) :symbol-int)
63 (t (error 'type-error :datum ,form :expected-type ',type))))
65 (define-type-method from-alien-form ((type enum) form &key ref)
66 (declare (ignore ref))
68 ,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol)))
70 (define-type-method to-alien-function ((type enum) &optional copy-p)
71 (declare (ignore copy-p))
72 (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :symbol-int)))
75 (second (assoc enum mappings))
76 (error 'type-error :datum enum :expected-type type)))))
78 (define-type-method from-alien-function ((type enum) &key ref)
79 (declare (ignore ref))
80 (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :int-symbol)))
82 (second (assoc int mappings)))))
84 (define-type-method writer-function ((type enum) &key temp (inlined t))
85 (declare (ignore temp))
86 (assert-inlined type inlined)
87 (let ((writer (writer-function 'signed))
88 (function (to-alien-function (type-expand-to 'enum type))))
89 #'(lambda (enum location &optional (offset 0))
90 (funcall writer (funcall function enum) location offset))))
92 (define-type-method reader-function ((type enum) &key ref (inlined t))
93 (declare (ignore ref))
94 (assert-inlined type inlined)
95 (let ((reader (reader-function 'signed))
96 (function (from-alien-function (type-expand-to 'enum type))))
97 #'(lambda (location &optional (offset 0))
98 (funcall function (funcall reader location offset)))))
100 (defun enum-int (enum type)
101 (funcall (to-alien-function type) enum))
103 (defun int-enum (int type)
104 (funcall (from-alien-function type) int))
106 (defun enum-mapping (type)
107 (rest (type-expand-to 'enum type)))
110 ;;;; Named enum types
112 (defmacro define-enum-type (name &rest args)
113 (let ((enum-int (intern (format nil "~A-TO-INT" name)))
114 (int-enum (intern (format nil "INT-TO-~A" name))))
116 (deftype ,name () '(enum ,@args))
117 (defun ,enum-int (enum)
119 ,@(%map-enum args :symbol-int)
120 (t (error 'type-error :datum enum :expected-type ',name))))
121 (defun ,int-enum (value)
123 ,@(%map-enum args :int-quoted-symbol)))
124 (eval-when (:compile-toplevel :load-toplevel :execute)
125 (define-type-method to-alien-form ((type ,name) form &optional copy-p)
126 (declare (ignore type copy-p))
127 (list ',enum-int form))
128 (define-type-method from-alien-form ((type ,name) form &key ref)
129 (declare (ignore type ref))
130 (list ',int-enum form))
131 (define-type-method to-alien-function ((type ,name) &optional copy-p)
132 (declare (ignore type copy-p))
134 (define-type-method from-alien-function ((type ,name) &key ref)
135 (declare (ignore type ref))
137 (define-type-method writer-function ((type ,name) &key temp (inlined t))
138 (declare (ignore temp))
139 (assert-inlined type inlined)
140 (let ((writer (writer-function 'signed)))
141 #'(lambda (enum location &optional (offset 0))
142 (funcall writer (,enum-int enum) location offset))))
143 (define-type-method reader-function ((type ,name) &key ref (inlined t))
144 (declare (ignore ref))
145 (assert-inlined type inlined)
146 (let ((reader (reader-function 'signed)))
147 #'(lambda (location &optional (offset 0))
148 (,int-enum (funcall reader location offset)))))))))
151 ;;;; Generic flags type
153 (defun %map-flags (mappings op)
156 as value = 1 then (ash value 1)
157 for mapping in mappings
158 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
159 (unless (atom mapping)
160 (setq value (second mapping)))
162 (:symbol-int `(,symbol ,value))
163 (:int-symbol `(,value ,symbol)))))
164 :key #'first :from-end t))
166 (deftype flags (&rest args)
167 `(or (member ,@(%map-symbols args)) list))
169 (define-type-method alien-type ((type flags))
170 (declare (ignore type))
171 (alien-type 'unsigned))
173 (define-type-method size-of ((type flags) &key (inlined t))
174 (assert-inlined type inlined)
177 (define-type-method to-alien-form ((type flags) flags &optional copy-p)
178 (declare (ignore copy-p))
179 `(reduce #'logior (mklist ,flags)
180 :key #'(lambda (flag)
182 ,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int)
183 (t (error 'type-error :datum ,flags :expected-type ',type))))))
185 (define-type-method from-alien-form ((type flags) value &key ref)
186 (declare (ignore ref))
188 for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol)
189 when (= (logand ,value int) int)
192 (define-type-method to-alien-function ((type flags) &optional copy-p)
193 (declare (ignore copy-p))
194 (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :symbol-int)))
196 (reduce #'logior (mklist flags)
197 :key #'(lambda (flag)
199 (second (assoc flag mappings))
200 (error 'type-error :datum flags :expected-type type)))))))
202 (define-type-method from-alien-function ((type flags) &key ref)
203 (declare (ignore ref))
204 (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :int-symbol)))
207 for (int symbol) in mappings
208 when (= (logand value int) int)
211 (define-type-method writer-function ((type flags) &key temp (inlined t))
212 (declare (ignore temp))
213 (assert-inlined type inlined)
214 (let ((writer (writer-function 'unsigned))
215 (function (to-alien-function (type-expand-to 'flags type))))
216 #'(lambda (flags location &optional (offset 0))
217 (funcall writer (funcall function flags) location offset))))
219 (define-type-method reader-function ((type flags) &key ref (inlined t))
220 (declare (ignore ref))
221 (assert-inlined type inlined)
222 (let ((reader (reader-function 'unsigned))
223 (function (from-alien-function (type-expand-to 'flags type))))
224 #'(lambda (location &optional (offset 0))
225 (funcall function (funcall reader location offset)))))
228 ;;;; Named flags types
230 (defmacro define-flags-type (name &rest args)
231 (let ((flags-int (intern (format nil "~A-TO-INT" name)))
232 (int-flags (intern (format nil "INT-TO-~A" name)))
233 (satisfies (intern (format nil "~A-P" name))))
235 (deftype ,name () '(satisfies ,satisfies))
236 (defun ,satisfies (object)
238 (find ob ',(%map-symbols args))))
240 (symbol (valid-p object))
241 (list (every #'valid-p object)))))
242 (defun ,flags-int (flags)
243 (reduce #'logior (mklist flags)
244 :key #'(lambda (flag)
246 ,@(%map-flags args :symbol-int)
247 (t (error 'type-error :datum flags :expected-type ',name))))))
248 (defun ,int-flags (value)
250 for (int symbol) in ',(%map-flags args :int-symbol)
251 when(= (logand value int) int)
253 (eval-when (:compile-toplevel :load-toplevel :execute)
254 (define-type-method alien-type ((type ,name))
255 (declare (ignore type))
257 (define-type-method size-of ((type ,name) &key (inlined t))
258 (assert-inlined type inlined)
260 (define-type-method to-alien-form ((type ,name) form &optional copy-p)
261 (declare (ignore type copy-p))
262 (list ',flags-int form))
263 (define-type-method from-alien-form ((type ,name) form &key ref)
264 (declare (ignore type ref))
265 (list ',int-flags form))
266 (define-type-method to-alien-function ((type ,name) &optional copy-p)
267 (declare (ignore type copy-p))
269 (define-type-method from-alien-function ((type ,name) &key ref)
270 (declare (ignore type ref))
272 (define-type-method writer-function ((type ,name) &key temp (inlined t))
273 (declare (ignore temp))
274 (assert-inlined type inlined)
275 (let ((writer (writer-function 'signed)))
276 #'(lambda (flags location &optional (offset 0))
277 (funcall writer (,flags-int flags) location offset))))
278 (define-type-method reader-function ((type ,name) &key ref (inlined t))
279 (declare (ignore ref))
280 (assert-inlined type inlined)
281 (let ((reader (reader-function 'signed)))
282 #'(lambda (location &optional (offset 0))
283 (,int-flags (funcall reader location offset)))))))))
286 (defexport define-enum-type (name &rest args)
287 (declare (ignore args))
290 (defexport define-flags-type (name &rest args)
291 (declare (ignore args))