[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.19 2006-02-26 15:30:01 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)))

(define-type-method alien-type ((type enum))
  (declare (ignore type))
  (alien-type 'signed))

(define-type-method size-of ((type enum))
  (declare (ignore type))
  (size-of 'signed))

(define-type-method to-alien-form ((type enum) form )
  `(case ,form
    ,@(%map-enum (rest (type-expand-to 'enum type)) :symbol-int)
    (t (error 'type-error :datum ,form :expected-type ',type))))

(define-type-method from-alien-form ((type enum) form)
  `(case ,form
    ,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol)))

(define-type-method to-alien-function ((type enum))
  (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :symbol-int)))
    #'(lambda (enum)
	(or
	 (second (assoc enum mappings))
	 (error 'type-error :datum enum :expected-type type)))))

(define-type-method from-alien-function ((type enum))
  (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :int-symbol)))
    #'(lambda (int)
	(second (assoc int mappings)))))

(define-type-method writer-function ((type enum))
  (let ((writer (writer-function 'signed))
	(function (to-alien-function (type-expand-to 'enum type))))
    #'(lambda (enum location &optional (offset 0))
	(funcall writer (funcall function enum) location offset))))
    
(define-type-method reader-function ((type enum))
  (let ((reader (reader-function 'signed))
	(function (from-alien-function (type-expand-to 'enum type))))
    #'(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)))
       (define-type-method to-alien-form ((type ,name) form)
	 (declare (ignore type))
	 (list ',enum-int form))
       (define-type-method from-alien-form ((type ,name) form)
	 (declare (ignore type))
	 (list ',int-enum form))
       (define-type-method to-alien-function ((type ,name))
	 (declare (ignore type))
	 #',enum-int)
       (define-type-method from-alien-function ((type ,name))
	 (declare (ignore type))
	 #',int-enum)
       (define-type-method writer-function ((type ,name))
	 (declare (ignore type))
	 (let ((writer (writer-function 'signed)))
	   #'(lambda (enum location &optional (offset 0))
	       (funcall writer (,enum-int enum) location offset))))    
       (define-type-method reader-function ((type ,name))
	 (declare (ignore type))
	 (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))

(define-type-method alien-type ((type flags))
  (declare (ignore type))
  (alien-type 'unsigned))

(define-type-method size-of ((type flags))
  (declare (ignore type))
  (size-of 'unsigned))

(define-type-method to-alien-form ((type flags) flags)
  `(reduce #'logior (mklist ,flags)
    :key #'(lambda (flag)
	     (case flag
	       ,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int)
	       (t (error 'type-error :datum ,flags :expected-type ',type))))))

(define-type-method from-alien-form ((type flags) value)
  `(loop
    for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol)
    when (= (logand ,value int) int)
    collect symbol))

(define-type-method to-alien-function ((type flags))
  (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :symbol-int)))
    #'(lambda (flags)
	(reduce #'logior (mklist flags)
	 :key #'(lambda (flag)
		  (or
		   (second (assoc flag mappings))
		   (error 'type-error :datum flags :expected-type type)))))))

(define-type-method from-alien-function ((type flags))
  (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :int-symbol)))
    #'(lambda (value)
	(loop
	 for (int symbol) in mappings
	 when (= (logand value int) int)
	 collect symbol))))

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