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