chiark / gitweb /
Correctly sort out string-specified getters in virtual-slots.lisp
[clg] / gffi / enums.lisp
CommitLineData
e6813115 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
d249d89f 23;; $Id: enums.lisp,v 1.3 2006-09-05 13:15:46 espen Exp $
e6813115 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
90e8bbf6 59(define-type-method type-alignment ((type enum) &key (inlined t))
60 (assert-inlined type inlined)
61 (type-alignment 'signed))
62
e6813115 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
d249d89f 170(deftype flags (&rest args) (declare (ignore args)) t)
e6813115 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
90e8bbf6 180(define-type-method type-alignment ((type flags) &key (inlined t))
181 (assert-inlined type inlined)
182 (type-alignment 'unsigned))
183
e6813115 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))))
90e8bbf6 241 `(eval-when (:compile-toplevel :load-toplevel :execute)
d249d89f 242;; (deftype ,name () '(satisfies ,satisfies))
243 (deftype ,name () '(flags ,@args))
e6813115 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))
90e8bbf6 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))))))))
e6813115 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)