d479a3a2 |
1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net> |
3 | ;; |
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: |
11 | ;; |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
14 | ;; |
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. |
22 | |
20298cc5 |
23 | ;; $Id: enums.lisp,v 1.3 2006/09/05 13:15:46 espen Exp $ |
d479a3a2 |
24 | |
25 | (in-package "GFFI") |
26 | |
27 | ;;;; Generic enum type |
28 | |
29 | (defun %map-enum (mappings op) |
30 | (delete-duplicates |
31 | (loop |
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))) |
37 | (ecase op |
38 | (:symbol-int `(,symbol ,value)) |
39 | (:int-symbol `(,value ,symbol)) |
40 | (:int-quoted-symbol `(,value ',symbol))))) |
41 | :key #'first :from-end t)) |
42 | |
43 | (defun %map-symbols (mappings) |
44 | (mapcar #'(lambda (mapping) |
45 | (first (mklist mapping))) |
46 | mappings)) |
47 | |
48 | (deftype enum (&rest args) |
49 | `(member ,@(%map-symbols args))) |
50 | |
51 | (define-type-method alien-type ((type enum)) |
52 | (declare (ignore type)) |
53 | (alien-type 'signed)) |
54 | |
55 | (define-type-method size-of ((type enum) &key (inlined t)) |
56 | (assert-inlined type inlined) |
57 | (size-of 'signed)) |
58 | |
83f60e84 |
59 | (define-type-method type-alignment ((type enum) &key (inlined t)) |
60 | (assert-inlined type inlined) |
61 | (type-alignment 'signed)) |
62 | |
d479a3a2 |
63 | (define-type-method to-alien-form ((type enum) form &optional copy-p) |
64 | (declare (ignore copy-p)) |
65 | `(case ,form |
66 | ,@(%map-enum (rest (type-expand-to 'enum type)) :symbol-int) |
67 | (t (error 'type-error :datum ,form :expected-type ',type)))) |
68 | |
69 | (define-type-method from-alien-form ((type enum) form &key ref) |
70 | (declare (ignore ref)) |
71 | `(case ,form |
72 | ,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol))) |
73 | |
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))) |
77 | #'(lambda (enum) |
78 | (or |
79 | (second (assoc enum mappings)) |
80 | (error 'type-error :datum enum :expected-type type))))) |
81 | |
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))) |
85 | #'(lambda (int) |
86 | (second (assoc int mappings))))) |
87 | |
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)))) |
95 | |
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))))) |
103 | |
104 | (defun enum-int (enum type) |
105 | (funcall (to-alien-function type) enum)) |
106 | |
107 | (defun int-enum (int type) |
108 | (funcall (from-alien-function type) int)) |
109 | |
110 | (defun enum-mapping (type) |
111 | (rest (type-expand-to 'enum type))) |
112 | |
113 | |
114 | ;;;; Named enum types |
115 | |
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)))) |
119 | `(progn |
120 | (deftype ,name () '(enum ,@args)) |
121 | (defun ,enum-int (enum) |
122 | (case enum |
123 | ,@(%map-enum args :symbol-int) |
124 | (t (error 'type-error :datum enum :expected-type ',name)))) |
125 | (defun ,int-enum (value) |
126 | (case 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)) |
137 | #',enum-int) |
138 | (define-type-method from-alien-function ((type ,name) &key ref) |
139 | (declare (ignore type ref)) |
140 | #',int-enum) |
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))))))))) |
153 | |
154 | |
155 | ;;;; Generic flags type |
156 | |
157 | (defun %map-flags (mappings op) |
158 | (delete-duplicates |
159 | (loop |
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))) |
165 | (case op |
166 | (:symbol-int `(,symbol ,value)) |
167 | (:int-symbol `(,value ,symbol))))) |
168 | :key #'first :from-end t)) |
169 | |
20298cc5 |
170 | (deftype flags (&rest args) (declare (ignore args)) t) |
d479a3a2 |
171 | |
172 | (define-type-method alien-type ((type flags)) |
173 | (declare (ignore type)) |
174 | (alien-type 'unsigned)) |
175 | |
176 | (define-type-method size-of ((type flags) &key (inlined t)) |
177 | (assert-inlined type inlined) |
178 | (size-of 'unsigned)) |
179 | |
83f60e84 |
180 | (define-type-method type-alignment ((type flags) &key (inlined t)) |
181 | (assert-inlined type inlined) |
182 | (type-alignment 'unsigned)) |
183 | |
d479a3a2 |
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) |
188 | (case flag |
189 | ,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int) |
190 | (t (error 'type-error :datum ,flags :expected-type ',type)))))) |
191 | |
192 | (define-type-method from-alien-form ((type flags) value &key ref) |
193 | (declare (ignore ref)) |
194 | `(loop |
195 | for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol) |
196 | when (= (logand ,value int) int) |
197 | collect symbol)) |
198 | |
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))) |
202 | #'(lambda (flags) |
203 | (reduce #'logior (mklist flags) |
204 | :key #'(lambda (flag) |
205 | (or |
206 | (second (assoc flag mappings)) |
207 | (error 'type-error :datum flags :expected-type type))))))) |
208 | |
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))) |
212 | #'(lambda (value) |
213 | (loop |
214 | for (int symbol) in mappings |
215 | when (= (logand value int) int) |
216 | collect symbol)))) |
217 | |
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)))) |
225 | |
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))))) |
233 | |
234 | |
235 | ;;;; Named flags types |
236 | |
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)))) |
83f60e84 |
241 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
20298cc5 |
242 | ;; (deftype ,name () '(satisfies ,satisfies)) |
243 | (deftype ,name () '(flags ,@args)) |
d479a3a2 |
244 | (defun ,satisfies (object) |
245 | (flet ((valid-p (ob) |
246 | (find ob ',(%map-symbols args)))) |
247 | (typecase object |
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) |
253 | (case flag |
254 | ,@(%map-flags args :symbol-int) |
255 | (t (error 'type-error :datum flags :expected-type ',name)))))) |
256 | (defun ,int-flags (value) |
257 | (loop |
258 | for (int symbol) in ',(%map-flags args :int-symbol) |
259 | when(= (logand value int) int) |
260 | collect symbol)) |
83f60e84 |
261 | (define-type-method alien-type ((type ,name)) |
262 | (declare (ignore type)) |
263 | (alien-type 'flags)) |
264 | (define-type-method size-of ((type ,name) &key (inlined t)) |
265 | (assert-inlined type inlined) |
266 | (size-of 'flags)) |
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)) |
278 | #',flags-int) |
279 | (define-type-method from-alien-function ((type ,name) &key ref) |
280 | (declare (ignore type ref)) |
281 | #',int-flags) |
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)))))))) |
d479a3a2 |
294 | |
295 | |
296 | (defexport define-enum-type (name &rest args) |
297 | (declare (ignore args)) |
298 | name) |
299 | |
300 | (defexport define-flags-type (name &rest args) |
301 | (declare (ignore args)) |
302 | name) |