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.19 2006-02-26 15:30:01 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 (define-type-method alien-type ((type enum))
46 (declare (ignore type))
49 (define-type-method size-of ((type enum))
50 (declare (ignore type))
53 (define-type-method to-alien-form ((type enum) form )
55 ,@(%map-enum (rest (type-expand-to 'enum type)) :symbol-int)
56 (t (error 'type-error :datum ,form :expected-type ',type))))
58 (define-type-method from-alien-form ((type enum) form)
60 ,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol)))
62 (define-type-method to-alien-function ((type enum))
63 (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :symbol-int)))
66 (second (assoc enum mappings))
67 (error 'type-error :datum enum :expected-type type)))))
69 (define-type-method from-alien-function ((type enum))
70 (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :int-symbol)))
72 (second (assoc int mappings)))))
74 (define-type-method writer-function ((type enum))
75 (let ((writer (writer-function 'signed))
76 (function (to-alien-function (type-expand-to 'enum type))))
77 #'(lambda (enum location &optional (offset 0))
78 (funcall writer (funcall function enum) location offset))))
80 (define-type-method reader-function ((type enum))
81 (let ((reader (reader-function 'signed))
82 (function (from-alien-function (type-expand-to 'enum type))))
83 #'(lambda (location &optional (offset 0) weak-p)
84 (declare (ignore weak-p))
85 (funcall function (funcall reader location offset)))))
87 (defun enum-int (enum type)
88 (funcall (to-alien-function type) enum))
90 (defun int-enum (int type)
91 (funcall (from-alien-function type) int))
93 (defun enum-mapping (type)
94 (rest (type-expand-to 'enum type)))
99 (defmacro define-enum-type (name &rest args)
100 (let ((enum-int (intern (format nil "~A-TO-INT" name)))
101 (int-enum (intern (format nil "INT-TO-~A" name))))
103 (deftype ,name () '(enum ,@args))
104 (defun ,enum-int (enum)
106 ,@(%map-enum args :symbol-int)
107 (t (error 'type-error :datum enum :expected-type ',name))))
108 (defun ,int-enum (value)
110 ,@(%map-enum args :int-quoted-symbol)))
111 (define-type-method to-alien-form ((type ,name) form)
112 (declare (ignore type))
113 (list ',enum-int form))
114 (define-type-method from-alien-form ((type ,name) form)
115 (declare (ignore type))
116 (list ',int-enum form))
117 (define-type-method to-alien-function ((type ,name))
118 (declare (ignore type))
120 (define-type-method from-alien-function ((type ,name))
121 (declare (ignore type))
123 (define-type-method writer-function ((type ,name))
124 (declare (ignore type))
125 (let ((writer (writer-function 'signed)))
126 #'(lambda (enum location &optional (offset 0))
127 (funcall writer (,enum-int enum) location offset))))
128 (define-type-method reader-function ((type ,name))
129 (declare (ignore type))
130 (let ((reader (reader-function 'signed)))
131 #'(lambda (location &optional (offset 0) weak-p)
132 (declare (ignore weak-p))
133 (,int-enum (funcall reader location offset))))))))
136 ;;;; Generic flags type
138 (defun %map-flags (mappings op)
140 as value = 1 then (ash value 1)
141 for mapping in mappings
142 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
143 (unless (atom mapping)
144 (setq value (second mapping)))
146 (:symbol-int `(,symbol ,value))
147 (:int-symbol `(,value ,symbol))
148 (:symbols symbol)))))
150 (deftype flags (&rest args)
151 `(or (member ,@(%map-flags args :symbols)) list))
153 (define-type-method alien-type ((type flags))
154 (declare (ignore type))
155 (alien-type 'unsigned))
157 (define-type-method size-of ((type flags))
158 (declare (ignore type))
161 (define-type-method to-alien-form ((type flags) flags)
162 `(reduce #'logior (mklist ,flags)
163 :key #'(lambda (flag)
165 ,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int)
166 (t (error 'type-error :datum ,flags :expected-type ',type))))))
168 (define-type-method from-alien-form ((type flags) value)
170 for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol)
171 when (= (logand ,value int) int)
174 (define-type-method to-alien-function ((type flags))
175 (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :symbol-int)))
177 (reduce #'logior (mklist flags)
178 :key #'(lambda (flag)
180 (second (assoc flag mappings))
181 (error 'type-error :datum flags :expected-type type)))))))
183 (define-type-method from-alien-function ((type flags))
184 (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :int-symbol)))
187 for (int symbol) in mappings
188 when (= (logand value int) int)
191 (define-type-method writer-function ((type flags))
192 (let ((writer (writer-function 'unsigned))
193 (function (to-alien-function (type-expand-to 'flags type))))
194 #'(lambda (flags location &optional (offset 0))
195 (funcall writer (funcall function flags) location offset))))
197 (define-type-method reader-function ((type flags))
198 (let ((reader (reader-function 'unsigned))
199 (function (from-alien-function (type-expand-to 'flags type))))
200 #'(lambda (location &optional (offset 0) weak-p)
201 (declare (ignore weak-p))
202 (funcall function (funcall reader location offset)))))
205 ;;;; Named flags types
207 (defmacro define-flags-type (name &rest args)
208 (let ((flags-int (intern (format nil "~A-TO-INT" name)))
209 (int-flags (intern (format nil "INT-TO-~A" name)))
210 (satisfies (intern (format nil "~A-P" name))))
212 (deftype ,name () '(satisfies ,satisfies))
213 (defun ,satisfies (object)
215 (find ob ',(%map-flags args :symbols))))
217 (symbol (valid-p object))
218 (list (every #'valid-p object)))))
219 (defun ,flags-int (flags)
220 (reduce #'logior (mklist flags)
221 :key #'(lambda (flag)
223 ,@(%map-flags args :symbol-int)
224 (t (error 'type-error :datum flags
225 :expected-type ',name))))))
226 (defun ,int-flags (value)
228 for (int symbol) in ',(%map-flags args :int-symbol)
229 when(= (logand value int) int)
231 (define-type-method alien-type ((type ,name))
232 (declare (ignore type))
234 (define-type-method size-of ((type ,name))
235 (declare (ignore type))
237 (define-type-method to-alien-form ((type ,name) form)
238 (declare (ignore type))
239 (list ',flags-int form))
240 (define-type-method from-alien-form ((type ,name) form)
241 (declare (ignore type))
242 (list ',int-flags form))
243 (define-type-method to-alien-function ((type ,name))
244 (declare (ignore type))
246 (define-type-method from-alien-function ((type ,name))
247 (declare (ignore type))
249 (define-type-method writer-function ((type ,name))
250 (declare (ignore type))
251 (let ((writer (writer-function 'signed)))
252 #'(lambda (flags location &optional (offset 0))
253 (funcall writer (,flags-int flags) location offset))))
254 (define-type-method reader-function ((type ,name))
255 (declare (ignore type))
256 (let ((reader (reader-function 'signed)))
257 #'(lambda (location &optional (offset 0) weak-p)
258 (declare (ignore weak-p))
259 (,int-flags (funcall reader location offset))))))))
263 ;;;; Type definition by introspection
265 (defun %query-enum-or-flags-values (query-function class type)
266 (multiple-value-bind (sap length)
267 (funcall query-function (type-class-ref type))
269 (size (foreign-size (find-class class)))
270 (proxy (ensure-proxy-instance class sap)))
272 (with-slots (location nickname value) proxy
274 (setq sap (sap+ sap size))
277 (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
283 (defclass %enum-value (struct)
284 ((value :allocation :alien :type int)
285 (name :allocation :alien :type string)
286 (nickname :allocation :alien :type string))
287 (:metaclass static-struct-class))
289 (defbinding %enum-class-values () pointer
291 (n-values unsigned-int :out))
293 (defun query-enum-values (type)
294 (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
297 (defclass %flags-value (struct)
298 ((value :allocation :alien :type unsigned-int)
299 (name :allocation :alien :type string)
300 (nickname :allocation :alien :type string))
301 (:metaclass static-struct-class))
303 (defbinding %flags-class-values () pointer
305 (n-values unsigned-int :out))
307 (defun query-flags-values (type)
308 (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
311 (defun expand-enum-type (type-number forward-p options)
312 (declare (ignore forward-p))
313 (let* ((super (supertype type-number))
314 (type (type-from-number type-number))
315 (mappings (getf options :mappings))
321 (assoc (first mapping) mappings)
322 (rassoc (cdr mapping) mappings :test #'equal)))
324 (query-enum-values type-number)
325 (query-flags-values type-number)))
327 #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
329 (register-type ',type ',(find-type-init-function type-number))
331 (enum `(define-enum-type ,type ,@expanded-mappings))
332 (flags `(define-flags-type ,type ,@expanded-mappings))))))
335 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
336 (register-derivable-type 'flags "GFlags" 'expand-enum-type)