chiark / gitweb /
Bug fix
[clg] / glib / genums.lisp
... / ...
CommitLineData
1;; Common Lisp bindings for GTK+ v2.x
2;; Copyright 2000-2005 Espen S. Johnsen <espen@users.sf.net>
3;;
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:
11;;
12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
14;;
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.
22
23;; $Id: genums.lisp,v 1.21 2006-09-05 13:20:08 espen Exp $
24
25(in-package "GLIB")
26
27;;;; Definition of enums and flags by introspection
28
29(eval-when (:compile-toplevel :load-toplevel :execute)
30 (defclass enum-value (struct)
31 ((value :allocation :alien :type int)
32 (name :allocation :alien :type string)
33 (nickname :allocation :alien :type string))
34 (:metaclass struct-class)))
35
36(defun map-enum-values (values symbolic-p)
37 (map 'list
38 #'(lambda (enum-value)
39 (with-slots (nickname name value) enum-value
40 (list
41 (if symbolic-p
42 (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
43 name)
44 value)))
45 values))
46
47(defbinding enum-class-values () (static (vector (inlined enum-value) n-values))
48 (class pointer)
49 (n-values unsigned-int :out))
50
51(defbinding flags-class-values () (static (vector (inlined enum-value) n-values))
52 (class pointer)
53 (n-values unsigned-int :out))
54
55(defun query-enum-values (type &optional (symbolic-p t))
56 (let ((class (type-class-ref type)))
57 (map-enum-values (if (eq (supertype type) 'enum)
58 (enum-class-values class)
59 (flags-class-values class))
60 symbolic-p)))
61
62(defun expand-enum-type (type-number forward-p options)
63 (declare (ignore forward-p))
64 (let* ((type (type-from-number type-number))
65 (mappings (getf options :mappings))
66 (expanded-mappings
67 (append
68 (delete-if
69 #'(lambda (mapping)
70 (or
71 (assoc (first mapping) mappings)
72 (rassoc (cdr mapping) mappings :test #'equal)))
73 (query-enum-values type-number))
74 (remove-if
75 #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
76 `(progn
77 (register-type ',type ',(find-type-init-function type-number))
78 ,(ecase (supertype type-number)
79 (enum `(define-enum-type ,type ,@expanded-mappings))
80 (flags `(define-flags-type ,type ,@expanded-mappings))))))
81
82
83(register-derivable-type 'enum "GEnum" 'expand-enum-type)
84(register-derivable-type 'flags "GFlags" 'expand-enum-type)
85