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.16 2004-11-06 21:39:58 espen Exp $
26 ;;;; Memory management
28 (defbinding (allocate-memory "g_malloc0") () pointer
31 (defbinding (reallocate-memory "g_realloc") () pointer
35 (defbinding (deallocate-memory "g_free") () nil
37 ;; (defun deallocate-memory (address)
38 ;; (declare (ignore address)))
40 (defun copy-memory (from length &optional (to (allocate-memory length)))
41 (kernel:system-area-copy from 0 to 0 (* 8 length))
45 ;;;; User data mechanism
47 (internal *user-data* *user-data-count*)
49 (declaim (fixnum *user-data-count*))
51 (defvar *user-data* (make-hash-table))
52 (defvar *user-data-count* 0)
54 (defun register-user-data (object &optional destroy-function)
55 (check-type destroy-function (or null symbol function))
56 (incf *user-data-count*)
58 (gethash *user-data-count* *user-data*)
59 (cons object destroy-function))
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)))
67 (defun destroy-user-data (id)
68 (check-type id fixnum)
69 (let ((user-data (gethash id *user-data*)))
71 (funcall (cdr user-data) (car user-data))))
72 (remhash id *user-data*))
78 (internal *quark-counter* *quark-from-object* *quark-to-object*)
80 (deftype quark () 'unsigned)
82 ;(defbinding %quark-get-reserved () quark)
84 (defbinding %quark-from-string () quark
87 (defvar *quark-counter* 0)
89 (defun %quark-get-reserved ()
90 ;; The string is just a dummy
91 (%quark-from-string (format nil "#@£$%&-quark-~D" (incf *quark-counter*))))
93 (defvar *quark-from-object* (make-hash-table))
94 (defvar *quark-to-object* (make-hash-table))
96 (defun quark-from-object (object &key (test #'eq))
97 (let ((hash-code (sxhash object)))
99 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
100 (let ((quark (%quark-get-reserved)))
102 (gethash hash-code *quark-from-object*)
104 (gethash hash-code *quark-from-object*)
105 (list (cons object quark))))
106 (setf (gethash quark *quark-to-object*) object)
109 (defun quark-to-object (quark)
110 (gethash quark *quark-to-object*))
112 (defun remove-quark (quark)
113 (let* ((object (gethash quark *quark-to-object*))
114 (hash-code (sxhash object)))
115 (remhash quark *quark-to-object*)
117 (gethash hash-code *quark-from-object*)
118 (assoc-delete object (gethash hash-code *quark-from-object*)))
119 (remhash hash-code *quark-from-object*))))
123 ;;;; Linked list (GList)
125 (deftype glist (type &key copy)
126 (declare (ignore copy))
127 `(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 (defun make-glist (type list)
142 (let ((new-element (ecase (alien-type type)
143 (system-area-pointer #'%glist-append-sap)
144 ((signed-byte c-call:short c-call:int c-call:long)
145 #'%glist-append-signed)
146 ((unsigned-byte c-call:unsigned-short
147 c-call:unsigned-int c-call:unsigned-long)
148 #'%glist-append-unsigned)))
149 (to-alien (to-alien-function type)))
152 as glist = (funcall new-element (or glist (make-pointer 0))
153 (funcall to-alien element))
154 finally (return glist))))
156 (defun glist-next (glist)
157 (unless (null-pointer-p glist)
158 (sap-ref-sap glist +size-of-pointer+)))
160 ;; Also used for gslists
161 (defun map-glist (seqtype function glist element-type)
162 (let ((reader (reader-function element-type)))
166 as tmp = glist then (glist-next tmp)
167 until (null-pointer-p tmp)
168 do (funcall function (funcall reader tmp))))
171 as tmp = glist then (glist-next tmp)
172 until (null-pointer-p tmp)
173 collect (funcall function (funcall reader tmp))))
177 as tmp = glist then (glist-next tmp)
178 until (null-pointer-p tmp)
179 collect (funcall function (funcall reader tmp)))
182 (defbinding (glist-free "g_list_free") () nil
186 (defmethod alien-type ((type (eql 'glist)) &rest args)
187 (declare (ignore type args))
188 (alien-type 'pointer))
190 (defmethod size-of ((type (eql 'glist)) &rest args)
191 (declare (ignore type args))
194 (defmethod to-alien-form (list (type (eql 'glist)) &rest args)
195 (declare (ignore type))
196 (destructuring-bind (element-type) args
197 `(make-glist ',element-type ,list)))
199 (defmethod to-alien-function ((type (eql 'glist)) &rest args)
200 (declare (ignore type args))
201 (destructuring-bind (element-type) args
203 (make-glist element-type list))))
205 (defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
206 (declare (ignore type))
207 (destructuring-bind (element-type) args
208 `(let ((glist ,glist))
210 (map-glist 'list #'identity glist ',element-type)
211 (glist-free glist)))))
213 (defmethod from-alien-function ((type (eql 'glist)) &rest args)
214 (declare (ignore type))
215 (destructuring-bind (element-type) args
218 (map-glist 'list #'identity glist element-type)
219 (glist-free glist)))))
221 (defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
222 (declare (ignore type args))
223 `(glist-free ,glist))
225 (defmethod cleanup-function ((type (eql 'glist)) &rest args)
226 (declare (ignore type args))
231 ;;;; Single linked list (GSList)
233 (deftype gslist (type) `(or (null (cons ,type list))))
235 (defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer
239 (defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer
243 (defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
247 (defun make-gslist (type list)
248 (let ((new-element (ecase (alien-type type)
249 (system-area-pointer #'%gslist-prepend-sap)
250 ((signed-byte c-call:short c-call:int c-call:long)
251 #'%gslist-prepend-signed)
252 ((unsigned-byte c-call:unsigned-short
253 c-call:unsigned-int c-call:unsigned-long)
254 #'%gslist-prepend-unsigned)))
255 (to-alien (to-alien-function type)))
257 for element in (reverse list)
258 as gslist = (funcall new-element (or gslist (make-pointer 0))
259 (funcall to-alien element))
260 finally (return gslist))))
262 (defbinding (gslist-free "g_slist_free") () nil
266 (defmethod alien-type ((type (eql 'gslist)) &rest args)
267 (declare (ignore type args))
268 (alien-type 'pointer))
270 (defmethod size-of ((type (eql 'gslist)) &rest args)
271 (declare (ignore type args))
274 (defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
275 (declare (ignore type))
276 (destructuring-bind (element-type) args
277 `(make-sglist ',element-type ,list)))
279 (defmethod to-alien-function ((type (eql 'gslist)) &rest args)
280 (declare (ignore type args))
281 (destructuring-bind (element-type) args
283 (make-gslist element-type list))))
285 (defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
286 (declare (ignore type))
287 (destructuring-bind (element-type) args
288 `(let ((gslist ,gslist))
290 (map-glist 'list #'identity gslist ',element-type)
291 (gslist-free gslist)))))
293 (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
294 (declare (ignore type))
295 (destructuring-bind (element-type) args
298 (map-glist 'list #'identity gslist element-type)
299 (gslist-free gslist)))))
301 (defmethod cleanup-form (list (type (eql 'gslist)) &rest args)
302 (declare (ignore type args))
303 `(gslist-free ,list))
305 (defmethod cleanup-function ((type (eql 'gslist)) &rest args)
306 (declare (ignore type args))
313 (defun make-c-vector (type length &optional content location)
314 (let* ((size-of-type (size-of type))
315 (location (or location (allocate-memory (* size-of-type length))))
316 (writer (writer-function type)))
318 for element across content
319 for i from 0 below length
320 as offset = 0 then (+ offset size-of-type)
321 do (funcall writer element location offset))
325 (defun map-c-vector (seqtype function location element-type length)
326 (let ((reader (reader-function element-type))
327 (size-of-element (size-of element-type)))
331 for i from 0 below length
332 as offset = 0 then (+ offset size-of-element)
333 do (funcall function (funcall reader location offset))))
336 for i from 0 below length
337 as offset = 0 then (+ offset size-of-element)
338 collect (funcall function (funcall reader location offset))))
341 with sequence = (make-sequence seqtype length)
342 for i from 0 below length
343 as offset = 0 then (+ offset size-of-element)
346 (funcall function (funcall reader location offset)))
347 finally (return sequence))))))
350 (defmethod alien-type ((type (eql 'vector)) &rest args)
351 (declare (ignore type args))
352 (alien-type 'pointer))
354 (defmethod size-of ((type (eql 'vector)) &rest args)
355 (declare (ignore type args))
358 (defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
359 (declare (ignore type))
360 (destructuring-bind (element-type &optional (length '*)) args
362 `(let* ((vector ,vector)
364 (allocate-memory (+ ,+size-of-int+
365 (* ,(size-of element-type)
368 (make-c-vector ',element-type (length vector) vector location)
369 (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
371 `(make-c-vector ',element-type ,length ,vector))))
373 (defmethod from-alien-form (location (type (eql 'vector)) &rest args)
374 (declare (ignore type))
375 (destructuring-bind (element-type &optional (length '*)) args
377 (error "Can't use vector of variable size as return type")
378 `(map-c-vector 'vector #'identity ',element-type ',length ,location))))
380 (defmethod cleanup-form (location (type (eql 'vector)) &rest args)
381 (declare (ignore type))
382 (destructuring-bind (element-type &optional (length '*)) args
383 `(let* ((location ,location)
384 (length ,(if (eq length '*)
385 `(sap-ref-32 location ,(- +size-of-int+))
388 with destroy = (destroy-function ',element-type)
389 for i from 0 below length
390 as offset = 0 then (+ offset ,(size-of element-type))
391 do (funcall destroy location offset))
392 (deallocate-memory ,(if (eq length '*)
393 `(sap+ location ,(- +size-of-int+))