[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
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
dfa4f314	18	;; $Id: genums.lisp,v 1.12 2005-03-06 17:26:23 espen Exp $
94f15c3c	19
94f15c3c	20	(in-package "GLIB")
d4b21b08	21
9adccb27	22	;;;; Generic enum type
94f15c3c	23
33939600	24	(defun %map-enum (mappings op)
33939600	25	(loop
c96c452a	26	as value = 0 then (1+ value)
33939600	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
a9acf424	32	(:symbol-int `(,symbol ,value))
	33	(:int-symbol `(,value ,symbol))
	34	(:int-quoted-symbol `(,value ',symbol))
33939600	35	(:symbols symbol)))))
33939600	36
94f15c3c	37	(deftype enum (&rest args)
9adccb27	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))
33939600	50	`(case ,form
	51	,@(%map-enum args :symbol-int)
	52	(t (error 'type-error :datum ,form :expected-type '(enum ,@args)))))
	53
9adccb27	54
	55	(defmethod from-alien-form (form (type (eql 'enum)) &rest args)
	56	(declare (ignore type))
a9acf424	57	`(case ,form
a9acf424	58	,@(%map-enum args :int-quoted-symbol)))
9adccb27	59
9adccb27	60	(defmethod to-alien-function ((type (eql 'enum)) &rest args)
33939600	61	(declare (ignore type))
33939600	62	(let ((mappings (%map-enum args :symbol-int)))
9adccb27	63	#'(lambda (enum)
	64	(or
	65	(second (assoc enum mappings))
33939600	66	(error 'type-error :datum enum :expected-type (cons 'enum args))))))
9adccb27	67
	68	(defmethod from-alien-function ((type (eql 'enum)) &rest args)
	69	(declare (ignore type))
33939600	70	(let ((mappings (%map-enum args :int-symbol)))
9adccb27	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
487aa284	88	(defun enum-int (enum type)
487aa284	89	(funcall (to-alien-function type) enum))
94f15c3c	90
487aa284	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)))
94f15c3c	96
bdd137d2	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))
33939600	105	(defun ,enum-int (enum)
	106	(case enum
	107	,@(%map-enum args :symbol-int)
	108	(t (error 'type-error :datum enum :expected-type ',name))))
bdd137d2	109	(defun ,int-enum (value)
a9acf424	110	(case value
a9acf424	111	,@(%map-enum args :int-quoted-symbol)))
bdd137d2	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
9adccb27	136	;;;; Generic flags type
94f15c3c	137
33939600	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
a9acf424	146	(:symbol-int `(,symbol ,value))
a9acf424	147	(:int-symbol `(,value ,symbol))
33939600	148	(:symbols symbol)))))
33939600	149
94f15c3c	150	(deftype flags (&rest args)
33939600	151	`(or (member ,@(%map-flags args :symbols)) list))
9adccb27	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)
33939600	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)))))))
9adccb27	168
	169	(defmethod from-alien-form (int (type (eql 'flags)) &rest args)
	170	(declare (ignore type))
	171	`(loop
33939600	172	for mapping in ',(%map-flags args :int-symbol)
466cf192	173	unless (zerop (logand ,int (first mapping)))
9adccb27	174	collect (second mapping)))
	175
	176	(defmethod to-alien-function ((type (eql 'flags)) &rest args)
33939600	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))))))))
9adccb27	186
	187	(defmethod from-alien-function ((type (eql 'flags)) &rest args)
	188	(declare (ignore type))
33939600	189	(let ((mappings (%map-flags args :int-symbol)))
9adccb27	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
bdd137d2	211	;;;; Named flags types
d4b21b08	212
bdd137d2	213	(defmacro define-flags-type (name &rest args)
bdd137d2	214	(let ((flags-int (intern (format nil "~A-TO-INT" name)))
33939600	215	(int-flags (intern (format nil "INT-TO-~A" name)))
33939600	216	(satisfies (intern (format nil "~A-P" name))))
bdd137d2	217	`(progn
33939600	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))))))
bdd137d2	232	(defun ,int-flags (value)
33939600	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))
bdd137d2	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
d4b21b08	269
33939600	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
62f12808	316	(defun expand-enum-type (type-number forward-p options)
466cf192	317	(declare (ignore forward-p))
d4b21b08	318	(let* ((super (supertype type-number))
d4b21b08	319	(type (type-from-number type-number))
b0bb0027	320	(mappings (getf options :mappings))
d4b21b08	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
dfa4f314	334	(register-type ',type ',(find-type-init-function type-number))
bdd137d2	335	,(ecase super
	336	(enum `(define-enum-type ,type ,@expanded-mappings))
	337	(flags `(define-flags-type ,type ,@expanded-mappings))))))
d4b21b08	338
d4b21b08	339
b0bb0027	340	(register-derivable-type 'enum "GEnum" 'expand-enum-type)
b0bb0027	341	(register-derivable-type 'flags "GFlags" 'expand-enum-type)
94f15c3c	342