[clg] / glib / genums.lisp

;; Common Lisp bindings for GTK+ v2.x
;; Copyright 2000-2005 Espen S. Johnsen <espen@users.sf.net>
;;
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;; $Id: genums.lisp,v 1.14 2005-04-24 13:24:41 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 (value (type (eql 'flags)) &rest args)
  (declare (ignore type))
  `(loop
    for (int symbol)  in ',(%map-flags args :int-symbol)
    when (= (logand ,value int) int)
    collect symbol))

(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 (value)
	(loop
	 for (int symbol) in mappings
	 when (= (logand value int) int)
	 collect symbol))))

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