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