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.18 2004-11-07 16:03:55 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 &key copy)
125 (declare (ignore copy))
126 `(or (null (cons ,type list))))
128 (defbinding (%glist-append-unsigned "g_list_append") () pointer
132 (defbinding (%glist-append-signed "g_list_append") () pointer
136 (defbinding (%glist-append-sap "g_list_append") () pointer
140 (defun make-glist (type list)
141 (let ((new-element (ecase (alien-type type)
142 (system-area-pointer #'%glist-append-sap)
143 ((signed-byte c-call:short c-call:int c-call:long)
144 #'%glist-append-signed)
145 ((unsigned-byte c-call:unsigned-short
146 c-call:unsigned-int c-call:unsigned-long)
147 #'%glist-append-unsigned)))
148 (to-alien (to-alien-function type)))
151 as glist = (funcall new-element (or glist (make-pointer 0))
152 (funcall to-alien element))
153 finally (return glist))))
155 (defun glist-next (glist)
156 (unless (null-pointer-p glist)
157 (sap-ref-sap glist +size-of-pointer+)))
159 ;; Also used for gslists
160 (defun map-glist (seqtype function glist element-type)
161 (let ((reader (reader-function element-type)))
165 as tmp = glist then (glist-next tmp)
166 until (null-pointer-p tmp)
167 do (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))))
176 as tmp = glist then (glist-next tmp)
177 until (null-pointer-p tmp)
178 collect (funcall function (funcall reader tmp)))
181 (defbinding (glist-free "g_list_free") () nil
185 (defmethod alien-type ((type (eql 'glist)) &rest args)
186 (declare (ignore type args))
187 (alien-type 'pointer))
189 (defmethod size-of ((type (eql 'glist)) &rest args)
190 (declare (ignore type args))
193 (defmethod to-alien-form (list (type (eql 'glist)) &rest args)
194 (declare (ignore type))
195 (destructuring-bind (element-type) args
196 `(make-glist ',element-type ,list)))
198 (defmethod to-alien-function ((type (eql 'glist)) &rest args)
199 (declare (ignore type))
200 (destructuring-bind (element-type) args
202 (make-glist element-type list))))
204 (defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
205 (declare (ignore type))
206 (destructuring-bind (element-type) args
207 `(let ((glist ,glist))
209 (map-glist 'list #'identity glist ',element-type)
210 (glist-free glist)))))
212 (defmethod from-alien-function ((type (eql 'glist)) &rest args)
213 (declare (ignore type))
214 (destructuring-bind (element-type) args
217 (map-glist 'list #'identity glist element-type)
218 (glist-free glist)))))
220 (defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
221 (declare (ignore type args))
222 `(glist-free ,glist))
224 (defmethod cleanup-function ((type (eql 'glist)) &rest args)
225 (declare (ignore type args))
230 ;;;; Single linked list (GSList)
232 (deftype gslist (type) `(or (null (cons ,type list))))
234 (defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer
238 (defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer
242 (defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
246 (defun make-gslist (type list)
247 (let ((new-element (ecase (alien-type type)
248 (system-area-pointer #'%gslist-prepend-sap)
249 ((signed-byte c-call:short c-call:int c-call:long)
250 #'%gslist-prepend-signed)
251 ((unsigned-byte c-call:unsigned-short
252 c-call:unsigned-int c-call:unsigned-long)
253 #'%gslist-prepend-unsigned)))
254 (to-alien (to-alien-function type)))
256 for element in (reverse list)
257 as gslist = (funcall new-element (or gslist (make-pointer 0))
258 (funcall to-alien element))
259 finally (return gslist))))
261 (defbinding (gslist-free "g_slist_free") () nil
265 (defmethod alien-type ((type (eql 'gslist)) &rest args)
266 (declare (ignore type args))
267 (alien-type 'pointer))
269 (defmethod size-of ((type (eql 'gslist)) &rest args)
270 (declare (ignore type args))
273 (defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
274 (declare (ignore type))
275 (destructuring-bind (element-type) args
276 `(make-sglist ',element-type ,list)))
278 (defmethod to-alien-function ((type (eql 'gslist)) &rest args)
279 (declare (ignore type))
280 (destructuring-bind (element-type) args
282 (make-gslist element-type list))))
284 (defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
285 (declare (ignore type))
286 (destructuring-bind (element-type) args
287 `(let ((gslist ,gslist))
289 (map-glist 'list #'identity gslist ',element-type)
290 (gslist-free gslist)))))
292 (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
293 (declare (ignore type))
294 (destructuring-bind (element-type) args
297 (map-glist 'list #'identity gslist element-type)
298 (gslist-free gslist)))))
300 (defmethod cleanup-form (list (type (eql 'gslist)) &rest args)
301 (declare (ignore type args))
302 `(gslist-free ,list))
304 (defmethod cleanup-function ((type (eql 'gslist)) &rest args)
305 (declare (ignore type args))
312 (defun make-c-vector (type length &optional content location)
313 (let* ((size-of-type (size-of type))
314 (location (or location (allocate-memory (* size-of-type length))))
315 (writer (writer-function type)))
317 for element across content
318 for i from 0 below length
319 as offset = 0 then (+ offset size-of-type)
320 do (funcall writer element location offset))
324 (defun map-c-vector (seqtype function location element-type length)
325 (let ((reader (reader-function element-type))
326 (size-of-element (size-of element-type)))
330 for i from 0 below length
331 as offset = 0 then (+ offset size-of-element)
332 do (funcall function (funcall reader location offset))))
335 for i from 0 below length
336 as offset = 0 then (+ offset size-of-element)
337 collect (funcall function (funcall reader location offset))))
340 with sequence = (make-sequence seqtype length)
341 for i from 0 below length
342 as offset = 0 then (+ offset size-of-element)
345 (funcall function (funcall reader location offset)))
346 finally (return sequence))))))
349 (defmethod alien-type ((type (eql 'vector)) &rest args)
350 (declare (ignore type args))
351 (alien-type 'pointer))
353 (defmethod size-of ((type (eql 'vector)) &rest args)
354 (declare (ignore type args))
357 (defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
358 (declare (ignore type))
359 (destructuring-bind (element-type &optional (length '*)) args
361 `(let* ((vector ,vector)
363 (allocate-memory (+ ,+size-of-int+
364 (* ,(size-of element-type)
367 (make-c-vector ',element-type (length vector) vector location)
368 (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
370 `(make-c-vector ',element-type ,length ,vector))))
372 (defmethod from-alien-form (location (type (eql 'vector)) &rest args)
373 (declare (ignore type))
374 (destructuring-bind (element-type &optional (length '*)) args
376 (error "Can't use vector of variable size as return type")
377 `(map-c-vector 'vector #'identity ',element-type ',length ,location))))
379 (defmethod cleanup-form (location (type (eql 'vector)) &rest args)
380 (declare (ignore type))
381 (destructuring-bind (element-type &optional (length '*)) args
382 `(let* ((location ,location)
383 (length ,(if (eq length '*)
384 `(sap-ref-32 location ,(- +size-of-int+))
387 with destroy = (destroy-function ',element-type)
388 for i from 0 below length
389 as offset = 0 then (+ offset ,(size-of element-type))
390 do (funcall destroy location offset))
391 (deallocate-memory ,(if (eq length '*)
392 `(sap+ location ,(- +size-of-int+))