[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.12 2005/03/06 17:26:23 espen Exp $

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

(defun %map-enum (mappings op)
  (loop
   as value = 0 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 `(,symbol ,value))
	       (:int-symbol `(,value ,symbol))
	       (:int-quoted-symbol `(,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))
  `(case ,form
    ,@(%map-enum args :int-quoted-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)
	 (case value
	   ,@(%map-enum args :int-quoted-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 `(,symbol ,value))
	       (:int-symbol `(,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-init-function 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
dcb31db6	18	;; $Id: genums.lisp,v 1.12 2005/03/06 17:26:23 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)
564b73ea	25	(loop
8bca7df5	26	as value = 0 then (1+ value)
564b73ea	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
1ce06bbe	32	(:symbol-int `(,symbol ,value))
	33	(:int-symbol `(,value ,symbol))
	34	(:int-quoted-symbol `(,value ',symbol))
564b73ea	35	(:symbols symbol)))))
564b73ea	36
b44caf77	37	(deftype enum (&rest args)
6baf860c	38	`(member ,@(%map-enum args :symbols)))
	39
	40	(defmethod alien-type ((type (eql 'enum)) &rest args)
	41	(declare (ignore type args))
	42	(alien-type 'signed))
	43
	44	(defmethod size-of ((type (eql 'enum)) &rest args)
	45	(declare (ignore type args))
	46	(size-of 'signed))
	47
	48	(defmethod to-alien-form (form (type (eql 'enum)) &rest args)
	49	(declare (ignore type))
564b73ea	50	`(case ,form
	51	,@(%map-enum args :symbol-int)
	52	(t (error 'type-error :datum ,form :expected-type '(enum ,@args)))))
	53
6baf860c	54
	55	(defmethod from-alien-form (form (type (eql 'enum)) &rest args)
	56	(declare (ignore type))
1ce06bbe	57	`(case ,form
1ce06bbe	58	,@(%map-enum args :int-quoted-symbol)))
6baf860c	59
6baf860c	60	(defmethod to-alien-function ((type (eql 'enum)) &rest args)
564b73ea	61	(declare (ignore type))
564b73ea	62	(let ((mappings (%map-enum args :symbol-int)))
6baf860c	63	#'(lambda (enum)
	64	(or
	65	(second (assoc enum mappings))
564b73ea	66	(error 'type-error :datum enum :expected-type (cons 'enum args))))))
6baf860c	67
	68	(defmethod from-alien-function ((type (eql 'enum)) &rest args)
	69	(declare (ignore type))
564b73ea	70	(let ((mappings (%map-enum args :int-symbol)))
6baf860c	71	#'(lambda (int)
	72	(second (assoc int mappings)))))
	73
	74	(defmethod writer-function ((type (eql 'enum)) &rest args)
	75	(declare (ignore type))
	76	(let ((writer (writer-function 'signed))
	77	(function (apply #'to-alien-function 'enum args)))
	78	#'(lambda (enum location &optional (offset 0))
	79	(funcall writer (funcall function enum) location offset))))
	80
	81	(defmethod reader-function ((type (eql 'enum)) &rest args)
	82	(declare (ignore type))
	83	(let ((reader (reader-function 'signed))
	84	(function (apply #'from-alien-function 'enum args)))
	85	#'(lambda (location &optional (offset 0))
	86	(funcall function (funcall reader location offset)))))
	87
f97131c0	88	(defun enum-int (enum type)
f97131c0	89	(funcall (to-alien-function type) enum))
b44caf77	90
f97131c0	91	(defun int-enum (int type)
	92	(funcall (from-alien-function type) int))
	93
	94	(defun enum-mapping (type)
	95	(rest (type-expand-to 'enum type)))
b44caf77	96
f463115b	97
	98	;;;; Named enum types
	99
	100	(defmacro define-enum-type (name &rest args)
	101	(let ((enum-int (intern (format nil "~A-TO-INT" name)))
	102	(int-enum (intern (format nil "INT-TO-~A" name))))
	103	`(progn
	104	(deftype ,name () '(enum ,@args))
564b73ea	105	(defun ,enum-int (enum)
	106	(case enum
	107	,@(%map-enum args :symbol-int)
	108	(t (error 'type-error :datum enum :expected-type ',name))))
f463115b	109	(defun ,int-enum (value)
1ce06bbe	110	(case value
1ce06bbe	111	,@(%map-enum args :int-quoted-symbol)))
f463115b	112	(defmethod to-alien-form (form (type (eql ',name)) &rest args)
	113	(declare (ignore type args))
	114	(list ',enum-int form))
	115	(defmethod from-alien-form (form (type (eql ',name)) &rest args)
	116	(declare (ignore type args))
	117	(list ',int-enum form))
	118	(defmethod to-alien-function ((type (eql ',name)) &rest args)
	119	(declare (ignore type args))
	120	#',enum-int)
	121	(defmethod from-alien-function ((type (eql ',name)) &rest args)
	122	(declare (ignore type args))
	123	#',int-enum)
	124	(defmethod writer-function ((type (eql ',name)) &rest args)
	125	(declare (ignore type args))
	126	(let ((writer (writer-function 'signed)))
	127	#'(lambda (enum location &optional (offset 0))
	128	(funcall writer (,enum-int enum) location offset))))
	129	(defmethod reader-function ((type (eql ',name)) &rest args)
	130	(declare (ignore type args))
	131	(let ((reader (reader-function 'signed)))
	132	#'(lambda (location &optional (offset 0))
	133	(,int-enum (funcall reader location offset))))))))
	134
	135
6baf860c	136	;;;; Generic flags type
b44caf77	137
564b73ea	138	(defun %map-flags (mappings op)
	139	(loop
	140	as value = 1 then (ash value 1)
	141	for mapping in mappings
	142	collect (let ((symbol (if (atom mapping) mapping (first mapping))))
	143	(unless (atom mapping)
	144	(setq value (second mapping)))
	145	(ecase op
1ce06bbe	146	(:symbol-int `(,symbol ,value))
1ce06bbe	147	(:int-symbol `(,value ,symbol))
564b73ea	148	(:symbols symbol)))))
564b73ea	149
b44caf77	150	(deftype flags (&rest args)
564b73ea	151	`(or (member ,@(%map-flags args :symbols)) list))
6baf860c	152
	153	(defmethod alien-type ((type (eql 'flags)) &rest args)
	154	(declare (ignore type args))
	155	(alien-type 'unsigned))
	156
	157	(defmethod size-of ((type (eql 'flags)) &rest args)
	158	(declare (ignore type args))
	159	(size-of 'unsigned))
	160
	161	(defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
564b73ea	162	`(reduce #'logior (mklist ,flags)
	163	:key #'(lambda (flag)
	164	(case flag
	165	,@(%map-flags args :symbol-int)
	166	(t (error 'type-error :datum ,flags
	167	:expected-type '(,type ,@args)))))))
6baf860c	168
	169	(defmethod from-alien-form (int (type (eql 'flags)) &rest args)
	170	(declare (ignore type))
	171	`(loop
564b73ea	172	for mapping in ',(%map-flags args :int-symbol)
145300db	173	unless (zerop (logand ,int (first mapping)))
6baf860c	174	collect (second mapping)))
	175
	176	(defmethod to-alien-function ((type (eql 'flags)) &rest args)
564b73ea	177	(declare (ignore type))
	178	(let ((mappings (%map-flags args :symbol-int)))
	179	#'(lambda (flags)
	180	(reduce #'logior (mklist flags)
	181	:key #'(lambda (flag)
	182	(or
	183	(second (assoc flag mappings))
	184	(error 'type-error :datum flags
	185	:expected-type (cons 'flags args))))))))
6baf860c	186
	187	(defmethod from-alien-function ((type (eql 'flags)) &rest args)
	188	(declare (ignore type))
564b73ea	189	(let ((mappings (%map-flags args :int-symbol)))
6baf860c	190	#'(lambda (int)
	191	(loop
	192	for mapping in mappings
	193	unless (zerop (logand int (first mapping)))
	194	collect (second mapping)))))
	195
	196	(defmethod writer-function ((type (eql 'flags)) &rest args)
	197	(declare (ignore type))
	198	(let ((writer (writer-function 'unsigned))
	199	(function (apply #'to-alien-function 'flags args)))
	200	#'(lambda (flags location &optional (offset 0))
	201	(funcall writer (funcall function flags) location offset))))
	202
	203	(defmethod reader-function ((type (eql 'flags)) &rest args)
	204	(declare (ignore type))
	205	(let ((reader (reader-function 'unsigned))
	206	(function (apply #'from-alien-function 'flags args)))
	207	#'(lambda (location &optional (offset 0))
	208	(funcall function (funcall reader location offset)))))
	209
	210
f463115b	211	;;;; Named flags types
3a935dfa	212
f463115b	213	(defmacro define-flags-type (name &rest args)
f463115b	214	(let ((flags-int (intern (format nil "~A-TO-INT" name)))
564b73ea	215	(int-flags (intern (format nil "INT-TO-~A" name)))
564b73ea	216	(satisfies (intern (format nil "~A-P" name))))
f463115b	217	`(progn
564b73ea	218	(deftype ,name () '(satisfies ,satisfies))
	219	(defun ,satisfies (object)
	220	(flet ((valid-p (ob)
	221	(find ob ',(%map-flags args :symbols))))
	222	(typecase object
	223	(symbol (valid-p object))
	224	(list (every #'valid-p object)))))
	225	(defun ,flags-int (flags)
	226	(reduce #'logior (mklist flags)
	227	:key #'(lambda (flag)
	228	(case flag
	229	,@(%map-flags args :symbol-int)
	230	(t (error 'type-error :datum flags
	231	:expected-type ',name))))))
f463115b	232	(defun ,int-flags (value)
564b73ea	233	(loop
	234	for mapping in ',(%map-flags args :int-symbol)
	235	unless (zerop (logand value (first mapping)))
	236	collect (second mapping)))
	237	(defmethod alien-type ((type (eql ',name)) &rest args)
	238	(declare (ignore type args))
	239	(alien-type 'flags))
	240	(defmethod size-of ((type (eql ',name)) &rest args)
	241	(declare (ignore type args))
	242	(size-of 'flags))
f463115b	243	(defmethod to-alien-form (form (type (eql ',name)) &rest args)
	244	(declare (ignore type args))
	245	(list ',flags-int form))
	246	(defmethod from-alien-form (form (type (eql ',name)) &rest args)
	247	(declare (ignore type args))
	248	(list ',int-flags form))
	249	(defmethod to-alien-function ((type (eql ',name)) &rest args)
	250	(declare (ignore type args))
	251	#',flags-int)
	252	(defmethod from-alien-function ((type (eql ',name)) &rest args)
	253	(declare (ignore type args))
	254	#',int-flags)
	255	(defmethod writer-function ((type (eql ',name)) &rest args)
	256	(declare (ignore type args))
	257	(let ((writer (writer-function 'signed)))
	258	#'(lambda (flags location &optional (offset 0))
	259	(funcall writer (,flags-int flags) location offset))))
	260	(defmethod reader-function ((type (eql ',name)) &rest args)
	261	(declare (ignore type args))
	262	(let ((reader (reader-function 'signed)))
	263	#'(lambda (location &optional (offset 0))
	264	(,int-flags (funcall reader location offset))))))))
	265
	266
	267
	268	;;;; Type definition by introspection
3a935dfa	269
564b73ea	270	(defun %query-enum-or-flags-values (query-function class type)
	271	(multiple-value-bind (sap length)
	272	(funcall query-function (type-class-ref type))
	273	(let ((values nil)
	274	(size (proxy-instance-size (find-class class)))
	275	(proxy (make-instance class :location sap)))
	276	(dotimes (i length)
	277	(with-slots (location nickname value) proxy
	278	(setf location sap)
	279	(setq sap (sap+ sap size))
	280	(push
	281	(list
	282	(intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
	283	value)
	284	values)))
	285	values)))
	286
	287
	288	(defclass %enum-value (struct)
	289	((value :allocation :alien :type int)
	290	(name :allocation :alien :type string)
	291	(nickname :allocation :alien :type string))
	292	(:metaclass static-struct-class))
	293
	294	(defbinding %enum-class-values () pointer
	295	(class pointer)
	296	(n-values unsigned-int :out))
	297
	298	(defun query-enum-values (type)
	299	(%query-enum-or-flags-values #'%enum-class-values '%enum-value type))
	300
	301
	302	(defclass %flags-value (struct)
	303	((value :allocation :alien :type unsigned-int)
	304	(name :allocation :alien :type string)
	305	(nickname :allocation :alien :type string))
	306	(:metaclass static-struct-class))
	307
	308	(defbinding %flags-class-values () pointer
	309	(class pointer)
	310	(n-values unsigned-int :out))
	311
	312	(defun query-flags-values (type)
	313	(%query-enum-or-flags-values #'%flags-class-values '%flags-value type))
	314
	315
e9934f39	316	(defun expand-enum-type (type-number forward-p options)
145300db	317	(declare (ignore forward-p))
3a935dfa	318	(let* ((super (supertype type-number))
3a935dfa	319	(type (type-from-number type-number))
6895c081	320	(mappings (getf options :mappings))
3a935dfa	321	(expanded-mappings
	322	(append
	323	(delete-if
	324	#'(lambda (mapping)
	325	(or
	326	(assoc (first mapping) mappings)
	327	(rassoc (cdr mapping) mappings :test #'equal)))
	328	(if (eq super 'enum)
	329	(query-enum-values type-number)
	330	(query-flags-values type-number)))
	331	(remove-if
	332	#'(lambda (mapping) (eq (second mapping) nil)) mappings))))
	333	`(progn
dcb31db6	334	(register-type ',type ',(find-type-init-function type-number))
f463115b	335	,(ecase super
	336	(enum `(define-enum-type ,type ,@expanded-mappings))
	337	(flags `(define-flags-type ,type ,@expanded-mappings))))))
3a935dfa	338
3a935dfa	339
6895c081	340	(register-derivable-type 'enum "GEnum" 'expand-enum-type)
6895c081	341	(register-derivable-type 'flags "GFlags" 'expand-enum-type)
b44caf77	342