[clg] / gffi / enums.lisp

;; Common Lisp bindings for GTK+ v2.x
;; Copyright 2000-2006 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: enums.lisp,v 1.1 2006-04-25 20:37:49 espen Exp $

(in-package "GFFI")
  
;;;; Generic enum type

(defun %map-enum (mappings op)
  (delete-duplicates 
   (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)))))
   :key #'first :from-end t))

(defun %map-symbols (mappings)
  (mapcar #'(lambda (mapping)
	      (first (mklist mapping)))
	  mappings))

(deftype enum (&rest args)
  `(member ,@(%map-symbols args)))

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

(define-type-method size-of ((type enum) &key (inlined t))
  (assert-inlined type inlined)
  (size-of 'signed))

(define-type-method to-alien-form ((type enum) form &optional copy-p)
  (declare (ignore copy-p))
  `(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 &key ref)
  (declare (ignore ref))
  `(case ,form
    ,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol)))

(define-type-method to-alien-function ((type enum) &optional copy-p)
  (declare (ignore copy-p))
  (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) &key ref)
  (declare (ignore ref))
  (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) &key temp (inlined t))
  (declare (ignore temp))
  (assert-inlined type inlined)
  (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) &key ref (inlined t))
  (declare (ignore ref))
  (assert-inlined type inlined)
  (let ((reader (reader-function 'signed))
	(function (from-alien-function (type-expand-to 'enum type))))
    #'(lambda (location &optional (offset 0))
	(funcall function (funcall reader location offset)))))

(defun enum-int (enum type)
  (funcall (to-alien-function type) enum))

(defun int-enum (int type)
  (funcall (from-alien-function type) int))

(defun enum-mapping (type)
  (rest (type-expand-to 'enum type)))


;;;; Named enum types

(defmacro define-enum-type (name &rest args)
  (let ((enum-int (intern (format nil "~A-TO-INT" name)))
	(int-enum (intern (format nil "INT-TO-~A" name))))
    `(progn
       (deftype ,name () '(enum ,@args))
       (defun ,enum-int (enum)
	 (case enum
	   ,@(%map-enum args :symbol-int)
	   (t (error 'type-error :datum enum :expected-type ',name))))
       (defun ,int-enum (value)
	 (case value
	   ,@(%map-enum args :int-quoted-symbol)))
       (eval-when (:compile-toplevel :load-toplevel :execute)
	 (define-type-method to-alien-form ((type ,name) form &optional copy-p)
	   (declare (ignore type copy-p))
	   (list ',enum-int form))
	 (define-type-method from-alien-form ((type ,name) form &key ref)
	   (declare (ignore type ref))
	   (list ',int-enum form))
	 (define-type-method to-alien-function ((type ,name) &optional copy-p)
	   (declare (ignore type copy-p))
	   #',enum-int)
	 (define-type-method from-alien-function ((type ,name) &key ref)
	   (declare (ignore type ref))
	   #',int-enum)
	 (define-type-method writer-function ((type ,name) &key temp (inlined t))
	   (declare (ignore temp))
	   (assert-inlined type inlined)
	   (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) &key ref (inlined t))
	   (declare (ignore ref))
	   (assert-inlined type inlined)
	   (let ((reader (reader-function 'signed)))
	     #'(lambda (location &optional (offset 0))
		 (,int-enum (funcall reader location offset)))))))))


;;;;  Generic flags type

(defun %map-flags (mappings op)
  (delete-duplicates
   (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)))
	      (case op
		(:symbol-int `(,symbol ,value))
		(:int-symbol `(,value ,symbol)))))
   :key #'first :from-end t))

(deftype flags (&rest args)
  `(or (member ,@(%map-symbols args)) list))

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

(define-type-method size-of ((type flags) &key (inlined t))
  (assert-inlined type inlined)
  (size-of 'unsigned))

(define-type-method to-alien-form ((type flags) flags &optional copy-p)
  (declare (ignore copy-p))
  `(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 &key ref)
  (declare (ignore ref))
  `(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) &optional copy-p)
  (declare (ignore copy-p))
  (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) &key ref)
  (declare (ignore ref))
  (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) &key temp (inlined t))
  (declare (ignore temp))
  (assert-inlined type inlined)
  (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) &key ref (inlined t))
  (declare (ignore ref))
  (assert-inlined type inlined)
  (let ((reader (reader-function 'unsigned))
	(function (from-alien-function (type-expand-to 'flags type))))
    #'(lambda (location &optional (offset 0))
	(funcall function (funcall reader location offset)))))


;;;; Named flags types

(defmacro define-flags-type (name &rest args)
  (let ((flags-int (intern (format nil "~A-TO-INT" name)))
	(int-flags (intern (format nil "INT-TO-~A" name)))
	(satisfies  (intern (format nil "~A-P" name))))
    `(progn
       (deftype ,name () '(satisfies ,satisfies))
       (defun ,satisfies (object)
	 (flet ((valid-p (ob)
		  (find ob ',(%map-symbols args))))
	   (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))
       (eval-when (:compile-toplevel :load-toplevel :execute)
	 (define-type-method alien-type ((type ,name))
	   (declare (ignore type))
	   (alien-type 'flags))
	 (define-type-method size-of ((type ,name) &key (inlined t))
	   (assert-inlined type inlined)
	   (size-of 'flags))
	 (define-type-method to-alien-form ((type ,name) form &optional copy-p)
	   (declare (ignore type copy-p))
	   (list ',flags-int form))
	 (define-type-method from-alien-form ((type ,name) form &key ref)
	   (declare (ignore type ref))
	   (list ',int-flags form))
	 (define-type-method to-alien-function ((type ,name) &optional copy-p)
	   (declare (ignore type copy-p))
	   #',flags-int)
	 (define-type-method from-alien-function ((type ,name) &key ref)
	   (declare (ignore type ref))
	   #',int-flags)
	 (define-type-method writer-function ((type ,name) &key temp (inlined t))
	   (declare (ignore temp))
	   (assert-inlined type inlined)
	   (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) &key ref (inlined t))
	   (declare (ignore ref))
	   (assert-inlined type inlined)
	   (let ((reader (reader-function 'signed)))
	     #'(lambda (location &optional (offset 0))
		 (,int-flags (funcall reader location offset)))))))))


(defexport define-enum-type (name &rest args)
  (declare (ignore args))
  name)

(defexport define-flags-type (name &rest args)
  (declare (ignore args))
  name)
Commit	Line	Data
e6813115	1	;; Common Lisp bindings for GTK+ v2.x
	2	;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
	3	;;
	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:
	11	;;
	12	;; The above copyright notice and this permission notice shall be
	13	;; included in all copies or substantial portions of the Software.
	14	;;
	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.
	22
	23	;; $Id: enums.lisp,v 1.1 2006-04-25 20:37:49 espen Exp $
	24
	25	(in-package "GFFI")
	26
	27	;;;; Generic enum type
	28
	29	(defun %map-enum (mappings op)
	30	(delete-duplicates
	31	(loop
	32	as value = 0 then (1+ value)
	33	for mapping in mappings
	34	collect (let ((symbol (if (atom mapping) mapping (first mapping))))
	35	(unless (atom mapping)
	36	(setq value (second mapping)))
	37	(ecase op
	38	(:symbol-int `(,symbol ,value))
	39	(:int-symbol `(,value ,symbol))
	40	(:int-quoted-symbol `(,value ',symbol)))))
	41	:key #'first :from-end t))
	42
	43	(defun %map-symbols (mappings)
	44	(mapcar #'(lambda (mapping)
	45	(first (mklist mapping)))
	46	mappings))
	47
	48	(deftype enum (&rest args)
	49	`(member ,@(%map-symbols args)))
	50
	51	(define-type-method alien-type ((type enum))
	52	(declare (ignore type))
	53	(alien-type 'signed))
	54
	55	(define-type-method size-of ((type enum) &key (inlined t))
	56	(assert-inlined type inlined)
	57	(size-of 'signed))
	58
	59	(define-type-method to-alien-form ((type enum) form &optional copy-p)
	60	(declare (ignore copy-p))
	61	`(case ,form
	62	,@(%map-enum (rest (type-expand-to 'enum type)) :symbol-int)
	63	(t (error 'type-error :datum ,form :expected-type ',type))))
	64
65	(define-type-method from-alien-form ((type enum) form &key ref)
66	(declare (ignore ref))
67	`(case ,form
68	,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol)))
69
70	(define-type-method to-alien-function ((type enum) &optional copy-p)
71	(declare (ignore copy-p))
72	(let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :symbol-int)))
73	#'(lambda (enum)
74	(or
75	(second (assoc enum mappings))
76	(error 'type-error :datum enum :expected-type type)))))
77
78	(define-type-method from-alien-function ((type enum) &key ref)
79	(declare (ignore ref))
80	(let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :int-symbol)))
81	#'(lambda (int)
82	(second (assoc int mappings)))))
83
84	(define-type-method writer-function ((type enum) &key temp (inlined t))
85	(declare (ignore temp))
86	(assert-inlined type inlined)
87	(let ((writer (writer-function 'signed))
88	(function (to-alien-function (type-expand-to 'enum type))))
89	#'(lambda (enum location &optional (offset 0))
90	(funcall writer (funcall function enum) location offset))))
91
92	(define-type-method reader-function ((type enum) &key ref (inlined t))
93	(declare (ignore ref))
94	(assert-inlined type inlined)
95	(let ((reader (reader-function 'signed))
96	(function (from-alien-function (type-expand-to 'enum type))))
97	#'(lambda (location &optional (offset 0))
98	(funcall function (funcall reader location offset)))))
99
100	(defun enum-int (enum type)
101	(funcall (to-alien-function type) enum))
102
103	(defun int-enum (int type)
104	(funcall (from-alien-function type) int))
105
106	(defun enum-mapping (type)
107	(rest (type-expand-to 'enum type)))
108
109
110	;;;; Named enum types
111
112	(defmacro define-enum-type (name &rest args)
113	(let ((enum-int (intern (format nil "~A-TO-INT" name)))
114	(int-enum (intern (format nil "INT-TO-~A" name))))
115	`(progn
116	(deftype ,name () '(enum ,@args))
117	(defun ,enum-int (enum)
118	(case enum
119	,@(%map-enum args :symbol-int)
120	(t (error 'type-error :datum enum :expected-type ',name))))
121	(defun ,int-enum (value)
122	(case value
123	,@(%map-enum args :int-quoted-symbol)))
124	(eval-when (:compile-toplevel :load-toplevel :execute)
125	(define-type-method to-alien-form ((type ,name) form &optional copy-p)
126	(declare (ignore type copy-p))
127	(list ',enum-int form))
128	(define-type-method from-alien-form ((type ,name) form &key ref)
129	(declare (ignore type ref))
130	(list ',int-enum form))
131	(define-type-method to-alien-function ((type ,name) &optional copy-p)
132	(declare (ignore type copy-p))
133	#',enum-int)
134	(define-type-method from-alien-function ((type ,name) &key ref)
135	(declare (ignore type ref))
136	#',int-enum)
137	(define-type-method writer-function ((type ,name) &key temp (inlined t))
138	(declare (ignore temp))
139	(assert-inlined type inlined)
140	(let ((writer (writer-function 'signed)))
141	#'(lambda (enum location &optional (offset 0))
142	(funcall writer (,enum-int enum) location offset))))
143	(define-type-method reader-function ((type ,name) &key ref (inlined t))
144	(declare (ignore ref))
145	(assert-inlined type inlined)
146	(let ((reader (reader-function 'signed)))
147	#'(lambda (location &optional (offset 0))
148	(,int-enum (funcall reader location offset)))))))))
149
150
151	;;;; Generic flags type
152
153	(defun %map-flags (mappings op)
154	(delete-duplicates
155	(loop
156	as value = 1 then (ash value 1)
157	for mapping in mappings
158	collect (let ((symbol (if (atom mapping) mapping (first mapping))))
159	(unless (atom mapping)
160	(setq value (second mapping)))
161	(case op
162	(:symbol-int `(,symbol ,value))
163	(:int-symbol `(,value ,symbol)))))
164	:key #'first :from-end t))
165
166	(deftype flags (&rest args)
167	`(or (member ,@(%map-symbols args)) list))
168
169	(define-type-method alien-type ((type flags))
170	(declare (ignore type))
171	(alien-type 'unsigned))
172
173	(define-type-method size-of ((type flags) &key (inlined t))
174	(assert-inlined type inlined)
175	(size-of 'unsigned))
176
177	(define-type-method to-alien-form ((type flags) flags &optional copy-p)
178	(declare (ignore copy-p))
179	`(reduce #'logior (mklist ,flags)
180	:key #'(lambda (flag)
181	(case flag
182	,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int)
183	(t (error 'type-error :datum ,flags :expected-type ',type))))))
184
185	(define-type-method from-alien-form ((type flags) value &key ref)
186	(declare (ignore ref))
187	`(loop
188	for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol)
189	when (= (logand ,value int) int)
190	collect symbol))
191
192	(define-type-method to-alien-function ((type flags) &optional copy-p)
193	(declare (ignore copy-p))
194	(let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :symbol-int)))
195	#'(lambda (flags)
196	(reduce #'logior (mklist flags)
197	:key #'(lambda (flag)
198	(or
199	(second (assoc flag mappings))
200	(error 'type-error :datum flags :expected-type type)))))))
201
202	(define-type-method from-alien-function ((type flags) &key ref)
203	(declare (ignore ref))
204	(let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :int-symbol)))
205	#'(lambda (value)
206	(loop
207	for (int symbol) in mappings
208	when (= (logand value int) int)
209	collect symbol))))
210
211	(define-type-method writer-function ((type flags) &key temp (inlined t))
212	(declare (ignore temp))
213	(assert-inlined type inlined)
214	(let ((writer (writer-function 'unsigned))
215	(function (to-alien-function (type-expand-to 'flags type))))
216	#'(lambda (flags location &optional (offset 0))
217	(funcall writer (funcall function flags) location offset))))
218
219	(define-type-method reader-function ((type flags) &key ref (inlined t))
220	(declare (ignore ref))
221	(assert-inlined type inlined)
222	(let ((reader (reader-function 'unsigned))
223	(function (from-alien-function (type-expand-to 'flags type))))
224	#'(lambda (location &optional (offset 0))
225	(funcall function (funcall reader location offset)))))
226
227
228	;;;; Named flags types
229
230	(defmacro define-flags-type (name &rest args)
231	(let ((flags-int (intern (format nil "~A-TO-INT" name)))
232	(int-flags (intern (format nil "INT-TO-~A" name)))
233	(satisfies (intern (format nil "~A-P" name))))
234	`(progn
235	(deftype ,name () '(satisfies ,satisfies))
236	(defun ,satisfies (object)
237	(flet ((valid-p (ob)
238	(find ob ',(%map-symbols args))))
239	(typecase object
240	(symbol (valid-p object))
241	(list (every #'valid-p object)))))
242	(defun ,flags-int (flags)
243	(reduce #'logior (mklist flags)
244	:key #'(lambda (flag)
245	(case flag
246	,@(%map-flags args :symbol-int)
247	(t (error 'type-error :datum flags :expected-type ',name))))))
248	(defun ,int-flags (value)
249	(loop
250	for (int symbol) in ',(%map-flags args :int-symbol)
251	when(= (logand value int) int)
252	collect symbol))
253	(eval-when (:compile-toplevel :load-toplevel :execute)
254	(define-type-method alien-type ((type ,name))
255	(declare (ignore type))
256	(alien-type 'flags))
257	(define-type-method size-of ((type ,name) &key (inlined t))
258	(assert-inlined type inlined)
259	(size-of 'flags))
260	(define-type-method to-alien-form ((type ,name) form &optional copy-p)
261	(declare (ignore type copy-p))
262	(list ',flags-int form))
263	(define-type-method from-alien-form ((type ,name) form &key ref)
264	(declare (ignore type ref))
265	(list ',int-flags form))
266	(define-type-method to-alien-function ((type ,name) &optional copy-p)
267	(declare (ignore type copy-p))
268	#',flags-int)
269	(define-type-method from-alien-function ((type ,name) &key ref)
270	(declare (ignore type ref))
271	#',int-flags)
272	(define-type-method writer-function ((type ,name) &key temp (inlined t))
273	(declare (ignore temp))
274	(assert-inlined type inlined)
275	(let ((writer (writer-function 'signed)))
276	#'(lambda (flags location &optional (offset 0))
277	(funcall writer (,flags-int flags) location offset))))
278	(define-type-method reader-function ((type ,name) &key ref (inlined t))
279	(declare (ignore ref))
280	(assert-inlined type inlined)
281	(let ((reader (reader-function 'signed)))
282	#'(lambda (location &optional (offset 0))
283	(,int-flags (funcall reader location offset)))))))))
284
285
286	(defexport define-enum-type (name &rest args)
287	(declare (ignore args))
288	name)
289
290	(defexport define-flags-type (name &rest args)
291	(declare (ignore args))
292	name)