1 ;; Common Lisp bindings for GTK+ v1.2.x
2 ;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
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.
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.
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
18 ;; $Id: glib.lisp,v 1.13 2004-10-27 14:58:59 espen Exp $
25 ;(load-shared-library "libglib-2.0")
27 ;;;; Memory management
29 (defbinding (allocate-memory "g_malloc0") () pointer
32 (defbinding (reallocate-memory "g_realloc") () pointer
36 (defbinding (deallocate-memory "g_free") () nil
38 ;(defun deallocate-memory (address)
39 ; (declare (ignore address)))
41 (defun copy-memory (from length &optional (to (allocate-memory length)))
42 (kernel:system-area-copy from 0 to 0 (* 8 length))
46 ;;;; User data mechanism
48 (internal *user-data* *user-data-count*)
50 (declaim (fixnum *user-data-count*))
52 (defvar *destroy-notify* (system:foreign-symbol-address "destroy_notify"))
53 (defvar *user-data* (make-hash-table))
54 (defvar *user-data-count* 0)
56 (defun register-user-data (object &optional destroy-function)
57 (check-type destroy-function (or null symbol function))
58 (incf *user-data-count*)
60 (gethash *user-data-count* *user-data*)
61 (cons object destroy-function))
64 (defun find-user-data (id)
65 (check-type id fixnum)
66 (multiple-value-bind (user-data p) (gethash id *user-data*)
67 (values (car user-data) p)))
69 (defun destroy-user-data (id)
70 (check-type id fixnum)
71 (let ((user-data (gethash id *user-data*)))
73 (funcall (cdr user-data) (car user-data))))
74 (remhash id *user-data*))
80 (internal *quark-counter* *quark-from-object* *quark-to-object*)
82 (deftype quark () 'unsigned)
84 ;(defbinding %quark-get-reserved () quark)
86 (defbinding %quark-from-string () quark
89 (defvar *quark-counter* 0)
91 (defun %quark-get-reserved ()
92 ;; The string is just a dummy
93 (%quark-from-string (format nil "#@£$%&-quark-~D" (incf *quark-counter*))))
95 (defvar *quark-from-object* (make-hash-table))
96 (defvar *quark-to-object* (make-hash-table))
98 (defun quark-from-object (object &key (test #'eq))
99 (let ((hash-code (sxhash object)))
101 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
102 (let ((quark (%quark-get-reserved)))
104 (gethash hash-code *quark-from-object*)
106 (gethash hash-code *quark-from-object*)
107 (list (cons object quark))))
108 (setf (gethash quark *quark-to-object*) object)
111 (defun quark-to-object (quark)
112 (gethash quark *quark-to-object*))
114 (defun remove-quark (quark)
115 (let* ((object (gethash quark *quark-to-object*))
116 (hash-code (sxhash object)))
117 (remhash quark *quark-to-object*)
119 (gethash hash-code *quark-from-object*)
120 (assoc-delete object (gethash hash-code *quark-from-object*)))
121 (remhash hash-code *quark-from-object*))))
125 ;;;; Linked list (GList)
127 (deftype glist (type) `(or (null (cons ,type list))))
129 (defbinding (%glist-append-unsigned "g_list_append") () pointer
133 (defbinding (%glist-append-signed "g_list_append") () pointer
137 (defbinding (%glist-append-sap "g_list_append") () pointer
141 (defmacro glist-append (glist value type-spec)
142 (ecase (first (mklist (translate-type-spec type-spec)))
143 (unsigned `(%glist-append-unsigned ,glist ,value))
144 (signed `(%glist-append-signed ,glist ,value))
145 (system-area-pointer `(%glist-append-sap ,glist ,value))))
147 (defmacro glist-data (glist type-spec)
148 (ecase (first (mklist (translate-type-spec type-spec)))
149 (unsigned `(sap-ref-unsigned ,glist 0))
150 (signed `(sap-ref-signed ,glist 0))
151 (system-area-pointer `(sap-ref-sap ,glist 0))))
153 (defun glist-next (glist)
154 (unless (null-pointer-p glist)
155 (sap-ref-sap glist +size-of-sap+)))
157 (defbinding (glist-free "g_list_free") () nil
160 (deftype-method translate-type-spec glist (type-spec)
161 (declare (ignore type-spec))
162 (translate-type-spec 'pointer))
164 (deftype-method size-of glist (type-spec)
165 (declare (ignore type-spec))
168 (deftype-method translate-to-alien glist (type-spec list &optional weak-ref)
169 (declare (ignore weak-ref))
170 (let* ((element-type (second (type-expand-to 'glist type-spec)))
171 (element (translate-to-alien element-type 'element)))
172 `(let ((glist (make-pointer 0)))
173 (dolist (element ,list glist)
174 (setq glist (glist-append glist ,element ,element-type))))))
176 (deftype-method translate-from-alien
177 glist (type-spec glist &optional weak-ref)
178 (let ((element-type (second (type-expand-to 'glist type-spec))))
179 `(let ((glist ,glist)
181 (do ((tmp glist (glist-next tmp)))
182 ((null-pointer-p tmp))
184 ,(translate-from-alien
185 element-type `(glist-data tmp ,element-type) weak-ref)
191 (deftype-method cleanup-alien glist (type-spec glist &optional weak-ref)
193 (unreference-alien type-spec glist)))
195 (deftype-method unreference-alien glist (type-spec glist)
196 (let ((element-type (second (type-expand-to 'glist type-spec))))
197 `(let ((glist ,glist))
198 (unless (null-pointer-p glist)
199 ,(unless (atomic-type-p element-type)
200 `(do ((tmp glist (glist-next tmp)))
201 ((null-pointer-p tmp))
203 element-type `(glist-data tmp ,element-type))))
204 (glist-free glist)))))
207 ;;;; Single linked list (GSList)
209 (deftype gslist (type) `(or (null (cons ,type list))))
211 (defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer
215 (defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer
219 (defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
223 (defmacro gslist-prepend (gslist value type-spec)
224 (ecase (first (mklist (translate-type-spec type-spec)))
225 (unsigned `(%gslist-prepend-unsigned ,gslist ,value))
226 (signed `(%gslist-prepend-signed ,gslist ,value))
227 (system-area-pointer `(%gslist-prepend-sap ,gslist ,value))))
229 (defbinding (gslist-free "g_slist_free") () nil
232 (deftype-method translate-type-spec gslist (type-spec)
233 (declare (ignore type-spec))
234 (translate-type-spec 'pointer))
236 (deftype-method size-of gslist (type-spec)
237 (declare (ignore type-spec))
240 (deftype-method translate-to-alien gslist (type-spec list &optional weak-ref)
241 (declare (ignore weak-ref))
242 (let* ((element-type (second (type-expand-to 'gslist type-spec)))
243 (element (translate-to-alien element-type 'element)))
244 `(let ((gslist (make-pointer 0)))
245 (dolist (element (reverse ,list) gslist)
246 (setq gslist (gslist-prepend gslist ,element ,element-type))))))
248 (deftype-method translate-from-alien
249 gslist (type-spec gslist &optional weak-ref)
250 (let ((element-type (second (type-expand-to 'gslist type-spec))))
251 `(let ((gslist ,gslist)
253 (do ((tmp gslist (glist-next tmp)))
254 ((null-pointer-p tmp))
256 ,(translate-from-alien
257 element-type `(glist-data tmp ,element-type) weak-ref)
260 '(gslist-free gslist))
263 (deftype-method cleanup-alien gslist (type-spec gslist &optional weak-ref)
265 (unreference-alien type-spec gslist)))
267 (deftype-method unreference-alien gslist (type-spec gslist)
268 (let ((element-type (second (type-expand-to 'gslist type-spec))))
269 `(let ((gslist ,gslist))
270 (unless (null-pointer-p gslist)
271 ,(unless (atomic-type-p element-type)
272 `(do ((tmp gslist (glist-next tmp)))
273 ((null-pointer-p tmp))
275 element-type `(glist-data tmp ,element-type))))
276 (gslist-free gslist)))))
282 (defvar *magic-end-of-array* (allocate-memory 1))
284 (deftype-method translate-type-spec vector (type-spec)
285 (declare (ignore type-spec))
286 (translate-type-spec 'pointer))
288 (deftype-method size-of vector (type-spec)
289 (declare (ignore type-spec))
292 (deftype-method translate-to-alien vector (type-spec vector &optional weak-ref)
293 (declare (ignore weak-ref))
294 (destructuring-bind (element-type &optional (length '*))
295 (cdr (type-expand-to 'vector type-spec))
296 (let* ((element-size (size-of element-type))
298 ((not (eq length '*))
299 (* element-size length))
300 ((not (atomic-type-p element-type))
301 `(* ,element-size (1+ (length vector))))
303 `(* ,element-size (length vector))))))
305 `(let ((vector ,vector))
306 (let ((c-vector (allocate-memory ,size)))
307 (dotimes (i ,(if (eq length '*) '(length vector) length))
309 (,(sap-ref-fname element-type) c-vector (* i ,element-size))
310 ,(translate-to-alien element-type '(aref vector i))))
313 (not (atomic-type-p element-type)))
315 (sap-ref-sap c-vector (* (length vector) ,element-size))
316 *magic-end-of-array*))
319 (deftype-method translate-from-alien
320 vector (type-spec c-array &optional weak-ref)
321 (destructuring-bind (element-type &optional (length '*))
322 (cdr (type-expand-to 'vector type-spec))
324 (error "Can't use vectors of variable length as return type"))
325 (let ((element-size (size-of element-type)))
326 `(let ((c-array ,c-array)
327 (vector (make-array ,length :element-type ',element-type)))
331 ,(translate-from-alien
333 `(,(sap-ref-fname element-type) c-array (* i ,element-size))
336 '(deallocate-memory c-vector))
340 (deftype-method cleanup-alien vector (type-spec c-vector &optional weak-ref)
342 (unreference-alien type-spec c-vector)))
344 (deftype-method unreference-alien vector (type-spec c-vector)
345 (destructuring-bind (element-type &optional (length '*))
346 (cdr (type-expand-to 'vector type-spec))
347 `(let ((c-vector ,c-vector))
348 (unless (null-pointer-p c-vector)
349 ,(unless (atomic-type-p element-type)
350 (let ((element-size (size-of element-type)))
351 (if (not (eq length '*))
352 `(dotimes (i ,length)
354 element-type (sap-ref-sap c-vector (* i ,element-size))))
355 `(do ((offset 0 (+ offset ,element-size)))
357 (sap-ref-sap c-vector offset)
358 *magic-end-of-array*))
360 element-type '(sap-ref-sap c-vector offset))))))
361 (deallocate-memory c-vector)))))
364 (defun map-c-array (seqtype function location element-type length)
365 (let ((reader (intern-reader-function element-type))
366 (size (size-of element-type)))
370 (funcall function (funcall reader location (* i size)))))
374 (push (funcall function (funcall reader location (* i size))) list))
377 (let ((sequence (make-sequence seqtype length)))
381 (funcall function (funcall reader location (* i size)))))