chiark / gitweb /
Callbacks from C done properly
[clg] / glib / glib.lisp
CommitLineData
560af5c5 1;; Common Lisp bindings for GTK+ v1.2.x
2;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
3;;
4;; This library is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU Lesser General Public
6;; License as published by the Free Software Foundation; either
7;; version 2 of the License, or (at your option) any later version.
8;;
9;; This library is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;; Lesser General Public License for more details.
13;;
14;; You should have received a copy of the GNU Lesser General Public
15;; License along with this library; if not, write to the Free Software
16;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
34f9e1d4 18;; $Id: glib.lisp,v 1.15 2004-11-01 00:08:49 espen Exp $
560af5c5 19
20
21(in-package "GLIB")
c4e9d221 22
560af5c5 23(use-prefix "g")
24
25
26;;;; Memory management
27
dba0c446 28(defbinding (allocate-memory "g_malloc0") () pointer
560af5c5 29 (size unsigned-long))
30
dba0c446 31(defbinding (reallocate-memory "g_realloc") () pointer
560af5c5 32 (address pointer)
33 (size unsigned-long))
34
3c657c71 35(defbinding (deallocate-memory "g_free") () nil
36 (address pointer))
37;(defun deallocate-memory (address)
38; (declare (ignore address)))
560af5c5 39
40(defun copy-memory (from length &optional (to (allocate-memory length)))
41 (kernel:system-area-copy from 0 to 0 (* 8 length))
42 to)
43
44
c4e9d221 45;;;; User data mechanism
46
47(internal *user-data* *user-data-count*)
48
49(declaim (fixnum *user-data-count*))
50
c4e9d221 51(defvar *user-data* (make-hash-table))
52(defvar *user-data-count* 0)
53
54(defun register-user-data (object &optional destroy-function)
55 (check-type destroy-function (or null symbol function))
56 (incf *user-data-count*)
57 (setf
58 (gethash *user-data-count* *user-data*)
59 (cons object destroy-function))
60 *user-data-count*)
61
62(defun find-user-data (id)
63 (check-type id fixnum)
64 (multiple-value-bind (user-data p) (gethash id *user-data*)
65 (values (car user-data) p)))
66
67(defun destroy-user-data (id)
68 (check-type id fixnum)
69 (let ((user-data (gethash id *user-data*)))
70 (when (cdr user-data)
71 (funcall (cdr user-data) (car user-data))))
72 (remhash id *user-data*))
73
74
560af5c5 75
0aef1da8 76;;;; Quarks
77
c4e9d221 78(internal *quark-counter* *quark-from-object* *quark-to-object*)
79
0aef1da8 80(deftype quark () 'unsigned)
81
5cae32e1 82;(defbinding %quark-get-reserved () quark)
415444ae 83
5cae32e1 84(defbinding %quark-from-string () quark
415444ae 85 (string string))
86
c4e9d221 87(defvar *quark-counter* 0)
415444ae 88
89(defun %quark-get-reserved ()
c4e9d221 90 ;; The string is just a dummy
91 (%quark-from-string (format nil "#@$%&-quark-~D" (incf *quark-counter*))))
0aef1da8 92
93(defvar *quark-from-object* (make-hash-table))
94(defvar *quark-to-object* (make-hash-table))
95
96(defun quark-from-object (object &key (test #'eq))
97 (let ((hash-code (sxhash object)))
98 (or
99 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
100 (let ((quark (%quark-get-reserved)))
ab566f2c 101 (setf
102 (gethash hash-code *quark-from-object*)
103 (append
104 (gethash hash-code *quark-from-object*)
105 (list (cons object quark))))
0aef1da8 106 (setf (gethash quark *quark-to-object*) object)
107 quark))))
108
109(defun quark-to-object (quark)
110 (gethash quark *quark-to-object*))
111
112(defun remove-quark (quark)
113 (let* ((object (gethash quark *quark-to-object*))
114 (hash-code (sxhash object)))
115 (remhash quark *quark-to-object*)
116 (unless (setf
117 (gethash hash-code *quark-from-object*)
118 (assoc-delete object (gethash hash-code *quark-from-object*)))
119 (remhash hash-code *quark-from-object*))))
120
121
122
3846c0b6 123;;;; Linked list (GList)
560af5c5 124
3846c0b6 125(deftype glist (type) `(or (null (cons ,type list))))
560af5c5 126
dba0c446 127(defbinding (%glist-append-unsigned "g_list_append") () pointer
3846c0b6 128 (glist pointer)
560af5c5 129 (data unsigned))
130
dba0c446 131(defbinding (%glist-append-signed "g_list_append") () pointer
3846c0b6 132 (glist pointer)
133 (data signed))
134
dba0c446 135(defbinding (%glist-append-sap "g_list_append") () pointer
3846c0b6 136 (glist pointer)
137 (data pointer))
138
560af5c5 139(defmacro glist-append (glist value type-spec)
140 (ecase (first (mklist (translate-type-spec type-spec)))
3846c0b6 141 (unsigned `(%glist-append-unsigned ,glist ,value))
142 (signed `(%glist-append-signed ,glist ,value))
143 (system-area-pointer `(%glist-append-sap ,glist ,value))))
560af5c5 144
145(defmacro glist-data (glist type-spec)
146 (ecase (first (mklist (translate-type-spec type-spec)))
147 (unsigned `(sap-ref-unsigned ,glist 0))
148 (signed `(sap-ref-signed ,glist 0))
149 (system-area-pointer `(sap-ref-sap ,glist 0))))
150
560af5c5 151(defun glist-next (glist)
152 (unless (null-pointer-p glist)
153 (sap-ref-sap glist +size-of-sap+)))
560af5c5 154
dba0c446 155(defbinding (glist-free "g_list_free") () nil
560af5c5 156 (glist pointer))
157
3846c0b6 158(deftype-method translate-type-spec glist (type-spec)
560af5c5 159 (declare (ignore type-spec))
415444ae 160 (translate-type-spec 'pointer))
161
3846c0b6 162(deftype-method size-of glist (type-spec)
415444ae 163 (declare (ignore type-spec))
164 (size-of 'pointer))
560af5c5 165
5cae32e1 166(deftype-method translate-to-alien glist (type-spec list &optional weak-ref)
167 (declare (ignore weak-ref))
168 (let* ((element-type (second (type-expand-to 'glist type-spec)))
169 (element (translate-to-alien element-type 'element)))
560af5c5 170 `(let ((glist (make-pointer 0)))
171 (dolist (element ,list glist)
5cae32e1 172 (setq glist (glist-append glist ,element ,element-type))))))
560af5c5 173
3846c0b6 174(deftype-method translate-from-alien
5cae32e1 175 glist (type-spec glist &optional weak-ref)
176 (let ((element-type (second (type-expand-to 'glist type-spec))))
560af5c5 177 `(let ((glist ,glist)
178 (list nil))
179 (do ((tmp glist (glist-next tmp)))
180 ((null-pointer-p tmp))
181 (push
182 ,(translate-from-alien
5cae32e1 183 element-type `(glist-data tmp ,element-type) weak-ref)
560af5c5 184 list))
5cae32e1 185 ,(unless weak-ref
560af5c5 186 '(glist-free glist))
187 (nreverse list))))
188
5cae32e1 189(deftype-method cleanup-alien glist (type-spec glist &optional weak-ref)
190 (when weak-ref
191 (unreference-alien type-spec glist)))
192
193(deftype-method unreference-alien glist (type-spec glist)
194 (let ((element-type (second (type-expand-to 'glist type-spec))))
560af5c5 195 `(let ((glist ,glist))
196 (unless (null-pointer-p glist)
5cae32e1 197 ,(unless (atomic-type-p element-type)
560af5c5 198 `(do ((tmp glist (glist-next tmp)))
199 ((null-pointer-p tmp))
5cae32e1 200 ,(unreference-alien
201 element-type `(glist-data tmp ,element-type))))
560af5c5 202 (glist-free glist)))))
203
204
3846c0b6 205;;;; Single linked list (GSList)
206
207(deftype gslist (type) `(or (null (cons ,type list))))
208
dba0c446 209(defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer
3846c0b6 210 (gslist pointer)
211 (data unsigned))
212
dba0c446 213(defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer
3846c0b6 214 (gslist pointer)
215 (data signed))
216
dba0c446 217(defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
3846c0b6 218 (gslist pointer)
219 (data pointer))
220
221(defmacro gslist-prepend (gslist value type-spec)
222 (ecase (first (mklist (translate-type-spec type-spec)))
223 (unsigned `(%gslist-prepend-unsigned ,gslist ,value))
224 (signed `(%gslist-prepend-signed ,gslist ,value))
225 (system-area-pointer `(%gslist-prepend-sap ,gslist ,value))))
226
dba0c446 227(defbinding (gslist-free "g_slist_free") () nil
3846c0b6 228 (gslist pointer))
229
230(deftype-method translate-type-spec gslist (type-spec)
231 (declare (ignore type-spec))
232 (translate-type-spec 'pointer))
233
234(deftype-method size-of gslist (type-spec)
235 (declare (ignore type-spec))
236 (size-of 'pointer))
237
5cae32e1 238(deftype-method translate-to-alien gslist (type-spec list &optional weak-ref)
239 (declare (ignore weak-ref))
240 (let* ((element-type (second (type-expand-to 'gslist type-spec)))
241 (element (translate-to-alien element-type 'element)))
3846c0b6 242 `(let ((gslist (make-pointer 0)))
243 (dolist (element (reverse ,list) gslist)
5cae32e1 244 (setq gslist (gslist-prepend gslist ,element ,element-type))))))
3846c0b6 245
246(deftype-method translate-from-alien
5cae32e1 247 gslist (type-spec gslist &optional weak-ref)
248 (let ((element-type (second (type-expand-to 'gslist type-spec))))
3846c0b6 249 `(let ((gslist ,gslist)
250 (list nil))
251 (do ((tmp gslist (glist-next tmp)))
252 ((null-pointer-p tmp))
253 (push
254 ,(translate-from-alien
5cae32e1 255 element-type `(glist-data tmp ,element-type) weak-ref)
3846c0b6 256 list))
5cae32e1 257 ,(unless weak-ref
3846c0b6 258 '(gslist-free gslist))
259 (nreverse list))))
260
5cae32e1 261(deftype-method cleanup-alien gslist (type-spec gslist &optional weak-ref)
262 (when weak-ref
263 (unreference-alien type-spec gslist)))
264
265(deftype-method unreference-alien gslist (type-spec gslist)
266 (let ((element-type (second (type-expand-to 'gslist type-spec))))
3846c0b6 267 `(let ((gslist ,gslist))
268 (unless (null-pointer-p gslist)
5cae32e1 269 ,(unless (atomic-type-p element-type)
3846c0b6 270 `(do ((tmp gslist (glist-next tmp)))
271 ((null-pointer-p tmp))
5cae32e1 272 ,(unreference-alien
273 element-type `(glist-data tmp ,element-type))))
3846c0b6 274 (gslist-free gslist)))))
275
276
277
415444ae 278;;; Vector
279
5cae32e1 280(defvar *magic-end-of-array* (allocate-memory 1))
281
415444ae 282(deftype-method translate-type-spec vector (type-spec)
283 (declare (ignore type-spec))
284 (translate-type-spec 'pointer))
285
286(deftype-method size-of vector (type-spec)
287 (declare (ignore type-spec))
288 (size-of 'pointer))
289
5cae32e1 290(deftype-method translate-to-alien vector (type-spec vector &optional weak-ref)
291 (declare (ignore weak-ref))
415444ae 292 (destructuring-bind (element-type &optional (length '*))
293 (cdr (type-expand-to 'vector type-spec))
5cae32e1 294 (let* ((element-size (size-of element-type))
295 (size (cond
296 ((not (eq length '*))
297 (* element-size length))
298 ((not (atomic-type-p element-type))
299 `(* ,element-size (1+ (length vector))))
300 (t
301 `(* ,element-size (length vector))))))
302
415444ae 303 `(let ((vector ,vector))
5cae32e1 304 (let ((c-vector (allocate-memory ,size)))
305 (dotimes (i ,(if (eq length '*) '(length vector) length))
415444ae 306 (setf
307 (,(sap-ref-fname element-type) c-vector (* i ,element-size))
5cae32e1 308 ,(translate-to-alien element-type '(aref vector i))))
309 ,(when (and
310 (eq length '*)
311 (not (atomic-type-p element-type)))
312 `(setf
313 (sap-ref-sap c-vector (* (length vector) ,element-size))
314 *magic-end-of-array*))
315 c-vector)))))
3846c0b6 316
317(deftype-method translate-from-alien
5cae32e1 318 vector (type-spec c-array &optional weak-ref)
3846c0b6 319 (destructuring-bind (element-type &optional (length '*))
320 (cdr (type-expand-to 'vector type-spec))
321 (when (eq length '*)
322 (error "Can't use vectors of variable length as return type"))
323 (let ((element-size (size-of element-type)))
5cae32e1 324 `(let ((c-array ,c-array)
3846c0b6 325 (vector (make-array ,length :element-type ',element-type)))
5cae32e1 326 (dotimes (i ,length)
3846c0b6 327 (setf
328 (aref vector i)
90816c46 329 ,(translate-from-alien
3846c0b6 330 element-type
5cae32e1 331 `(,(sap-ref-fname element-type) c-array (* i ,element-size))
332 weak-ref)))
333 ,(unless weak-ref
334 '(deallocate-memory c-vector))
335 vector))))
336
337
338(deftype-method cleanup-alien vector (type-spec c-vector &optional weak-ref)
339 (when weak-ref
340 (unreference-alien type-spec c-vector)))
341
342(deftype-method unreference-alien vector (type-spec c-vector)
343 (destructuring-bind (element-type &optional (length '*))
344 (cdr (type-expand-to 'vector type-spec))
345 `(let ((c-vector ,c-vector))
346 (unless (null-pointer-p c-vector)
347 ,(unless (atomic-type-p element-type)
348 (let ((element-size (size-of element-type)))
349 (if (not (eq length '*))
350 `(dotimes (i ,length)
351 (unreference-alien
352 element-type (sap-ref-sap c-vector (* i ,element-size))))
4d83a8a6 353 `(do ((offset 0 (+ offset ,element-size)))
5cae32e1 354 ((sap=
355 (sap-ref-sap c-vector offset)
4d83a8a6 356 *magic-end-of-array*))
5cae32e1 357 ,(unreference-alien
358 element-type '(sap-ref-sap c-vector offset))))))
359 (deallocate-memory c-vector)))))
dba0c446 360
361
362(defun map-c-array (seqtype function location element-type length)
363 (let ((reader (intern-reader-function element-type))
364 (size (size-of element-type)))
365 (case seqtype
366 ((nil)
367 (dotimes (i length)
368 (funcall function (funcall reader location (* i size)))))
369 (list
370 (let ((list nil))
371 (dotimes (i length)
372 (push (funcall function (funcall reader location (* i size))) list))
373 (nreverse list)))
374 (t
375 (let ((sequence (make-sequence seqtype length)))
376 (dotimes (i length)
377 (setf
378 (elt sequence i)
379 (funcall function (funcall reader location (* i size)))))
380 sequence)))))