chiark / gitweb /
Added version numbers to glib/gtk shared lib file names
[clg] / glib / glib.lisp
CommitLineData
560af5c5 1;; Common Lisp bindings for GTK+ v1.2.x
2;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
3;;
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.
8;;
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.
13;;
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
17
3846c0b6 18;; $Id: glib.lisp,v 1.7 2000-10-05 17:17:41 espen Exp $
560af5c5 19
20
21(in-package "GLIB")
22(use-prefix "g")
23
24
25;;;; Memory management
26
27(define-foreign ("g_malloc0" allocate-memory) () pointer
28 (size unsigned-long))
29
30(define-foreign ("g_realloc" reallocate-memory) () pointer
31 (address pointer)
32 (size unsigned-long))
33
34(define-foreign ("g_free" deallocate-memory) () nil
35 (address pointer))
36
37(defun copy-memory (from length &optional (to (allocate-memory length)))
38 (kernel:system-area-copy from 0 to 0 (* 8 length))
39 to)
40
41
42
0aef1da8 43;;;; Quarks
44
45(deftype quark () 'unsigned)
46
415444ae 47;(define-foreign %quark-get-reserved () quark)
48
49(define-foreign %quark-from-string () quark
50 (string string))
51
52(defvar *string-counter* 0)
53
54(defun %quark-get-reserved ()
55 (%quark-from-string (format nil "CLG-~D" (incf *string-counter*))))
0aef1da8 56
57(defvar *quark-from-object* (make-hash-table))
58(defvar *quark-to-object* (make-hash-table))
59
60(defun quark-from-object (object &key (test #'eq))
61 (let ((hash-code (sxhash object)))
62 (or
63 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
64 (let ((quark (%quark-get-reserved)))
ab566f2c 65 (setf
66 (gethash hash-code *quark-from-object*)
67 (append
68 (gethash hash-code *quark-from-object*)
69 (list (cons object quark))))
0aef1da8 70 (setf (gethash quark *quark-to-object*) object)
71 quark))))
72
73(defun quark-to-object (quark)
74 (gethash quark *quark-to-object*))
75
76(defun remove-quark (quark)
77 (let* ((object (gethash quark *quark-to-object*))
78 (hash-code (sxhash object)))
79 (remhash quark *quark-to-object*)
80 (unless (setf
81 (gethash hash-code *quark-from-object*)
82 (assoc-delete object (gethash hash-code *quark-from-object*)))
83 (remhash hash-code *quark-from-object*))))
84
85
86
3846c0b6 87;;;; Linked list (GList)
560af5c5 88
3846c0b6 89(deftype glist (type) `(or (null (cons ,type list))))
560af5c5 90
3846c0b6 91(define-foreign ("g_list_append" %glist-append-unsigned) () pointer
92 (glist pointer)
560af5c5 93 (data unsigned))
94
3846c0b6 95(define-foreign ("g_list_append" %glist-append-signed) () pointer
96 (glist pointer)
97 (data signed))
98
99(define-foreign ("g_list_append" %glist-append-sap) () pointer
100 (glist pointer)
101 (data pointer))
102
560af5c5 103(defmacro glist-append (glist value type-spec)
104 (ecase (first (mklist (translate-type-spec type-spec)))
3846c0b6 105 (unsigned `(%glist-append-unsigned ,glist ,value))
106 (signed `(%glist-append-signed ,glist ,value))
107 (system-area-pointer `(%glist-append-sap ,glist ,value))))
560af5c5 108
109(defmacro glist-data (glist type-spec)
110 (ecase (first (mklist (translate-type-spec type-spec)))
111 (unsigned `(sap-ref-unsigned ,glist 0))
112 (signed `(sap-ref-signed ,glist 0))
113 (system-area-pointer `(sap-ref-sap ,glist 0))))
114
560af5c5 115(defun glist-next (glist)
116 (unless (null-pointer-p glist)
117 (sap-ref-sap glist +size-of-sap+)))
560af5c5 118
119(define-foreign ("g_list_free" glist-free) () nil
120 (glist pointer))
121
3846c0b6 122(deftype-method translate-type-spec glist (type-spec)
560af5c5 123 (declare (ignore type-spec))
415444ae 124 (translate-type-spec 'pointer))
125
3846c0b6 126(deftype-method size-of glist (type-spec)
415444ae 127 (declare (ignore type-spec))
128 (size-of 'pointer))
560af5c5 129
3846c0b6 130(deftype-method translate-to-alien glist (type-spec list &optional copy)
560af5c5 131 (declare (ignore copy))
3846c0b6 132 (let* ((element-type-spec (second (type-expand-to 'glist type-spec)))
560af5c5 133 (to-alien (translate-to-alien element-type-spec 'element t)))
134 `(let ((glist (make-pointer 0)))
135 (dolist (element ,list glist)
4e94e04b 136 (setq glist (glist-append glist ,to-alien ,element-type-spec))))))
560af5c5 137
3846c0b6 138(deftype-method translate-from-alien
139 glist (type-spec glist &optional (alloc :reference))
140 (let ((element-type-spec (second (type-expand-to 'glist type-spec))))
560af5c5 141 `(let ((glist ,glist)
142 (list nil))
143 (do ((tmp glist (glist-next tmp)))
144 ((null-pointer-p tmp))
145 (push
146 ,(translate-from-alien
147 element-type-spec `(glist-data tmp ,element-type-spec) alloc)
148 list))
fb754a8b 149 ,(when (eq alloc :reference)
560af5c5 150 '(glist-free glist))
151 (nreverse list))))
152
3846c0b6 153(deftype-method cleanup-alien glist (type-spec glist &optional copied)
560af5c5 154 (declare (ignore copied))
3846c0b6 155 (let* ((element-type-spec (second (type-expand-to 'glist type-spec)))
560af5c5 156 (alien-type-spec (translate-type-spec element-type-spec)))
157 `(let ((glist ,glist))
158 (unless (null-pointer-p glist)
159 ,(when (eq alien-type-spec 'system-area-pointer)
160 `(do ((tmp glist (glist-next tmp)))
161 ((null-pointer-p tmp))
4e94e04b 162 ,(cleanup-alien
163 element-type-spec `(glist-data tmp ,element-type-spec) t)))
560af5c5 164 (glist-free glist)))))
165
166
167
3846c0b6 168;;;; Single linked list (GSList)
169
170(deftype gslist (type) `(or (null (cons ,type list))))
171
172(define-foreign ("g_slist_prepend" %gslist-prepend-unsigned) () pointer
173 (gslist pointer)
174 (data unsigned))
175
176(define-foreign ("g_slist_prepend" %gslist-prepend-signed) () pointer
177 (gslist pointer)
178 (data signed))
179
180(define-foreign ("g_slist_prepend" %gslist-prepend-sap) () pointer
181 (gslist pointer)
182 (data pointer))
183
184(defmacro gslist-prepend (gslist value type-spec)
185 (ecase (first (mklist (translate-type-spec type-spec)))
186 (unsigned `(%gslist-prepend-unsigned ,gslist ,value))
187 (signed `(%gslist-prepend-signed ,gslist ,value))
188 (system-area-pointer `(%gslist-prepend-sap ,gslist ,value))))
189
190(define-foreign ("g_slist_free" gslist-free) () nil
191 (gslist pointer))
192
193(deftype-method translate-type-spec gslist (type-spec)
194 (declare (ignore type-spec))
195 (translate-type-spec 'pointer))
196
197(deftype-method size-of gslist (type-spec)
198 (declare (ignore type-spec))
199 (size-of 'pointer))
200
201(deftype-method translate-to-alien gslist (type-spec list &optional copy)
202 (declare (ignore copy))
203 (let* ((element-type-spec (second (type-expand-to 'gslist type-spec)))
204 (to-alien (translate-to-alien element-type-spec 'element t)))
205 `(let ((gslist (make-pointer 0)))
206 (dolist (element (reverse ,list) gslist)
207 (setq gslist (gslist-prepend gslist ,to-alien ,element-type-spec))))))
208
209(deftype-method translate-from-alien
210 gslist (type-spec gslist &optional (alloc :reference))
211 (let ((element-type-spec (second (type-expand-to 'gslist type-spec))))
212 `(let ((gslist ,gslist)
213 (list nil))
214 (do ((tmp gslist (glist-next tmp)))
215 ((null-pointer-p tmp))
216 (push
217 ,(translate-from-alien
218 element-type-spec `(glist-data tmp ,element-type-spec) alloc)
219 list))
220 ,(when (eq alloc :reference)
221 '(gslist-free gslist))
222 (nreverse list))))
223
224(deftype-method cleanup-alien gslist (type-spec gslist &optional copied)
225 (declare (ignore copied))
226 (let* ((element-type-spec (second (type-expand-to 'gslist type-spec)))
227 (alien-type-spec (translate-type-spec element-type-spec)))
228 `(let ((gslist ,gslist))
229 (unless (null-pointer-p gslist)
230 ,(when (eq alien-type-spec 'system-area-pointer)
231 `(do ((tmp gslist (glist-next tmp)))
232 ((null-pointer-p tmp))
233 ,(cleanup-alien
234 element-type-spec `(glist-data tmp ,element-type-spec) t)))
235 (gslist-free gslist)))))
236
237
238
415444ae 239;;; Vector
240
241(deftype-method translate-type-spec vector (type-spec)
242 (declare (ignore type-spec))
243 (translate-type-spec 'pointer))
244
245(deftype-method size-of vector (type-spec)
246 (declare (ignore type-spec))
247 (size-of 'pointer))
248
249(deftype-method translate-to-alien vector (type-spec vector &optional copy)
250 (declare (ignore copy))
251 (destructuring-bind (element-type &optional (length '*))
252 (cdr (type-expand-to 'vector type-spec))
3846c0b6 253 (let ((element-size (size-of element-type)))
415444ae 254 `(let ((vector ,vector))
255 (let ((c-vector
256 (allocate-memory
257 ,(if (eq length '*)
258 `(* ,element-size (length vector))
259 (* element-size length)))))
260 (dotimes (i ,(if (eq length '*) '(length vector) length) c-vector)
261 (setf
262 (,(sap-ref-fname element-type) c-vector (* i ,element-size))
3846c0b6 263 ,(translate-to-alien element-type '(aref vector i) :copy))))))))
264
265(deftype-method translate-from-alien
266 vector (type-spec sap &optional (alloc :reference))
267 (destructuring-bind (element-type &optional (length '*))
268 (cdr (type-expand-to 'vector type-spec))
269 (when (eq length '*)
270 (error "Can't use vectors of variable length as return type"))
271 (let ((element-size (size-of element-type)))
272 `(let ((sap ,sap)
273 (vector (make-array ,length :element-type ',element-type)))
274 (dotimes (i ,length vector)
275 (setf
276 (aref vector i)
277 ,(translate-to-alien
278 element-type
279 `(,(sap-ref-fname element-type) sap (* i ,element-size))
280 alloc)))))))
281
415444ae 282
283(deftype-method cleanup-alien vector (type-spec sap &optional copied)
284 (declare (ignore type-spec copied))
285 ;; The individual elements also have to be cleaned up to avoid memory leaks,
286 ;; but this is currently not possible because we can't always tell the
287 ;; length of the vector
288 `(deallocate-memory ,sap))