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.1 2001/04/29 20:19:25 espen Exp $
23 (defun %map-mappings (args op)
24 (let ((current-value 0))
28 (destructuring-bind (symbol &optional (value current-value))
30 (setf current-value (1+ value))
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))
37 (if (integerp (first args))
44 (deftype enum (&rest args)
45 `(member ,@(%map-mappings args :symbols)))
47 (deftype-method translate-type-spec enum (type-spec)
48 (let ((args (cdr (type-expand-to 'enum type-spec))))
49 (if (integerp (first args))
50 (translate-type-spec `(signed ,(first args)))
51 (translate-type-spec 'signed))))
53 (deftype-method size-of enum (type-spec)
54 (let ((args (cdr (type-expand-to 'enum type-spec))))
55 (if (integerp (first args))
56 (size-of `(signed ,(first args)))
59 (deftype-method translate-to-alien enum (type-spec expr &optional weak-ref)
60 (declare (ignore weak-ref))
61 (let ((args (cdr (type-expand-to 'enum type-spec))))
63 ,@(%map-mappings args :enum-int))))
65 (deftype-method translate-from-alien enum (type-spec expr &optional weak-ref)
66 (declare (ignore weak-ref))
67 (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
68 (declare (ignore name))
70 ,@(%map-mappings args :int-enum))))
72 (setf (alien-type-name 'enum) "GEnum")
74 (eval-when (:compile-toplevel :load-toplevel :execute)
75 (defclass %enum-value (alien-structure)
76 ((value :allocation :alien :type int)
77 (name :allocation :alien :type string)
78 (nickname :allocation :alien :type string))
79 (:metaclass proxy-class)))
81 (defbinding %enum-class-values () (glist %enum-value)
84 (defun %query-enum-values (type-number)
86 #'(lambda (enum-value)
90 #\- #\_ (string-upcase (slot-value enum-value 'nickname))) "KEYWORD")
91 (slot-value enum-value 'value)))
92 (%enum-class-values (type-class-peek type-number))))
94 (defun define-enum-by-query (init-fname &optional name)
95 (let ((type-number (type-init name init-fname)))
96 (unless (= (type-parent type-number) (find-type-number 'enum))
97 (error "~A is not an enum type" (alien-type-name type-number)))
99 (type-class-ref type-number)
100 (setf (find-type-number name) type-number)
101 (let ((expanded (cons 'enum (%query-enum-values type-number)))
102 (name (or name (default-type-name (alien-type-name type-number)))))
106 (unless (zerop (length (cdr whole)))
107 (lisp::do-arg-count-error 'deftype name (cdr whole) nil 0 0))
113 (deftype flags (&rest args)
117 (member ,@(%map-mappings args :symbols))
120 (deftype-method translate-type-spec flags (type-spec)
121 (let ((args (cdr (type-expand-to 'flags type-spec))))
122 (if (integerp (first args))
123 (translate-type-spec `(unsigned ,(first args)))
124 (translate-type-spec 'unsigned))))
126 (deftype-method size-of flags (type-spec)
127 (let ((args (cdr (type-expand-to 'flags type-spec))))
128 (if (integerp (first args))
129 (size-of `(unsigned ,(first args)))
130 (size-of 'unsigned))))
132 (deftype-method translate-to-alien flags (type-spec expr &optional weak-ref)
133 (declare (ignore weak-ref))
134 (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
135 (declare (ignore name))
136 (let ((mappings (%map-mappings args :flags-int))
137 (value (make-symbol "VALUE")))
139 (dolist (flag ,expr ,value)
140 (setq ,value (logior ,value (second (assoc flag ',mappings)))))))))
142 (deftype-method translate-from-alien flags (type-spec expr &optional weak-ref)
143 (declare (ignore weak-ref))
144 (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
145 (declare (ignore name))
146 (let ((mappings (%map-mappings args :int-flags))
147 (result (make-symbol "RESULT")))
148 `(let ((,result nil))
149 (dolist (mapping ',mappings ,result)
150 (unless (zerop (logand ,expr (first mapping)))
151 (push (second mapping) ,result)))))))
153 (setf (alien-type-name 'flags) "GFlags")
156 (eval-when (:compile-toplevel :load-toplevel :execute)
157 (defclass %flags-value (alien-structure)
158 ((value :allocation :alien :type unsigned-int)
159 (name :allocation :alien :type string)
160 (nickname :allocation :alien :type string))
161 (:metaclass proxy-class)))
163 (defbinding %flags-class-values () (glist %flags-value)
166 (defun %query-flags-values (type-number)
168 #'(lambda (flags-value)
172 #\- #\_ (string-upcase (slot-value flags-value 'nickname))) "KEYWORD")
173 (slot-value flags-value 'value)))
174 (%flags-class-values (type-class-peek type-number))))
176 (defun define-flags-by-query (init-fname &optional name)
177 (let ((type-number (type-init nil init-fname)))
178 (unless (= (type-parent type-number) (find-type-number 'flags))
179 (error "~A is not a flags type" (alien-type-name type-number)))
181 (type-class-ref type-number)
182 (setf (find-type-number name) type-number)
183 (let ((expanded (cons 'flags (%query-flags-values type-number)))
184 (name (or name (default-type-name (alien-type-name type-number)))))
188 (unless (zerop (length (cdr whole)))
189 (lisp::do-arg-count-error 'deftype name (cdr whole) nil 0 0))