1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
4 ;; This library is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU Lesser General Public
6 ;; License as published by the Free Software Foundation; either
7 ;; version 2 of the License, or (at your option) any later version.
9 ;; This library is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;; Lesser General Public License for more details.
14 ;; You should have received a copy of the GNU Lesser General Public
15 ;; License along with this library; if not, write to the Free Software
16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18 ;; $Id: genums.lisp,v 1.9 2005-02-11 19:09:38 espen Exp $
22 ;;;; Generic enum type
24 (defun %map-enum (mappings op)
26 as value = 1 then (1+ value)
27 for mapping in mappings
28 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
29 (unless (atom mapping)
30 (setq value (second mapping)))
32 (:symbol-int (list symbol value))
33 (:int-symbol (list value symbol))
36 (deftype enum (&rest args)
37 `(member ,@(%map-enum args :symbols)))
39 (defmethod alien-type ((type (eql 'enum)) &rest args)
40 (declare (ignore type args))
43 (defmethod size-of ((type (eql 'enum)) &rest args)
44 (declare (ignore type args))
47 (defmethod to-alien-form (form (type (eql 'enum)) &rest args)
48 (declare (ignore type))
50 ,@(%map-enum args :symbol-int)
51 (t (error 'type-error :datum ,form :expected-type '(enum ,@args)))))
54 (defmethod from-alien-form (form (type (eql 'enum)) &rest args)
55 (declare (ignore type))
57 ,@(%map-enum args :int-symbol)))
59 (defmethod to-alien-function ((type (eql 'enum)) &rest args)
60 (declare (ignore type))
61 (let ((mappings (%map-enum args :symbol-int)))
64 (second (assoc enum mappings))
65 (error 'type-error :datum enum :expected-type (cons 'enum args))))))
67 (defmethod from-alien-function ((type (eql 'enum)) &rest args)
68 (declare (ignore type))
69 (let ((mappings (%map-enum args :int-symbol)))
71 (second (assoc int mappings)))))
73 (defmethod writer-function ((type (eql 'enum)) &rest args)
74 (declare (ignore type))
75 (let ((writer (writer-function 'signed))
76 (function (apply #'to-alien-function 'enum args)))
77 #'(lambda (enum location &optional (offset 0))
78 (funcall writer (funcall function enum) location offset))))
80 (defmethod reader-function ((type (eql 'enum)) &rest args)
81 (declare (ignore type))
82 (let ((reader (reader-function 'signed))
83 (function (apply #'from-alien-function 'enum args)))
84 #'(lambda (location &optional (offset 0))
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-symbol)))
111 (defmethod to-alien-form (form (type (eql ',name)) &rest args)
112 (declare (ignore type args))
113 (list ',enum-int form))
114 (defmethod from-alien-form (form (type (eql ',name)) &rest args)
115 (declare (ignore type args))
116 (list ',int-enum form))
117 (defmethod to-alien-function ((type (eql ',name)) &rest args)
118 (declare (ignore type args))
120 (defmethod from-alien-function ((type (eql ',name)) &rest args)
121 (declare (ignore type args))
123 (defmethod writer-function ((type (eql ',name)) &rest args)
124 (declare (ignore type args))
125 (let ((writer (writer-function 'signed)))
126 #'(lambda (enum location &optional (offset 0))
127 (funcall writer (,enum-int enum) location offset))))
128 (defmethod reader-function ((type (eql ',name)) &rest args)
129 (declare (ignore type args))
130 (let ((reader (reader-function 'signed)))
131 #'(lambda (location &optional (offset 0))
132 (,int-enum (funcall reader location offset))))))))
135 ;;;; Generic flags type
137 (defun %map-flags (mappings op)
139 as value = 1 then (ash value 1)
140 for mapping in mappings
141 collect (let ((symbol (if (atom mapping) mapping (first mapping))))
142 (unless (atom mapping)
143 (setq value (second mapping)))
145 (:symbol-int (list symbol value))
146 (:int-symbol (list value symbol))
147 (:symbols symbol)))))
149 (deftype flags (&rest args)
150 `(or (member ,@(%map-flags args :symbols)) list))
152 (defmethod alien-type ((type (eql 'flags)) &rest args)
153 (declare (ignore type args))
154 (alien-type 'unsigned))
156 (defmethod size-of ((type (eql 'flags)) &rest args)
157 (declare (ignore type args))
160 (defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
161 `(reduce #'logior (mklist ,flags)
162 :key #'(lambda (flag)
164 ,@(%map-flags args :symbol-int)
165 (t (error 'type-error :datum ,flags
166 :expected-type '(,type ,@args)))))))
168 (defmethod from-alien-form (int (type (eql 'flags)) &rest args)
169 (declare (ignore type))
171 for mapping in ',(%map-flags args :int-symbol)
172 unless (zerop (logand ,int (first mapping)))
173 collect (second mapping)))
175 (defmethod to-alien-function ((type (eql 'flags)) &rest args)
176 (declare (ignore type))
177 (let ((mappings (%map-flags args :symbol-int)))
179 (reduce #'logior (mklist flags)
180 :key #'(lambda (flag)
182 (second (assoc flag mappings))
183 (error 'type-error :datum flags
184 :expected-type (cons 'flags args))))))))
186 (defmethod from-alien-function ((type (eql 'flags)) &rest args)
187 (declare (ignore type))
188 (let ((mappings (%map-flags args :int-symbol)))
191 for mapping in mappings
192 unless (zerop (logand int (first mapping)))
193 collect (second mapping)))))
195 (defmethod writer-function ((type (eql 'flags)) &rest args)
196 (declare (ignore type))
197 (let ((writer (writer-function 'unsigned))
198 (function (apply #'to-alien-function 'flags args)))
199 #'(lambda (flags location &optional (offset 0))
200 (funcall writer (funcall function flags) location offset))))
202 (defmethod reader-function ((type (eql 'flags)) &rest args)
203 (declare (ignore type))
204 (let ((reader (reader-function 'unsigned))
205 (function (apply #'from-alien-function 'flags args)))
206 #'(lambda (location &optional (offset 0))
207 (funcall function (funcall reader location offset)))))
210 ;;;; Named flags types
212 (defmacro define-flags-type (name &rest args)
213 (let ((flags-int (intern (format nil "~A-TO-INT" name)))
214 (int-flags (intern (format nil "INT-TO-~A" name)))
215 (satisfies (intern (format nil "~A-P" name))))
217 (deftype ,name () '(satisfies ,satisfies))
218 (defun ,satisfies (object)
220 (find ob ',(%map-flags args :symbols))))
222 (symbol (valid-p object))
223 (list (every #'valid-p object)))))
224 (defun ,flags-int (flags)
225 (reduce #'logior (mklist flags)
226 :key #'(lambda (flag)
228 ,@(%map-flags args :symbol-int)
229 (t (error 'type-error :datum flags
230 :expected-type ',name))))))
231 (defun ,int-flags (value)
233 for mapping in ',(%map-flags args :int-symbol)
234 unless (zerop (logand value (first mapping)))
235 collect (second mapping)))
236 (defmethod alien-type ((type (eql ',name)) &rest args)
237 (declare (ignore type args))
239 (defmethod size-of ((type (eql ',name)) &rest args)
240 (declare (ignore type args))
242 (defmethod to-alien-form (form (type (eql ',name)) &rest args)
243 (declare (ignore type args))
244 (list ',flags-int form))
245 (defmethod from-alien-form (form (type (eql ',name)) &rest args)
246 (declare (ignore type args))
247 (list ',int-flags form))
248 (defmethod to-alien-function ((type (eql ',name)) &rest args)
249 (declare (ignore type args))
251 (defmethod from-alien-function ((type (eql ',name)) &rest args)
252 (declare (ignore type args))
254 (defmethod writer-function ((type (eql ',name)) &rest args)
255 (declare (ignore type args))
256 (let ((writer (writer-function 'signed)))
257 #'(lambda (flags location &optional (offset 0))
258 (funcall writer (,flags-int flags) location offset))))
259 (defmethod reader-function ((type (eql ',name)) &rest args)
260 (declare (ignore type args))
261 (let ((reader (reader-function 'signed)))
262 #'(lambda (location &optional (offset 0))
263 (,int-flags (funcall reader location offset))))))))
267 ;;;; Type definition by introspection
269 (defun %query-enum-or-flags-values (query-function class type)
270 (multiple-value-bind (sap length)
271 (funcall query-function (type-class-ref type))
273 (size (proxy-instance-size (find-class class)))
274 (proxy (make-instance class :location sap)))
276 (with-slots (location nickname value) proxy
278 (setq sap (sap+ sap size))
281 (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
287 (defclass %enum-value (struct)
288 ((value :allocation :alien :type int)
289 (name :allocation :alien :type string)
290 (nickname :allocation :alien :type string))
291 (:metaclass static-struct-class))
293 (defbinding %enum-class-values () pointer
295 (n-values unsigned-int :out))
297 (defun query-enum-values (type)
298 (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
301 (defclass %flags-value (struct)
302 ((value :allocation :alien :type unsigned-int)
303 (name :allocation :alien :type string)
304 (nickname :allocation :alien :type string))
305 (:metaclass static-struct-class))
307 (defbinding %flags-class-values () pointer
309 (n-values unsigned-int :out))
311 (defun query-flags-values (type)
312 (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
315 (defun expand-enum-type (type-number forward-p options)
316 (declare (ignore forward-p))
317 (let* ((super (supertype type-number))
318 (type (type-from-number type-number))
319 (mappings (getf options :mappings))
325 (assoc (first mapping) mappings)
326 (rassoc (cdr mapping) mappings :test #'equal)))
328 (query-enum-values type-number)
329 (query-flags-values type-number)))
331 #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
333 (register-type ',type ,(find-type-name type-number))
335 (enum `(define-enum-type ,type ,@expanded-mappings))
336 (flags `(define-flags-type ,type ,@expanded-mappings))))))
339 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
340 (register-derivable-type 'flags "GFlags" 'expand-enum-type)