chiark / gitweb /
Added bindigns to GdkAtom
[clg] / glib / genums.lisp
CommitLineData
94f15c3c 1;; Common Lisp bindings for GTK+ v2.0
2;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
3;;
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.
8;;
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.
13;;
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
17
487aa284 18;; $Id: genums.lisp,v 1.5 2004-12-19 18:18:05 espen Exp $
94f15c3c 19
20(in-package "GLIB")
21
22
9adccb27 23(defun %map-enum (args op)
94f15c3c 24 (let ((current-value 0))
9adccb27 25 (mapcar
94f15c3c 26 #'(lambda (mapping)
27 (destructuring-bind (symbol &optional (value current-value))
28 (mklist mapping)
29 (setf current-value (1+ value))
30 (case op
31 (:enum-int (list symbol value))
9adccb27 32 (:flags-int (list symbol value))
94f15c3c 33 (:int-enum (list value symbol))
9adccb27 34 (:int-flags (list value symbol))
94f15c3c 35 (:symbols symbol))))
9adccb27 36 args)))
94f15c3c 37
d4b21b08 38(defun %query-enum-or-flags-values (query-function class type)
39 (multiple-value-bind (sap length)
40 (funcall query-function (type-class-ref type))
41 (let ((values nil)
9adccb27 42 (size (proxy-instance-size (find-class class)))
43 (proxy (make-instance class :location sap)))
d4b21b08 44 (dotimes (i length)
45 (with-slots (location nickname value) proxy
46 (setf location sap)
47 (setq sap (sap+ sap size))
48 (push
49 (list
50 (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
51 value)
52 values)))
53 values)))
54
55
9adccb27 56;;;; Generic enum type
94f15c3c 57
58(deftype enum (&rest args)
9adccb27 59 `(member ,@(%map-enum args :symbols)))
60
61(defmethod alien-type ((type (eql 'enum)) &rest args)
62 (declare (ignore type args))
63 (alien-type 'signed))
64
65(defmethod size-of ((type (eql 'enum)) &rest args)
66 (declare (ignore type args))
67 (size-of 'signed))
68
69(defmethod to-alien-form (form (type (eql 'enum)) &rest args)
70 (declare (ignore type))
71 `(ecase ,form
72 ,@(%map-enum args :enum-int)))
73
74(defmethod from-alien-form (form (type (eql 'enum)) &rest args)
75 (declare (ignore type))
76 `(ecase ,form
77 ,@(%map-enum args :int-enum)))
78
79(defmethod to-alien-function ((type (eql 'enum)) &rest args)
80 (let ((mappings (%map-enum args :enum-int)))
81 #'(lambda (enum)
82 (or
83 (second (assoc enum mappings))
84 (error "~S is not of type ~S" enum (cons type args))))))
85
86(defmethod from-alien-function ((type (eql 'enum)) &rest args)
87 (declare (ignore type))
88 (let ((mappings (%map-enum args :int-enum)))
89 #'(lambda (int)
90 (second (assoc int mappings)))))
91
92(defmethod writer-function ((type (eql 'enum)) &rest args)
93 (declare (ignore type))
94 (let ((writer (writer-function 'signed))
95 (function (apply #'to-alien-function 'enum args)))
96 #'(lambda (enum location &optional (offset 0))
97 (funcall writer (funcall function enum) location offset))))
98
99(defmethod reader-function ((type (eql 'enum)) &rest args)
100 (declare (ignore type))
101 (let ((reader (reader-function 'signed))
102 (function (apply #'from-alien-function 'enum args)))
103 #'(lambda (location &optional (offset 0))
104 (funcall function (funcall reader location offset)))))
105
106
107
108(defclass %enum-value (struct)
109 ((value :allocation :alien :type int)
110 (name :allocation :alien :type string)
111 (nickname :allocation :alien :type string))
112 (:metaclass static-struct-class))
94f15c3c 113
d4b21b08 114(defbinding %enum-class-values () pointer
115 (class pointer)
116 (n-values unsigned-int :out))
117
118(defun query-enum-values (type)
119 (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
120
487aa284 121(defun enum-int (enum type)
122 (funcall (to-alien-function type) enum))
94f15c3c 123
487aa284 124(defun int-enum (int type)
125 (funcall (from-alien-function type) int))
126
127(defun enum-mapping (type)
128 (rest (type-expand-to 'enum type)))
94f15c3c 129
9adccb27 130;;;; Generic flags type
94f15c3c 131
132(deftype flags (&rest args)
9adccb27 133 `(or null (cons (member ,@(%map-enum args :symbols)) list)))
134
135(defmethod alien-type ((type (eql 'flags)) &rest args)
136 (declare (ignore type args))
137 (alien-type 'unsigned))
138
139(defmethod size-of ((type (eql 'flags)) &rest args)
140 (declare (ignore type args))
141 (size-of 'unsigned))
142
143(defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
144 `(loop
145 with value = 0
146 with flags = ,flags
147 for flag in (mklist flags)
148 do (let ((flagval
149 (or
150 (second (assoc flag ',(%map-enum args :flags-int)))
151 (error "~S is not of type ~S" flags '(,type ,@args)))))
152 (setq value (logior value flagval)))
153 finally (return value)))
154
155(defmethod from-alien-form (int (type (eql 'flags)) &rest args)
156 (declare (ignore type))
157 `(loop
158 for mapping in ',(%map-enum args :int-flags)
159 unless (zerop (logand int (first mapping)))
160 collect (second mapping)))
161
162(defmethod to-alien-function ((type (eql 'flags)) &rest args)
163 (let ((mappings (%map-enum args :flags-int)))
164 #'(lambda (flags)
165 (loop
166 with value = 0
167 for flag in (mklist flags)
168 do (let ((flagval (or
169 (second (assoc flag mappings))
170 (error "~S is not of type ~S" flags (cons type args)))))
171 (setq value (logior value flagval)))
172 finally (return value)))))
173
174(defmethod from-alien-function ((type (eql 'flags)) &rest args)
175 (declare (ignore type))
176 (let ((mappings (%map-enum args :int-flags)))
177 #'(lambda (int)
178 (loop
179 for mapping in mappings
180 unless (zerop (logand int (first mapping)))
181 collect (second mapping)))))
182
183(defmethod writer-function ((type (eql 'flags)) &rest args)
184 (declare (ignore type))
185 (let ((writer (writer-function 'unsigned))
186 (function (apply #'to-alien-function 'flags args)))
187 #'(lambda (flags location &optional (offset 0))
188 (funcall writer (funcall function flags) location offset))))
189
190(defmethod reader-function ((type (eql 'flags)) &rest args)
191 (declare (ignore type))
192 (let ((reader (reader-function 'unsigned))
193 (function (apply #'from-alien-function 'flags args)))
194 #'(lambda (location &optional (offset 0))
195 (funcall function (funcall reader location offset)))))
196
197
198
199(defclass %flags-value (struct)
200 ((value :allocation :alien :type unsigned-int)
201 (name :allocation :alien :type string)
202 (nickname :allocation :alien :type string))
203 (:metaclass static-struct-class))
d4b21b08 204
205(defbinding %flags-class-values () pointer
206 (class pointer)
207 (n-values unsigned-int :out))
208
209(defun query-flags-values (type)
210 (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
211
212
213
214;;;;
215
b0bb0027 216(defun expand-enum-type (type-number &optional options)
d4b21b08 217 (let* ((super (supertype type-number))
218 (type (type-from-number type-number))
b0bb0027 219 (mappings (getf options :mappings))
d4b21b08 220 (expanded-mappings
221 (append
222 (delete-if
223 #'(lambda (mapping)
224 (or
225 (assoc (first mapping) mappings)
226 (rassoc (cdr mapping) mappings :test #'equal)))
227 (if (eq super 'enum)
228 (query-enum-values type-number)
229 (query-flags-values type-number)))
230 (remove-if
231 #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
232 `(progn
233 (register-type ',type ,(find-type-name type-number))
234 (deftype ,type () '(,super ,@expanded-mappings)))))
235
236
b0bb0027 237(register-derivable-type 'enum "GEnum" 'expand-enum-type)
238(register-derivable-type 'flags "GFlags" 'expand-enum-type)
94f15c3c 239