[clg] / glib / genums.lisp

;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;; $Id: genums.lisp,v 1.9 2005/02/11 19:09:38 espen Exp $

(in-package "GLIB")
  
;;;; Generic enum type

(defun %map-enum (mappings op)
  (loop
   as value = 1 then (1+ value)
   for mapping in mappings
   collect (let ((symbol (if (atom mapping) mapping (first mapping))))
	     (unless (atom mapping)
	       (setq value (second mapping)))
	     (ecase op
	       (:symbol-int (list symbol value))
	       (:int-symbol (list value symbol))
	       (:symbols symbol)))))

(deftype enum (&rest args)
  `(member ,@(%map-enum args :symbols)))

(defmethod alien-type ((type (eql 'enum)) &rest args)
  (declare (ignore type args))
  (alien-type 'signed))

(defmethod size-of ((type (eql 'enum)) &rest args)
  (declare (ignore type args))
  (size-of 'signed))

(defmethod to-alien-form (form (type (eql 'enum)) &rest args)
  (declare (ignore type))
  `(case ,form
    ,@(%map-enum args :symbol-int)
    (t (error 'type-error :datum ,form :expected-type '(enum ,@args)))))


(defmethod from-alien-form (form (type (eql 'enum)) &rest args)
  (declare (ignore type))
  `(ecase ,form
    ,@(%map-enum args :int-symbol)))

(defmethod to-alien-function ((type (eql 'enum)) &rest args)
  (declare (ignore type))
  (let ((mappings (%map-enum args :symbol-int)))
    #'(lambda (enum)
	(or
	 (second (assoc enum mappings))
	 (error 'type-error :datum enum :expected-type (cons 'enum args))))))

(defmethod from-alien-function ((type (eql 'enum)) &rest args)
  (declare (ignore type))
  (let ((mappings (%map-enum args :int-symbol)))
    #'(lambda (int)
	(second (assoc int mappings)))))

(defmethod writer-function ((type (eql 'enum)) &rest args)
  (declare (ignore type))
  (let ((writer (writer-function 'signed))
	(function (apply #'to-alien-function 'enum args)))
    #'(lambda (enum location &optional (offset 0))
	(funcall writer (funcall function enum) location offset))))
    
(defmethod reader-function ((type (eql 'enum)) &rest args)
  (declare (ignore type))
  (let ((reader (reader-function 'signed))
	(function (apply #'from-alien-function 'enum args)))
    #'(lambda (location &optional (offset 0))
	(funcall function (funcall reader location offset)))))

(defun enum-int (enum type)
  (funcall (to-alien-function type) enum))

(defun int-enum (int type)
  (funcall (from-alien-function type) int))

(defun enum-mapping (type)
  (rest (type-expand-to 'enum type)))


;;;; Named enum types

(defmacro define-enum-type (name &rest args)
  (let ((enum-int (intern (format nil "~A-TO-INT" name)))
	(int-enum (intern (format nil "INT-TO-~A" name))))
    `(progn
       (deftype ,name () '(enum ,@args))
       (defun ,enum-int (enum)
	 (case enum
	   ,@(%map-enum args :symbol-int)
	   (t (error 'type-error :datum enum :expected-type ',name))))
       (defun ,int-enum (value)
	 (ecase value
	   ,@(%map-enum args :int-symbol)))
       (defmethod to-alien-form (form (type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (list ',enum-int form))
       (defmethod from-alien-form (form (type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (list ',int-enum form))
       (defmethod to-alien-function ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 #',enum-int)
       (defmethod from-alien-function ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 #',int-enum)
       (defmethod writer-function ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (let ((writer (writer-function 'signed)))
	   #'(lambda (enum location &optional (offset 0))
	       (funcall writer (,enum-int enum) location offset))))    
       (defmethod reader-function ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (let ((reader (reader-function 'signed)))
	   #'(lambda (location &optional (offset 0))
	       (,int-enum (funcall reader location offset))))))))


;;;;  Generic flags type

(defun %map-flags (mappings op)
  (loop
   as value = 1 then (ash value 1)
   for mapping in mappings
   collect (let ((symbol (if (atom mapping) mapping (first mapping))))
	     (unless (atom mapping)
	       (setq value (second mapping)))
	     (ecase op
	       (:symbol-int (list symbol value))
	       (:int-symbol (list value symbol))
	       (:symbols symbol)))))

(deftype flags (&rest args)
  `(or (member ,@(%map-flags args :symbols)) list))

(defmethod alien-type ((type (eql 'flags)) &rest args)
  (declare (ignore type args))
  (alien-type 'unsigned))

(defmethod size-of ((type (eql 'flags)) &rest args)
  (declare (ignore type args))
  (size-of 'unsigned))

(defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
  `(reduce #'logior (mklist ,flags)
    :key #'(lambda (flag)
	     (case flag
	       ,@(%map-flags args :symbol-int)
	       (t (error 'type-error :datum ,flags 
		   :expected-type '(,type ,@args)))))))

(defmethod from-alien-form (int (type (eql 'flags)) &rest args)
  (declare (ignore type))
  `(loop
    for mapping in ',(%map-flags args :int-symbol)
    unless (zerop (logand ,int (first mapping)))
    collect (second mapping)))

(defmethod to-alien-function ((type (eql 'flags)) &rest args)
  (declare (ignore type))
  (let ((mappings (%map-flags args :symbol-int)))
    #'(lambda (flags)
	(reduce #'logior (mklist flags)
	 :key #'(lambda (flag)
		  (or
		   (second (assoc flag mappings))
		   (error 'type-error :datum flags 
		    :expected-type (cons 'flags args))))))))

(defmethod from-alien-function ((type (eql 'flags)) &rest args)
  (declare (ignore type))
  (let ((mappings (%map-flags args :int-symbol)))
    #'(lambda (int)
	(loop
	 for mapping in mappings
	 unless (zerop (logand int (first mapping)))
	 collect (second mapping)))))

(defmethod writer-function ((type (eql 'flags)) &rest args)
  (declare (ignore type))
  (let ((writer (writer-function 'unsigned))
	(function (apply #'to-alien-function 'flags args)))
    #'(lambda (flags location &optional (offset 0))
	(funcall writer (funcall function flags) location offset))))
    
(defmethod reader-function ((type (eql 'flags)) &rest args)
  (declare (ignore type))
  (let ((reader (reader-function 'unsigned))
	(function (apply #'from-alien-function 'flags args)))
    #'(lambda (location &optional (offset 0))
	(funcall function (funcall reader location offset)))))


;;;; Named flags types

(defmacro define-flags-type (name &rest args)
  (let ((flags-int (intern (format nil "~A-TO-INT" name)))
	(int-flags (intern (format nil "INT-TO-~A" name)))
	(satisfies  (intern (format nil "~A-P" name))))
    `(progn
       (deftype ,name () '(satisfies ,satisfies))
       (defun ,satisfies (object)
	 (flet ((valid-p (ob)
		  (find ob ',(%map-flags args :symbols))))
	   (typecase object
	     (symbol (valid-p object))
	     (list (every #'valid-p object)))))
       (defun ,flags-int (flags)
	 (reduce #'logior (mklist flags)
	  :key #'(lambda (flag)
		   (case flag
		     ,@(%map-flags args :symbol-int)
		     (t (error 'type-error :datum flags 
		         :expected-type ',name))))))
       (defun ,int-flags (value)
	 (loop
	  for mapping in ',(%map-flags args :int-symbol)
	  unless (zerop (logand value (first mapping)))
	  collect (second mapping)))
       (defmethod alien-type ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (alien-type 'flags))
       (defmethod size-of ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (size-of 'flags))
       (defmethod to-alien-form (form (type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (list ',flags-int form))
       (defmethod from-alien-form (form (type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (list ',int-flags form))
       (defmethod to-alien-function ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 #',flags-int)
       (defmethod from-alien-function ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 #',int-flags)
       (defmethod writer-function ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (let ((writer (writer-function 'signed)))
	   #'(lambda (flags location &optional (offset 0))
	       (funcall writer (,flags-int flags) location offset))))    
       (defmethod reader-function ((type (eql ',name)) &rest args)
	 (declare (ignore type args))
	 (let ((reader (reader-function 'signed)))
	   #'(lambda (location &optional (offset 0))
	       (,int-flags (funcall reader location offset))))))))


;;;; Type definition by introspection

(defun %query-enum-or-flags-values (query-function class type)
  (multiple-value-bind (sap length)
      (funcall query-function (type-class-ref type))
    (let ((values nil)
	  (size (proxy-instance-size (find-class class)))
	  (proxy (make-instance class :location sap)))
      (dotimes (i length)
	(with-slots (location nickname value) proxy
	  (setf location sap)
	  (setq sap (sap+ sap size))
	  (push
	   (list
	    (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
	    value)
	   values)))
      values)))


(defclass %enum-value (struct)
  ((value :allocation :alien :type int)
   (name :allocation :alien :type string)
   (nickname :allocation :alien :type string))
  (:metaclass static-struct-class))

(defbinding %enum-class-values () pointer
  (class pointer)
  (n-values unsigned-int :out))

(defun query-enum-values (type)
  (%query-enum-or-flags-values #'%enum-class-values '%enum-value type))


(defclass %flags-value (struct)
  ((value :allocation :alien :type unsigned-int)
   (name :allocation :alien :type string)
   (nickname :allocation :alien :type string))
  (:metaclass static-struct-class))

(defbinding %flags-class-values () pointer
  (class pointer)
  (n-values unsigned-int :out))

(defun query-flags-values (type)
  (%query-enum-or-flags-values #'%flags-class-values '%flags-value type))


(defun expand-enum-type (type-number forward-p options)
  (declare (ignore forward-p))
  (let* ((super (supertype type-number))
	 (type (type-from-number type-number))
	 (mappings (getf options :mappings))
	 (expanded-mappings
	  (append
	   (delete-if
	    #'(lambda (mapping)
		(or
		 (assoc (first mapping) mappings)
		 (rassoc (cdr mapping) mappings :test #'equal)))
	    (if (eq super 'enum)
		(query-enum-values type-number)
	      (query-flags-values type-number)))
	   (remove-if
	    #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
    `(progn
       (register-type ',type ,(find-type-name type-number))
       ,(ecase super
	  (enum `(define-enum-type ,type ,@expanded-mappings))
	  (flags `(define-flags-type ,type ,@expanded-mappings))))))


(register-derivable-type 'enum "GEnum" 'expand-enum-type)
(register-derivable-type 'flags "GFlags" 'expand-enum-type)
Commit	Line	Data
b44caf77	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
564b73ea	18	;; $Id: genums.lisp,v 1.9 2005/02/11 19:09:38 espen Exp $
b44caf77	19
b44caf77	20	(in-package "GLIB")
3a935dfa	21
6baf860c	22	;;;; Generic enum type
b44caf77	23
564b73ea	24	(defun %map-enum (mappings op)
	25	(loop
	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)))
	31	(ecase op
	32	(:symbol-int (list symbol value))
	33	(:int-symbol (list value symbol))
	34	(:symbols symbol)))))
	35
b44caf77	36	(deftype enum (&rest args)
6baf860c	37	`(member ,@(%map-enum args :symbols)))
	38
	39	(defmethod alien-type ((type (eql 'enum)) &rest args)
	40	(declare (ignore type args))
	41	(alien-type 'signed))
	42
	43	(defmethod size-of ((type (eql 'enum)) &rest args)
	44	(declare (ignore type args))
	45	(size-of 'signed))
	46
	47	(defmethod to-alien-form (form (type (eql 'enum)) &rest args)
	48	(declare (ignore type))
564b73ea	49	`(case ,form
	50	,@(%map-enum args :symbol-int)
	51	(t (error 'type-error :datum ,form :expected-type '(enum ,@args)))))
	52
6baf860c	53
	54	(defmethod from-alien-form (form (type (eql 'enum)) &rest args)
	55	(declare (ignore type))
	56	`(ecase ,form
564b73ea	57	,@(%map-enum args :int-symbol)))
6baf860c	58
6baf860c	59	(defmethod to-alien-function ((type (eql 'enum)) &rest args)
564b73ea	60	(declare (ignore type))
564b73ea	61	(let ((mappings (%map-enum args :symbol-int)))
6baf860c	62	#'(lambda (enum)
	63	(or
	64	(second (assoc enum mappings))
564b73ea	65	(error 'type-error :datum enum :expected-type (cons 'enum args))))))
6baf860c	66
	67	(defmethod from-alien-function ((type (eql 'enum)) &rest args)
	68	(declare (ignore type))
564b73ea	69	(let ((mappings (%map-enum args :int-symbol)))
6baf860c	70	#'(lambda (int)
	71	(second (assoc int mappings)))))
	72
	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))))
	79
	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)))))
	86
f97131c0	87	(defun enum-int (enum type)
f97131c0	88	(funcall (to-alien-function type) enum))
b44caf77	89
f97131c0	90	(defun int-enum (int type)
	91	(funcall (from-alien-function type) int))
	92
	93	(defun enum-mapping (type)
	94	(rest (type-expand-to 'enum type)))
b44caf77	95
f463115b	96
	97	;;;; Named enum types
	98
	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))))
	102	`(progn
	103	(deftype ,name () '(enum ,@args))
564b73ea	104	(defun ,enum-int (enum)
	105	(case enum
	106	,@(%map-enum args :symbol-int)
	107	(t (error 'type-error :datum enum :expected-type ',name))))
f463115b	108	(defun ,int-enum (value)
f463115b	109	(ecase value
564b73ea	110	,@(%map-enum args :int-symbol)))
f463115b	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))
	119	#',enum-int)
	120	(defmethod from-alien-function ((type (eql ',name)) &rest args)
	121	(declare (ignore type args))
	122	#',int-enum)
	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))))))))
	133
	134
6baf860c	135	;;;; Generic flags type
b44caf77	136
564b73ea	137	(defun %map-flags (mappings op)
	138	(loop
	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)))
	144	(ecase op
	145	(:symbol-int (list symbol value))
	146	(:int-symbol (list value symbol))
	147	(:symbols symbol)))))
	148
b44caf77	149	(deftype flags (&rest args)
564b73ea	150	`(or (member ,@(%map-flags args :symbols)) list))
6baf860c	151
	152	(defmethod alien-type ((type (eql 'flags)) &rest args)
	153	(declare (ignore type args))
	154	(alien-type 'unsigned))
	155
	156	(defmethod size-of ((type (eql 'flags)) &rest args)
	157	(declare (ignore type args))
	158	(size-of 'unsigned))
	159
	160	(defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
564b73ea	161	`(reduce #'logior (mklist ,flags)
	162	:key #'(lambda (flag)
	163	(case flag
	164	,@(%map-flags args :symbol-int)
	165	(t (error 'type-error :datum ,flags
	166	:expected-type '(,type ,@args)))))))
6baf860c	167
	168	(defmethod from-alien-form (int (type (eql 'flags)) &rest args)
	169	(declare (ignore type))
	170	`(loop
564b73ea	171	for mapping in ',(%map-flags args :int-symbol)
145300db	172	unless (zerop (logand ,int (first mapping)))
6baf860c	173	collect (second mapping)))
	174
	175	(defmethod to-alien-function ((type (eql 'flags)) &rest args)
564b73ea	176	(declare (ignore type))
	177	(let ((mappings (%map-flags args :symbol-int)))
	178	#'(lambda (flags)
	179	(reduce #'logior (mklist flags)
	180	:key #'(lambda (flag)
	181	(or
	182	(second (assoc flag mappings))
	183	(error 'type-error :datum flags
	184	:expected-type (cons 'flags args))))))))
6baf860c	185
	186	(defmethod from-alien-function ((type (eql 'flags)) &rest args)
	187	(declare (ignore type))
564b73ea	188	(let ((mappings (%map-flags args :int-symbol)))
6baf860c	189	#'(lambda (int)
	190	(loop
	191	for mapping in mappings
	192	unless (zerop (logand int (first mapping)))
	193	collect (second mapping)))))
	194
	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))))
	201
	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)))))
	208
	209
f463115b	210	;;;; Named flags types
3a935dfa	211
f463115b	212	(defmacro define-flags-type (name &rest args)
f463115b	213	(let ((flags-int (intern (format nil "~A-TO-INT" name)))
564b73ea	214	(int-flags (intern (format nil "INT-TO-~A" name)))
564b73ea	215	(satisfies (intern (format nil "~A-P" name))))
f463115b	216	`(progn
564b73ea	217	(deftype ,name () '(satisfies ,satisfies))
	218	(defun ,satisfies (object)
	219	(flet ((valid-p (ob)
	220	(find ob ',(%map-flags args :symbols))))
	221	(typecase object
	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)
	227	(case flag
	228	,@(%map-flags args :symbol-int)
	229	(t (error 'type-error :datum flags
	230	:expected-type ',name))))))
f463115b	231	(defun ,int-flags (value)
564b73ea	232	(loop
	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))
	238	(alien-type 'flags))
	239	(defmethod size-of ((type (eql ',name)) &rest args)
	240	(declare (ignore type args))
	241	(size-of 'flags))
f463115b	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))
	250	#',flags-int)
	251	(defmethod from-alien-function ((type (eql ',name)) &rest args)
	252	(declare (ignore type args))
	253	#',int-flags)
	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))))))))
	264
	265
	266
	267	;;;; Type definition by introspection
3a935dfa	268
564b73ea	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))
	272	(let ((values nil)
	273	(size (proxy-instance-size (find-class class)))
	274	(proxy (make-instance class :location sap)))
	275	(dotimes (i length)
	276	(with-slots (location nickname value) proxy
	277	(setf location sap)
	278	(setq sap (sap+ sap size))
	279	(push
	280	(list
	281	(intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
	282	value)
	283	values)))
	284	values)))
	285
	286
	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))
	292
	293	(defbinding %enum-class-values () pointer
	294	(class pointer)
	295	(n-values unsigned-int :out))
	296
	297	(defun query-enum-values (type)
	298	(%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
	299
	300
	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))
	306
	307	(defbinding %flags-class-values () pointer
	308	(class pointer)
	309	(n-values unsigned-int :out))
	310
	311	(defun query-flags-values (type)
	312	(%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
	313
	314
e9934f39	315	(defun expand-enum-type (type-number forward-p options)
145300db	316	(declare (ignore forward-p))
3a935dfa	317	(let* ((super (supertype type-number))
3a935dfa	318	(type (type-from-number type-number))
6895c081	319	(mappings (getf options :mappings))
3a935dfa	320	(expanded-mappings
	321	(append
	322	(delete-if
	323	#'(lambda (mapping)
	324	(or
	325	(assoc (first mapping) mappings)
	326	(rassoc (cdr mapping) mappings :test #'equal)))
	327	(if (eq super 'enum)
	328	(query-enum-values type-number)
	329	(query-flags-values type-number)))
	330	(remove-if
	331	#'(lambda (mapping) (eq (second mapping) nil)) mappings))))
	332	`(progn
	333	(register-type ',type ,(find-type-name type-number))
f463115b	334	,(ecase super
	335	(enum `(define-enum-type ,type ,@expanded-mappings))
	336	(flags `(define-flags-type ,type ,@expanded-mappings))))))
3a935dfa	337
3a935dfa	338
6895c081	339	(register-derivable-type 'enum "GEnum" 'expand-enum-type)
6895c081	340	(register-derivable-type 'flags "GFlags" 'expand-enum-type)
b44caf77	341