[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
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
4d1fea77	23	;; $Id: genums.lisp,v 1.19 2006/02/26 15:30:01 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)))
6baf860c	44
4d1fea77	45	(define-type-method alien-type ((type enum))
4d1fea77	46	(declare (ignore type))
6baf860c	47	(alien-type 'signed))
6baf860c	48
4d1fea77	49	(define-type-method size-of ((type enum))
4d1fea77	50	(declare (ignore type))
6baf860c	51	(size-of 'signed))
6baf860c	52
4d1fea77	53	(define-type-method to-alien-form ((type enum) form )
564b73ea	54	`(case ,form
4d1fea77	55	,@(%map-enum (rest (type-expand-to 'enum type)) :symbol-int)
4d1fea77	56	(t (error 'type-error :datum ,form :expected-type ',type))))
5e6fa40e	57
4d1fea77	58	(define-type-method from-alien-form ((type enum) form)
1ce06bbe	59	`(case ,form
4d1fea77	60	,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol)))
6baf860c	61
4d1fea77	62	(define-type-method to-alien-function ((type enum))
4d1fea77	63	(let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :symbol-int)))
6baf860c	64	#'(lambda (enum)
	65	(or
	66	(second (assoc enum mappings))
4d1fea77	67	(error 'type-error :datum enum :expected-type type)))))
6baf860c	68
4d1fea77	69	(define-type-method from-alien-function ((type enum))
4d1fea77	70	(let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :int-symbol)))
6baf860c	71	#'(lambda (int)
	72	(second (assoc int mappings)))))
	73
4d1fea77	74	(define-type-method writer-function ((type enum))
6baf860c	75	(let ((writer (writer-function 'signed))
4d1fea77	76	(function (to-alien-function (type-expand-to 'enum type))))
6baf860c	77	#'(lambda (enum location &optional (offset 0))
	78	(funcall writer (funcall function enum) location offset))))
	79
4d1fea77	80	(define-type-method reader-function ((type enum))
6baf860c	81	(let ((reader (reader-function 'signed))
4d1fea77	82	(function (from-alien-function (type-expand-to 'enum type))))
0739b019	83	#'(lambda (location &optional (offset 0) weak-p)
0739b019	84	(declare (ignore weak-p))
6baf860c	85	(funcall function (funcall reader location offset)))))
6baf860c	86
f97131c0	87	(defun enum-int (enum type)
f97131c0	88	(funcall (to-alien-function type) enum))
b44caf77	89
f97131c0	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)))
b44caf77	95
f463115b	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))
564b73ea	104	(defun ,enum-int (enum)
	105	(case enum
	106	,@(%map-enum args :symbol-int)
	107	(t (error 'type-error :datum enum :expected-type ',name))))
f463115b	108	(defun ,int-enum (value)
1ce06bbe	109	(case value
1ce06bbe	110	,@(%map-enum args :int-quoted-symbol)))
4d1fea77	111	(define-type-method to-alien-form ((type ,name) form)
4d1fea77	112	(declare (ignore type))
f463115b	113	(list ',enum-int form))
4d1fea77	114	(define-type-method from-alien-form ((type ,name) form)
4d1fea77	115	(declare (ignore type))
f463115b	116	(list ',int-enum form))
4d1fea77	117	(define-type-method to-alien-function ((type ,name))
4d1fea77	118	(declare (ignore type))
f463115b	119	#',enum-int)
4d1fea77	120	(define-type-method from-alien-function ((type ,name))
4d1fea77	121	(declare (ignore type))
f463115b	122	#',int-enum)
4d1fea77	123	(define-type-method writer-function ((type ,name))
4d1fea77	124	(declare (ignore type))
f463115b	125	(let ((writer (writer-function 'signed)))
	126	#'(lambda (enum location &optional (offset 0))
	127	(funcall writer (,enum-int enum) location offset))))
4d1fea77	128	(define-type-method reader-function ((type ,name))
4d1fea77	129	(declare (ignore type))
f463115b	130	(let ((reader (reader-function 'signed)))
0739b019	131	#'(lambda (location &optional (offset 0) weak-p)
0739b019	132	(declare (ignore weak-p))
f463115b	133	(,int-enum (funcall reader location offset))))))))
	134
	135
6baf860c	136	;;;; Generic flags type
b44caf77	137
564b73ea	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
1ce06bbe	146	(:symbol-int `(,symbol ,value))
1ce06bbe	147	(:int-symbol `(,value ,symbol))
564b73ea	148	(:symbols symbol)))))
564b73ea	149
b44caf77	150	(deftype flags (&rest args)
564b73ea	151	`(or (member ,@(%map-flags args :symbols)) list))
6baf860c	152
4d1fea77	153	(define-type-method alien-type ((type flags))
4d1fea77	154	(declare (ignore type))
6baf860c	155	(alien-type 'unsigned))
6baf860c	156
4d1fea77	157	(define-type-method size-of ((type flags))
4d1fea77	158	(declare (ignore type))
6baf860c	159	(size-of 'unsigned))
6baf860c	160
4d1fea77	161	(define-type-method to-alien-form ((type flags) flags)
564b73ea	162	`(reduce #'logior (mklist ,flags)
	163	:key #'(lambda (flag)
	164	(case flag
4d1fea77	165	,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int)
4d1fea77	166	(t (error 'type-error :datum ,flags :expected-type ',type))))))
6baf860c	167
4d1fea77	168	(define-type-method from-alien-form ((type flags) value)
6baf860c	169	`(loop
4d1fea77	170	for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol)
688630cc	171	when (= (logand ,value int) int)
688630cc	172	collect symbol))
6baf860c	173
4d1fea77	174	(define-type-method to-alien-function ((type flags))
4d1fea77	175	(let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :symbol-int)))
564b73ea	176	#'(lambda (flags)
	177	(reduce #'logior (mklist flags)
	178	:key #'(lambda (flag)
	179	(or
	180	(second (assoc flag mappings))
4d1fea77	181	(error 'type-error :datum flags :expected-type type)))))))
6baf860c	182
4d1fea77	183	(define-type-method from-alien-function ((type flags))
4d1fea77	184	(let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :int-symbol)))
688630cc	185	#'(lambda (value)
6baf860c	186	(loop
688630cc	187	for (int symbol) in mappings
	188	when (= (logand value int) int)
	189	collect symbol))))
6baf860c	190
4d1fea77	191	(define-type-method writer-function ((type flags))
6baf860c	192	(let ((writer (writer-function 'unsigned))
4d1fea77	193	(function (to-alien-function (type-expand-to 'flags type))))
6baf860c	194	#'(lambda (flags location &optional (offset 0))
	195	(funcall writer (funcall function flags) location offset))))
	196
4d1fea77	197	(define-type-method reader-function ((type flags))
6baf860c	198	(let ((reader (reader-function 'unsigned))
4d1fea77	199	(function (from-alien-function (type-expand-to 'flags type))))
0739b019	200	#'(lambda (location &optional (offset 0) weak-p)
0739b019	201	(declare (ignore weak-p))
6baf860c	202	(funcall function (funcall reader location offset)))))
	203
	204
f463115b	205	;;;; Named flags types
3a935dfa	206
f463115b	207	(defmacro define-flags-type (name &rest args)
f463115b	208	(let ((flags-int (intern (format nil "~A-TO-INT" name)))
564b73ea	209	(int-flags (intern (format nil "INT-TO-~A" name)))
564b73ea	210	(satisfies (intern (format nil "~A-P" name))))
f463115b	211	`(progn
564b73ea	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))))))
f463115b	226	(defun ,int-flags (value)
564b73ea	227	(loop
688630cc	228	for (int symbol) in ',(%map-flags args :int-symbol)
	229	when(= (logand value int) int)
	230	collect symbol))
4d1fea77	231	(define-type-method alien-type ((type ,name))
4d1fea77	232	(declare (ignore type))
564b73ea	233	(alien-type 'flags))
4d1fea77	234	(define-type-method size-of ((type ,name))
4d1fea77	235	(declare (ignore type))
564b73ea	236	(size-of 'flags))
4d1fea77	237	(define-type-method to-alien-form ((type ,name) form)
4d1fea77	238	(declare (ignore type))
f463115b	239	(list ',flags-int form))
4d1fea77	240	(define-type-method from-alien-form ((type ,name) form)
4d1fea77	241	(declare (ignore type))
f463115b	242	(list ',int-flags form))
4d1fea77	243	(define-type-method to-alien-function ((type ,name))
4d1fea77	244	(declare (ignore type))
f463115b	245	#',flags-int)
4d1fea77	246	(define-type-method from-alien-function ((type ,name))
4d1fea77	247	(declare (ignore type))
f463115b	248	#',int-flags)
4d1fea77	249	(define-type-method writer-function ((type ,name))
4d1fea77	250	(declare (ignore type))
f463115b	251	(let ((writer (writer-function 'signed)))
f463115b	252	#'(lambda (flags location &optional (offset 0))
4d1fea77	253	(funcall writer (,flags-int flags) location offset))))
	254	(define-type-method reader-function ((type ,name))
	255	(declare (ignore type))
f463115b	256	(let ((reader (reader-function 'signed)))
0739b019	257	#'(lambda (location &optional (offset 0) weak-p)
0739b019	258	(declare (ignore weak-p))
f463115b	259	(,int-flags (funcall reader location offset))))))))
	260
	261
	262
	263	;;;; Type definition by introspection
3a935dfa	264
564b73ea	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)
7ce0497d	269	(size (foreign-size (find-class class)))
1d06a422	270	(proxy (ensure-proxy-instance class sap)))
564b73ea	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
e9934f39	311	(defun expand-enum-type (type-number forward-p options)
145300db	312	(declare (ignore forward-p))
3a935dfa	313	(let* ((super (supertype type-number))
3a935dfa	314	(type (type-from-number type-number))
6895c081	315	(mappings (getf options :mappings))
3a935dfa	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
dcb31db6	329	(register-type ',type ',(find-type-init-function type-number))
f463115b	330	,(ecase super
	331	(enum `(define-enum-type ,type ,@expanded-mappings))
	332	(flags `(define-flags-type ,type ,@expanded-mappings))))))
3a935dfa	333
3a935dfa	334
6895c081	335	(register-derivable-type 'enum "GEnum" 'expand-enum-type)
6895c081	336	(register-derivable-type 'flags "GFlags" 'expand-enum-type)
b44caf77	337