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.23 2005-01-03 16:38:57 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 update-user-data (id object)
68 (check-type id fixnum)
69 (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
71 ((not exists-p) (error "User data id ~A does not exist" id))
74 (funcall (cdr user-data) (car user-data)))
75 (setf (car user-data) object)))))
77 (defun destroy-user-data (id)
78 (check-type id fixnum)
79 (let ((user-data (gethash id *user-data*)))
81 (funcall (cdr user-data) (car user-data))))
82 (remhash id *user-data*))
87 (internal *quark-counter* *quark-from-object* *quark-to-object*)
89 (deftype quark () 'unsigned)
91 ;(defbinding %quark-get-reserved () quark)
93 (defbinding %quark-from-string () quark
96 (defvar *quark-counter* 0)
98 (defun %quark-get-reserved ()
99 ;; The string is just a dummy
100 (%quark-from-string (format nil "#@£$%&-quark-~D" (incf *quark-counter*))))
102 (defvar *quark-from-object* (make-hash-table))
103 (defvar *quark-to-object* (make-hash-table))
105 (defun quark-from-object (object &key (test #'eq))
106 (let ((hash-code (sxhash object)))
108 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
109 (let ((quark (%quark-get-reserved)))
111 (gethash hash-code *quark-from-object*)
113 (gethash hash-code *quark-from-object*)
114 (list (cons object quark))))
115 (setf (gethash quark *quark-to-object*) object)
118 (defun quark-to-object (quark)
119 (gethash quark *quark-to-object*))
121 (defun remove-quark (quark)
122 (let* ((object (gethash quark *quark-to-object*))
123 (hash-code (sxhash object)))
124 (remhash quark *quark-to-object*)
126 (gethash hash-code *quark-from-object*)
127 (assoc-delete object (gethash hash-code *quark-from-object*)))
128 (remhash hash-code *quark-from-object*))))
132 ;;;; Linked list (GList)
134 (deftype glist (type)
135 `(or (null (cons ,type list))))
137 (defbinding (%glist-append "g_list_append") () pointer
141 (defun make-glist (type list)
143 with writer = (writer-function type)
145 as glist = (%glist-append (or glist (make-pointer 0)))
146 do (funcall writer element glist)
147 finally (return glist)))
149 (defun glist-next (glist)
150 (unless (null-pointer-p glist)
151 (sap-ref-sap glist +size-of-pointer+)))
153 ;; Also used for gslists
154 (defun map-glist (seqtype function glist element-type)
155 (let ((reader (reader-function element-type)))
159 as tmp = glist then (glist-next tmp)
160 until (null-pointer-p tmp)
161 do (funcall function (funcall reader tmp))))
164 as tmp = glist then (glist-next tmp)
165 until (null-pointer-p tmp)
166 collect (funcall function (funcall reader tmp))))
170 as tmp = glist then (glist-next tmp)
171 until (null-pointer-p tmp)
172 collect (funcall function (funcall reader tmp)))
175 (defbinding (glist-free "g_list_free") () nil
178 (defun destroy-glist (glist element-type)
180 with destroy = (destroy-function element-type)
181 as tmp = glist then (glist-next tmp)
182 until (null-pointer-p tmp)
183 do (funcall destroy tmp 0))
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))
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 (destroy-glist glist ',element-type)))))
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 (destroy-glist glist element-type)))))
221 (defmethod copy-from-alien-form (glist (type (eql 'glist)) &rest args)
222 (declare (ignore type))
223 (destructuring-bind (element-type) args
224 `(map-glist 'list #'identity ,glist ',element-type)))
226 (defmethod copy-from-alien-function ((type (eql 'glist)) &rest args)
227 (declare (ignore type))
228 (destructuring-bind (element-type) args
230 (map-glist 'list #'identity glist element-type))))
232 (defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
233 (declare (ignore type))
234 (destructuring-bind (element-type) args
235 `(destroy-glist ,glist ',element-type)))
237 (defmethod cleanup-function ((type (eql 'glist)) &rest args)
238 (declare (ignore type))
239 (destructuring-bind (element-type) args
241 (destroy-glist glist element-type))))
243 (defmethod writer-function ((type (eql 'glist)) &rest args)
244 (declare (ignore type))
245 (destructuring-bind (element-type) args
246 #'(lambda (list location &optional (offset 0))
248 (sap-ref-sap location offset)
249 (make-glist element-type list)))))
251 (defmethod reader-function ((type (eql 'glist)) &rest args)
252 (declare (ignore type))
253 (destructuring-bind (element-type) args
254 #'(lambda (location &optional (offset 0))
255 (unless (null-pointer-p (sap-ref-sap location offset))
256 (map-glist 'list #'identity (sap-ref-sap location offset) element-type)))))
258 (defmethod destroy-function ((type (eql 'glist)) &rest args)
259 (declare (ignore type))
260 (destructuring-bind (element-type) args
261 #'(lambda (location &optional (offset 0))
262 (unless (null-pointer-p (sap-ref-sap location offset))
263 (destroy-glist (sap-ref-sap location offset) element-type)
264 (setf (sap-ref-sap location offset) (make-pointer 0))))))
268 ;;;; Single linked list (GSList)
270 (deftype gslist (type) `(or (null (cons ,type list))))
272 (defbinding (%gslist-prepend "g_slist_prepend") () pointer
276 (defun make-gslist (type list)
278 with writer = (writer-function type)
279 for element in (reverse list)
280 as gslist = (%gslist-prepend (or gslist (make-pointer 0)))
281 do (funcall writer element gslist)
282 finally (return gslist)))
284 (defbinding (gslist-free "g_slist_free") () nil
287 (defun destroy-gslist (gslist element-type)
289 with destroy = (destroy-function element-type)
290 as tmp = gslist then (glist-next tmp)
291 until (null-pointer-p tmp)
292 do (funcall destroy tmp 0))
293 (gslist-free gslist))
295 (defmethod alien-type ((type (eql 'gslist)) &rest args)
296 (declare (ignore type args))
297 (alien-type 'pointer))
299 (defmethod size-of ((type (eql 'gslist)) &rest args)
300 (declare (ignore type args))
303 (defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
304 (declare (ignore type))
305 (destructuring-bind (element-type) args
306 `(make-sglist ',element-type ,list)))
308 (defmethod to-alien-function ((type (eql 'gslist)) &rest args)
309 (declare (ignore type))
310 (destructuring-bind (element-type) args
312 (make-gslist element-type list))))
314 (defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
315 (declare (ignore type))
316 (destructuring-bind (element-type) args
317 `(let ((gslist ,gslist))
319 (map-glist 'list #'identity gslist ',element-type)
320 (destroy-gslist gslist ',element-type)))))
322 (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
323 (declare (ignore type))
324 (destructuring-bind (element-type) args
327 (map-glist 'list #'identity gslist element-type)
328 (destroy-gslist gslist element-type)))))
330 (defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args)
331 (declare (ignore type))
332 (destructuring-bind (element-type) args
333 `(map-glist 'list #'identity ,gslist ',element-type)))
335 (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
336 (declare (ignore type))
337 (destructuring-bind (element-type) args
339 (map-glist 'list #'identity gslist element-type))))
341 (defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args)
342 (declare (ignore type))
343 (destructuring-bind (element-type) args
344 `(destroy-gslist ,gslist ',element-type)))
346 (defmethod cleanup-function ((type (eql 'gslist)) &rest args)
347 (declare (ignore type))
348 (destructuring-bind (element-type) args
350 (destroy-gslist gslist element-type))))
352 (defmethod writer-function ((type (eql 'gslist)) &rest args)
353 (declare (ignore type))
354 (destructuring-bind (element-type) args
355 #'(lambda (list location &optional (offset 0))
357 (sap-ref-sap location offset)
358 (make-gslist element-type list)))))
360 (defmethod reader-function ((type (eql 'gslist)) &rest args)
361 (declare (ignore type))
362 (destructuring-bind (element-type) args
363 #'(lambda (location &optional (offset 0))
364 (unless (null-pointer-p (sap-ref-sap location offset))
365 (map-glist 'list #'identity (sap-ref-sap location offset) element-type)))))
367 (defmethod destroy-function ((type (eql 'gslist)) &rest args)
368 (declare (ignore type))
369 (destructuring-bind (element-type) args
370 #'(lambda (location &optional (offset 0))
371 (unless (null-pointer-p (sap-ref-sap location offset))
372 (destroy-gslist (sap-ref-sap location offset) element-type)
373 (setf (sap-ref-sap location offset) (make-pointer 0))))))
378 (defun make-c-vector (type length &optional content location)
379 (let* ((size-of-type (size-of type))
380 (location (or location (allocate-memory (* size-of-type length))))
381 (writer (writer-function type)))
385 for element across content
386 for i from 0 below length
387 as offset = 0 then (+ offset size-of-type)
388 do (funcall writer element location offset)))
391 for element in content
392 for i from 0 below length
393 as offset = 0 then (+ offset size-of-type)
394 do (funcall writer element location offset))))
398 (defun map-c-vector (seqtype function location element-type length)
399 (let ((reader (reader-function element-type))
400 (size-of-element (size-of element-type)))
404 for i from 0 below length
405 as offset = 0 then (+ offset size-of-element)
406 do (funcall function (funcall reader location offset))))
409 for i from 0 below length
410 as offset = 0 then (+ offset size-of-element)
411 collect (funcall function (funcall reader location offset))))
414 with sequence = (make-sequence seqtype length)
415 for i from 0 below length
416 as offset = 0 then (+ offset size-of-element)
419 (funcall function (funcall reader location offset)))
420 finally (return sequence))))))
423 (defun destroy-c-vector (location element-type length)
425 with destroy = (destroy-function element-type)
426 with element-size = (size-of element-type)
427 for i from 0 below length
428 as offset = 0 then (+ offset element-size)
429 do (funcall destroy location offset))
430 (deallocate-memory location))
433 (defmethod alien-type ((type (eql 'vector)) &rest args)
434 (declare (ignore type args))
435 (alien-type 'pointer))
437 (defmethod size-of ((type (eql 'vector)) &rest args)
438 (declare (ignore type args))
441 (defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
442 (declare (ignore type))
443 (destructuring-bind (element-type &optional (length '*)) args
445 `(let* ((vector ,vector)
447 (allocate-memory (+ ,+size-of-int+
448 (* ,(size-of element-type)
451 (make-c-vector ',element-type (length vector) vector location)
452 (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
454 `(make-c-vector ',element-type ,length ,vector))))
456 (defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args)
457 (declare (ignore type))
458 (destructuring-bind (element-type &optional (length '*)) args
460 (error "Can't use vector of variable size as return type")
461 `(let ((c-vector ,c-vector))
463 (map-c-vector 'vector #'identity c-vector ',element-type ,length)
464 (destroy-c-vector c-vector ',element-type ,length))))))
466 (defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args)
467 (declare (ignore type))
468 (destructuring-bind (element-type &optional (length '*)) args
470 (error "Can't use vector of variable size as return type")
471 `(map-c-vector 'vector #'identity ,c-vector ',element-type ',length))))
473 (defmethod cleanup-form (location (type (eql 'vector)) &rest args)
474 (declare (ignore type))
475 (destructuring-bind (element-type &optional (length '*)) args
476 `(let* ((location ,location)
477 (length ,(if (eq length '*)
478 `(sap-ref-32 location ,(- +size-of-int+))
481 with destroy = (destroy-function ',element-type)
482 for i from 0 below length
483 as offset = 0 then (+ offset ,(size-of element-type))
484 do (funcall destroy location offset))
485 (deallocate-memory ,(if (eq length '*)
486 `(sap+ location ,(- +size-of-int+))
489 (defmethod writer-function ((type (eql 'vector)) &rest args)
490 (declare (ignore type))
491 (destructuring-bind (element-type &optional (length '*)) args
492 #'(lambda (vector location &optional (offset 0))
494 (sap-ref-sap location offset)
495 (make-c-vector element-type length vector)))))
497 (defmethod reader-function ((type (eql 'vector)) &rest args)
498 (declare (ignore type))
499 (destructuring-bind (element-type &optional (length '*)) args
501 (error "Can't create reader function for vector of variable size")
502 #'(lambda (location &optional (offset 0))
503 (unless (null-pointer-p (sap-ref-sap location offset))
504 (map-c-vector 'vector #'identity (sap-ref-sap location offset)
505 element-type length))))))
507 (defmethod destroy-function ((type (eql 'vector)) &rest args)
508 (declare (ignore type))
509 (destructuring-bind (element-type &optional (length '*)) args
511 (error "Can't create destroy function for vector of variable size")
512 #'(lambda (location &optional (offset 0))
513 (unless (null-pointer-p (sap-ref-sap location offset))
515 (sap-ref-sap location offset) element-type length)
516 (setf (sap-ref-sap location offset) (make-pointer 0)))))))