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.21 2004-12-09 23:31:50 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*))
77 (internal *quark-counter* *quark-from-object* *quark-to-object*)
79 (deftype quark () 'unsigned)
81 ;(defbinding %quark-get-reserved () quark)
83 (defbinding %quark-from-string () quark
86 (defvar *quark-counter* 0)
88 (defun %quark-get-reserved ()
89 ;; The string is just a dummy
90 (%quark-from-string (format nil "#@£$%&-quark-~D" (incf *quark-counter*))))
92 (defvar *quark-from-object* (make-hash-table))
93 (defvar *quark-to-object* (make-hash-table))
95 (defun quark-from-object (object &key (test #'eq))
96 (let ((hash-code (sxhash object)))
98 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
99 (let ((quark (%quark-get-reserved)))
101 (gethash hash-code *quark-from-object*)
103 (gethash hash-code *quark-from-object*)
104 (list (cons object quark))))
105 (setf (gethash quark *quark-to-object*) object)
108 (defun quark-to-object (quark)
109 (gethash quark *quark-to-object*))
111 (defun remove-quark (quark)
112 (let* ((object (gethash quark *quark-to-object*))
113 (hash-code (sxhash object)))
114 (remhash quark *quark-to-object*)
116 (gethash hash-code *quark-from-object*)
117 (assoc-delete object (gethash hash-code *quark-from-object*)))
118 (remhash hash-code *quark-from-object*))))
122 ;;;; Linked list (GList)
124 (deftype glist (type)
125 `(or (null (cons ,type list))))
127 (defbinding (%glist-append "g_list_append") () pointer
131 (defun make-glist (type list)
133 with writer = (writer-function type)
135 as glist = (%glist-append (or glist (make-pointer 0)))
136 do (funcall writer element glist)
137 finally (return glist)))
139 (defun glist-next (glist)
140 (unless (null-pointer-p glist)
141 (sap-ref-sap glist +size-of-pointer+)))
143 ;; Also used for gslists
144 (defun map-glist (seqtype function glist element-type)
145 (let ((reader (reader-function element-type)))
149 as tmp = glist then (glist-next tmp)
150 until (null-pointer-p tmp)
151 do (funcall function (funcall reader tmp))))
154 as tmp = glist then (glist-next tmp)
155 until (null-pointer-p tmp)
156 collect (funcall function (funcall reader tmp))))
160 as tmp = glist then (glist-next tmp)
161 until (null-pointer-p tmp)
162 collect (funcall function (funcall reader tmp)))
165 (defbinding (glist-free "g_list_free") () nil
168 (defun destroy-glist (glist element-type)
170 with destroy = (destroy-function element-type)
171 as tmp = glist then (glist-next tmp)
172 until (null-pointer-p tmp)
173 do (funcall destroy tmp 0))
176 (defmethod alien-type ((type (eql 'glist)) &rest args)
177 (declare (ignore type args))
178 (alien-type 'pointer))
180 (defmethod size-of ((type (eql 'glist)) &rest args)
181 (declare (ignore type args))
184 (defmethod to-alien-form (list (type (eql 'glist)) &rest args)
185 (declare (ignore type))
186 (destructuring-bind (element-type) args
187 `(make-glist ',element-type ,list)))
189 (defmethod to-alien-function ((type (eql 'glist)) &rest args)
190 (declare (ignore type))
191 (destructuring-bind (element-type) args
193 (make-glist element-type list))))
195 (defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
196 (declare (ignore type))
197 (destructuring-bind (element-type) args
198 `(let ((glist ,glist))
200 (map-glist 'list #'identity glist ',element-type)
201 (destroy-glist glist ',element-type)))))
203 (defmethod from-alien-function ((type (eql 'glist)) &rest args)
204 (declare (ignore type))
205 (destructuring-bind (element-type) args
208 (map-glist 'list #'identity glist element-type)
209 (destroy-glist glist element-type)))))
211 (defmethod copy-from-alien-form (glist (type (eql 'glist)) &rest args)
212 (declare (ignore type))
213 (destructuring-bind (element-type) args
214 `(map-glist 'list #'identity ,glist ',element-type)))
216 (defmethod copy-from-alien-function ((type (eql 'glist)) &rest args)
217 (declare (ignore type))
218 (destructuring-bind (element-type) args
220 (map-glist 'list #'identity glist element-type))))
222 (defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
223 (declare (ignore type))
224 (destructuring-bind (element-type) args
225 `(destroy-glist ,glist ',element-type)))
227 (defmethod cleanup-function ((type (eql 'glist)) &rest args)
228 (declare (ignore type args))
229 (destructuring-bind (element-type) args
231 (destroy-glist glist element-type))))
234 ;;;; Single linked list (GSList)
236 (deftype gslist (type) `(or (null (cons ,type list))))
238 (defbinding (%gslist-prepend "g_slist_prepend") () pointer
242 (defun make-gslist (type list)
244 with writer = (writer-function type)
245 for element in (reverse list)
246 as gslist = (%gslist-prepend (or gslist (make-pointer 0)))
247 do (funcall writer element gslist)
248 finally (return gslist)))
250 (defbinding (gslist-free "g_slist_free") () nil
253 (defun destroy-gslist (gslist element-type)
255 with destroy = (destroy-function element-type)
256 as tmp = gslist then (glist-next tmp)
257 until (null-pointer-p tmp)
258 do (funcall destroy tmp 0))
259 (gslist-free gslist))
261 (defmethod alien-type ((type (eql 'gslist)) &rest args)
262 (declare (ignore type args))
263 (alien-type 'pointer))
265 (defmethod size-of ((type (eql 'gslist)) &rest args)
266 (declare (ignore type args))
269 (defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
270 (declare (ignore type))
271 (destructuring-bind (element-type) args
272 `(make-sglist ',element-type ,list)))
274 (defmethod to-alien-function ((type (eql 'gslist)) &rest args)
275 (declare (ignore type))
276 (destructuring-bind (element-type) args
278 (make-gslist element-type list))))
280 (defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
281 (declare (ignore type))
282 (destructuring-bind (element-type) args
283 `(let ((gslist ,gslist))
285 (map-glist 'list #'identity gslist ',element-type)
286 (destroy-gslist gslist ',element-type)))))
288 (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
289 (declare (ignore type))
290 (destructuring-bind (element-type) args
293 (map-glist 'list #'identity gslist element-type)
294 (destroy-gslist gslist element-type)))))
296 (defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args)
297 (declare (ignore type))
298 (destructuring-bind (element-type) args
299 `(map-glist 'list #'identity ,gslist ',element-type)))
301 (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
302 (declare (ignore type))
303 (destructuring-bind (element-type) args
305 (map-glist 'list #'identity gslist element-type))))
307 (defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args)
308 (declare (ignore type args))
309 (destructuring-bind (element-type) args
310 `(destroy-gslist ,gslist ',element-type)))
312 (defmethod cleanup-function ((type (eql 'gslist)) &rest args)
313 (declare (ignore type args))
314 (destructuring-bind (element-type) args
316 (destroy-gslist gslist element-type))))
322 (defun make-c-vector (type length &optional content location)
323 (let* ((size-of-type (size-of type))
324 (location (or location (allocate-memory (* size-of-type length))))
325 (writer (writer-function type)))
329 for element across content
330 for i from 0 below length
331 as offset = 0 then (+ offset size-of-type)
332 do (funcall writer element location offset)))
335 for element in content
336 for i from 0 below length
337 as offset = 0 then (+ offset size-of-type)
338 do (funcall writer element location offset))))
342 (defun map-c-vector (seqtype function location element-type length)
343 (let ((reader (reader-function element-type))
344 (size-of-element (size-of element-type)))
348 for i from 0 below length
349 as offset = 0 then (+ offset size-of-element)
350 do (funcall function (funcall reader location offset))))
353 for i from 0 below length
354 as offset = 0 then (+ offset size-of-element)
355 collect (funcall function (funcall reader location offset))))
358 with sequence = (make-sequence seqtype length)
359 for i from 0 below length
360 as offset = 0 then (+ offset size-of-element)
363 (funcall function (funcall reader location offset)))
364 finally (return sequence))))))
367 (defun destroy-c-vector (location element-type length)
369 with destroy = (destroy-function element-type)
370 with element-size = (size-of element-type)
371 for i from 0 below length
372 as offset = 0 then (+ offset element-size)
373 do (funcall destroy location offset))
374 (deallocate-memory location))
377 (defmethod alien-type ((type (eql 'vector)) &rest args)
378 (declare (ignore type args))
379 (alien-type 'pointer))
381 (defmethod size-of ((type (eql 'vector)) &rest args)
382 (declare (ignore type args))
385 (defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
386 (declare (ignore type))
387 (destructuring-bind (element-type &optional (length '*)) args
389 `(let* ((vector ,vector)
391 (allocate-memory (+ ,+size-of-int+
392 (* ,(size-of element-type)
395 (make-c-vector ',element-type (length vector) vector location)
396 (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
398 `(make-c-vector ',element-type ,length ,vector))))
400 (defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args)
401 (declare (ignore type))
402 (destructuring-bind (element-type &optional (length '*)) args
404 (error "Can't use vector of variable size as return type")
405 `(let ((c-vector ,c-vector))
407 (map-c-vector 'vector #'identity ',element-type ,length c-vector)
408 (destroy-c-vector c-vector ',element-type ,length))))))
410 (defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args)
411 (declare (ignore type))
412 (destructuring-bind (element-type &optional (length '*)) args
414 (error "Can't use vector of variable size as return type")
415 `(map-c-vector 'vector #'identity ',element-type ',length ,c-vector))))
417 (defmethod cleanup-form (location (type (eql 'vector)) &rest args)
418 (declare (ignore type))
419 (destructuring-bind (element-type &optional (length '*)) args
420 `(let* ((location ,location)
421 (length ,(if (eq length '*)
422 `(sap-ref-32 location ,(- +size-of-int+))
425 with destroy = (destroy-function ',element-type)
426 for i from 0 below length
427 as offset = 0 then (+ offset ,(size-of element-type))
428 do (funcall destroy location offset))
429 (deallocate-memory ,(if (eq length '*)
430 `(sap+ location ,(- +size-of-int+))
433 (defmethod writer-function ((type (eql 'vector)) &rest args)
434 (declare (ignore type))
435 (destructuring-bind (element-type &optional (length '*)) args
436 #'(lambda (vector location &optional (offset 0))
438 (sap-ref-sap location offset)
439 (make-c-vector element-type length vector)))))
441 (defmethod reader-function ((type (eql 'vector)) &rest args)
442 (declare (ignore type))
443 (destructuring-bind (element-type &optional (length '*)) args
445 (error "Can't create reader function for vector of variable size")
446 #'(lambda (location &optional (offset 0))
447 (unless (null-pointer-p (sap-ref-sap location offset))
448 (map-c-vector 'vector #'identity (sap-ref-sap location offset)
449 element-type length))))))
451 (defmethod destroy-function ((type (eql 'vector)) &rest args)
452 (declare (ignore type))
453 (destructuring-bind (element-type &optional (length '*)) args
455 (error "Can't create destroy function for vector of variable size")
456 #'(lambda (location &optional (offset 0))
457 (unless (null-pointer-p (sap-ref-sap location offset))
459 (sap-ref-sap location offset) element-type length)
460 (setf (sap-ref-sap location offset) (make-pointer 0)))))))