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 | |
b0bb0027 |
18 | ;; $Id: genums.lisp,v 1.3 2001-10-21 22:02:01 espen Exp $ |
94f15c3c |
19 | |
20 | (in-package "GLIB") |
21 | |
22 | |
23 | (defun %map-mappings (args op) |
24 | (let ((current-value 0)) |
25 | (map |
26 | 'list |
27 | #'(lambda (mapping) |
28 | (destructuring-bind (symbol &optional (value current-value)) |
29 | (mklist mapping) |
30 | (setf current-value (1+ value)) |
31 | (case op |
32 | (:enum-int (list symbol value)) |
33 | (:flags-int (list symbol value #|(ash 1 value)|#)) |
34 | (:int-enum (list value symbol)) |
35 | (:int-flags (list value #|(ash 1 value)|# symbol)) |
36 | (:symbols symbol)))) |
37 | (if (integerp (first args)) |
38 | (rest args) |
39 | args)))) |
40 | |
d4b21b08 |
41 | (defun %query-enum-or-flags-values (query-function class type) |
42 | (multiple-value-bind (sap length) |
43 | (funcall query-function (type-class-ref type)) |
44 | (let ((values nil) |
45 | (size (proxy-class-size (find-class class))) |
46 | (proxy (make-proxy-instance class sap nil))) |
47 | (dotimes (i length) |
48 | (with-slots (location nickname value) proxy |
49 | (setf location sap) |
50 | (setq sap (sap+ sap size)) |
51 | (push |
52 | (list |
53 | (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD") |
54 | value) |
55 | values))) |
56 | values))) |
57 | |
58 | |
94f15c3c |
59 | ;;;; Enum type |
60 | |
61 | (deftype enum (&rest args) |
62 | `(member ,@(%map-mappings args :symbols))) |
63 | |
64 | (deftype-method translate-type-spec enum (type-spec) |
65 | (let ((args (cdr (type-expand-to 'enum type-spec)))) |
66 | (if (integerp (first args)) |
67 | (translate-type-spec `(signed ,(first args))) |
68 | (translate-type-spec 'signed)))) |
69 | |
70 | (deftype-method size-of enum (type-spec) |
71 | (let ((args (cdr (type-expand-to 'enum type-spec)))) |
72 | (if (integerp (first args)) |
73 | (size-of `(signed ,(first args))) |
74 | (size-of 'signed)))) |
75 | |
76 | (deftype-method translate-to-alien enum (type-spec expr &optional weak-ref) |
77 | (declare (ignore weak-ref)) |
78 | (let ((args (cdr (type-expand-to 'enum type-spec)))) |
79 | `(ecase ,expr |
80 | ,@(%map-mappings args :enum-int)))) |
81 | |
82 | (deftype-method translate-from-alien enum (type-spec expr &optional weak-ref) |
83 | (declare (ignore weak-ref)) |
84 | (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec) |
85 | (declare (ignore name)) |
86 | `(ecase ,expr |
87 | ,@(%map-mappings args :int-enum)))) |
88 | |
94f15c3c |
89 | (eval-when (:compile-toplevel :load-toplevel :execute) |
d4b21b08 |
90 | (defclass %enum-value (static) |
94f15c3c |
91 | ((value :allocation :alien :type int) |
92 | (name :allocation :alien :type string) |
93 | (nickname :allocation :alien :type string)) |
94 | (:metaclass proxy-class))) |
95 | |
d4b21b08 |
96 | (defbinding %enum-class-values () pointer |
97 | (class pointer) |
98 | (n-values unsigned-int :out)) |
99 | |
100 | (defun query-enum-values (type) |
101 | (%query-enum-or-flags-values #'%enum-class-values '%enum-value type)) |
102 | |
94f15c3c |
103 | |
104 | |
105 | ;;;; Flags type |
106 | |
107 | (deftype flags (&rest args) |
108 | `(or |
109 | null |
110 | (cons |
111 | (member ,@(%map-mappings args :symbols)) |
112 | list))) |
113 | |
114 | (deftype-method translate-type-spec flags (type-spec) |
115 | (let ((args (cdr (type-expand-to 'flags type-spec)))) |
116 | (if (integerp (first args)) |
117 | (translate-type-spec `(unsigned ,(first args))) |
118 | (translate-type-spec 'unsigned)))) |
119 | |
120 | (deftype-method size-of flags (type-spec) |
121 | (let ((args (cdr (type-expand-to 'flags type-spec)))) |
122 | (if (integerp (first args)) |
123 | (size-of `(unsigned ,(first args))) |
124 | (size-of 'unsigned)))) |
125 | |
126 | (deftype-method translate-to-alien flags (type-spec expr &optional weak-ref) |
127 | (declare (ignore weak-ref)) |
128 | (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) |
129 | (declare (ignore name)) |
130 | (let ((mappings (%map-mappings args :flags-int)) |
131 | (value (make-symbol "VALUE"))) |
132 | `(let ((,value 0)) |
133 | (dolist (flag ,expr ,value) |
134 | (setq ,value (logior ,value (second (assoc flag ',mappings))))))))) |
135 | |
136 | (deftype-method translate-from-alien flags (type-spec expr &optional weak-ref) |
137 | (declare (ignore weak-ref)) |
138 | (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) |
139 | (declare (ignore name)) |
140 | (let ((mappings (%map-mappings args :int-flags)) |
141 | (result (make-symbol "RESULT"))) |
142 | `(let ((,result nil)) |
143 | (dolist (mapping ',mappings ,result) |
144 | (unless (zerop (logand ,expr (first mapping))) |
145 | (push (second mapping) ,result))))))) |
146 | |
94f15c3c |
147 | |
148 | |
d4b21b08 |
149 | ;(eval-when (:compile-toplevel :load-toplevel :execute) |
150 | (defclass %flags-value (static) |
94f15c3c |
151 | ((value :allocation :alien :type unsigned-int) |
152 | (name :allocation :alien :type string) |
153 | (nickname :allocation :alien :type string)) |
d4b21b08 |
154 | (:metaclass proxy-class));) |
155 | |
156 | (defbinding %flags-class-values () pointer |
157 | (class pointer) |
158 | (n-values unsigned-int :out)) |
159 | |
160 | (defun query-flags-values (type) |
161 | (%query-enum-or-flags-values #'%flags-class-values '%flags-value type)) |
162 | |
163 | |
164 | |
165 | ;;;; |
166 | |
b0bb0027 |
167 | (defun expand-enum-type (type-number &optional options) |
d4b21b08 |
168 | (let* ((super (supertype type-number)) |
169 | (type (type-from-number type-number)) |
b0bb0027 |
170 | (mappings (getf options :mappings)) |
d4b21b08 |
171 | (expanded-mappings |
172 | (append |
173 | (delete-if |
174 | #'(lambda (mapping) |
175 | (or |
176 | (assoc (first mapping) mappings) |
177 | (rassoc (cdr mapping) mappings :test #'equal))) |
178 | (if (eq super 'enum) |
179 | (query-enum-values type-number) |
180 | (query-flags-values type-number))) |
181 | (remove-if |
182 | #'(lambda (mapping) (eq (second mapping) nil)) mappings)))) |
183 | `(progn |
184 | (register-type ',type ,(find-type-name type-number)) |
185 | (deftype ,type () '(,super ,@expanded-mappings))))) |
186 | |
187 | |
b0bb0027 |
188 | (register-derivable-type 'enum "GEnum" 'expand-enum-type) |
189 | (register-derivable-type 'flags "GFlags" 'expand-enum-type) |
94f15c3c |
190 | |