chiark / gitweb /
Bug fix: (mklist ()) now returns NIL
[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
72e5ffec 18;; $Id: glib.lisp,v 1.20 2004-11-21 17:37:24 espen Exp $
560af5c5 19
20
21(in-package "GLIB")
c4e9d221 22
560af5c5 23(use-prefix "g")
24
25
26;;;; Memory management
27
dba0c446 28(defbinding (allocate-memory "g_malloc0") () pointer
560af5c5 29 (size unsigned-long))
30
dba0c446 31(defbinding (reallocate-memory "g_realloc") () pointer
560af5c5 32 (address pointer)
33 (size unsigned-long))
34
3c657c71 35(defbinding (deallocate-memory "g_free") () nil
36 (address pointer))
9adccb27 37;; (defun deallocate-memory (address)
38;; (declare (ignore address)))
560af5c5 39
40(defun copy-memory (from length &optional (to (allocate-memory length)))
41 (kernel:system-area-copy from 0 to 0 (* 8 length))
42 to)
43
44
c4e9d221 45;;;; User data mechanism
46
47(internal *user-data* *user-data-count*)
48
49(declaim (fixnum *user-data-count*))
50
c4e9d221 51(defvar *user-data* (make-hash-table))
52(defvar *user-data-count* 0)
53
54(defun register-user-data (object &optional destroy-function)
55 (check-type destroy-function (or null symbol function))
56 (incf *user-data-count*)
57 (setf
58 (gethash *user-data-count* *user-data*)
59 (cons object destroy-function))
60 *user-data-count*)
61
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)))
66
67(defun destroy-user-data (id)
68 (check-type id fixnum)
69 (let ((user-data (gethash id *user-data*)))
70 (when (cdr user-data)
71 (funcall (cdr user-data) (car user-data))))
72 (remhash id *user-data*))
73
560af5c5 74
0aef1da8 75;;;; Quarks
76
c4e9d221 77(internal *quark-counter* *quark-from-object* *quark-to-object*)
78
0aef1da8 79(deftype quark () 'unsigned)
80
5cae32e1 81;(defbinding %quark-get-reserved () quark)
415444ae 82
5cae32e1 83(defbinding %quark-from-string () quark
415444ae 84 (string string))
85
c4e9d221 86(defvar *quark-counter* 0)
415444ae 87
88(defun %quark-get-reserved ()
c4e9d221 89 ;; The string is just a dummy
90 (%quark-from-string (format nil "#@$%&-quark-~D" (incf *quark-counter*))))
0aef1da8 91
92(defvar *quark-from-object* (make-hash-table))
93(defvar *quark-to-object* (make-hash-table))
94
95(defun quark-from-object (object &key (test #'eq))
96 (let ((hash-code (sxhash object)))
97 (or
98 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
99 (let ((quark (%quark-get-reserved)))
ab566f2c 100 (setf
101 (gethash hash-code *quark-from-object*)
102 (append
103 (gethash hash-code *quark-from-object*)
104 (list (cons object quark))))
0aef1da8 105 (setf (gethash quark *quark-to-object*) object)
106 quark))))
107
108(defun quark-to-object (quark)
109 (gethash quark *quark-to-object*))
110
111(defun remove-quark (quark)
112 (let* ((object (gethash quark *quark-to-object*))
113 (hash-code (sxhash object)))
114 (remhash quark *quark-to-object*)
115 (unless (setf
116 (gethash hash-code *quark-from-object*)
117 (assoc-delete object (gethash hash-code *quark-from-object*)))
118 (remhash hash-code *quark-from-object*))))
119
120
121
3846c0b6 122;;;; Linked list (GList)
560af5c5 123
72e5ffec 124(deftype glist (type)
9adccb27 125 `(or (null (cons ,type list))))
560af5c5 126
72e5ffec 127(defbinding (%glist-append "g_list_append") () pointer
3846c0b6 128 (glist pointer)
72e5ffec 129 (nil null))
3846c0b6 130
9adccb27 131(defun make-glist (type list)
72e5ffec 132 (loop
133 with writer = (writer-function type)
134 for element in list
135 as glist = (%glist-append (or glist (make-pointer 0)))
136 do (funcall writer element glist)
137 finally (return glist)))
560af5c5 138
560af5c5 139(defun glist-next (glist)
140 (unless (null-pointer-p glist)
9adccb27 141 (sap-ref-sap glist +size-of-pointer+)))
560af5c5 142
9adccb27 143;; Also used for gslists
144(defun map-glist (seqtype function glist element-type)
145 (let ((reader (reader-function element-type)))
146 (case seqtype
147 ((nil)
148 (loop
149 as tmp = glist then (glist-next tmp)
150 until (null-pointer-p tmp)
151 do (funcall function (funcall reader tmp))))
152 (list
153 (loop
154 as tmp = glist then (glist-next tmp)
155 until (null-pointer-p tmp)
156 collect (funcall function (funcall reader tmp))))
157 (t
158 (coerce
159 (loop
160 as tmp = glist then (glist-next tmp)
161 until (null-pointer-p tmp)
162 collect (funcall function (funcall reader tmp)))
163 seqtype)))))
164
dba0c446 165(defbinding (glist-free "g_list_free") () nil
560af5c5 166 (glist pointer))
167
72e5ffec 168(defun destroy-glist (glist element-type)
169 (loop
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))
174 (glist-free glist))
415444ae 175
9adccb27 176(defmethod alien-type ((type (eql 'glist)) &rest args)
177 (declare (ignore type args))
178 (alien-type 'pointer))
179
180(defmethod size-of ((type (eql 'glist)) &rest args)
181 (declare (ignore type args))
415444ae 182 (size-of 'pointer))
560af5c5 183
9adccb27 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)))
188
189(defmethod to-alien-function ((type (eql 'glist)) &rest args)
8755b1a5 190 (declare (ignore type))
9adccb27 191 (destructuring-bind (element-type) args
192 #'(lambda (list)
193 (make-glist element-type list))))
194
195(defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
196 (declare (ignore type))
197 (destructuring-bind (element-type) args
560af5c5 198 `(let ((glist ,glist))
9adccb27 199 (unwind-protect
200 (map-glist 'list #'identity glist ',element-type)
72e5ffec 201 (destroy-glist glist ',element-type)))))
9adccb27 202
203(defmethod from-alien-function ((type (eql 'glist)) &rest args)
204 (declare (ignore type))
205 (destructuring-bind (element-type) args
206 #'(lambda (glist)
207 (unwind-protect
208 (map-glist 'list #'identity glist element-type)
72e5ffec 209 (destroy-glist glist element-type)))))
210
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)))
215
216(defmethod copy-from-alien-function ((type (eql 'glist)) &rest args)
217 (declare (ignore type))
218 (destructuring-bind (element-type) args
219 #'(lambda (glist)
220 (map-glist 'list #'identity glist element-type))))
9adccb27 221
222(defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
72e5ffec 223 (declare (ignore type))
224 (destructuring-bind (element-type) args
225 `(destroy-glist ,glist ',element-type)))
9adccb27 226
227(defmethod cleanup-function ((type (eql 'glist)) &rest args)
228 (declare (ignore type args))
72e5ffec 229 (destructuring-bind (element-type) args
230 #'(lambda (glist)
231 (destroy-glist glist element-type))))
560af5c5 232
233
3846c0b6 234;;;; Single linked list (GSList)
235
236(deftype gslist (type) `(or (null (cons ,type list))))
237
72e5ffec 238(defbinding (%gslist-prepend "g_slist_prepend") () pointer
3846c0b6 239 (gslist pointer)
72e5ffec 240 (nil null))
3846c0b6 241
9adccb27 242(defun make-gslist (type list)
72e5ffec 243 (loop
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)))
9adccb27 249
dba0c446 250(defbinding (gslist-free "g_slist_free") () nil
3846c0b6 251 (gslist pointer))
252
72e5ffec 253(defun destroy-gslist (gslist element-type)
254 (loop
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))
3846c0b6 260
9adccb27 261(defmethod alien-type ((type (eql 'gslist)) &rest args)
262 (declare (ignore type args))
263 (alien-type 'pointer))
264
265(defmethod size-of ((type (eql 'gslist)) &rest args)
266 (declare (ignore type args))
3846c0b6 267 (size-of 'pointer))
268
9adccb27 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)))
273
274(defmethod to-alien-function ((type (eql 'gslist)) &rest args)
8755b1a5 275 (declare (ignore type))
9adccb27 276 (destructuring-bind (element-type) args
277 #'(lambda (list)
278 (make-gslist element-type list))))
279
280(defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
281 (declare (ignore type))
282 (destructuring-bind (element-type) args
3846c0b6 283 `(let ((gslist ,gslist))
9adccb27 284 (unwind-protect
285 (map-glist 'list #'identity gslist ',element-type)
72e5ffec 286 (destroy-gslist gslist ',element-type)))))
3846c0b6 287
9adccb27 288(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
289 (declare (ignore type))
290 (destructuring-bind (element-type) args
291 #'(lambda (gslist)
292 (unwind-protect
293 (map-glist 'list #'identity gslist element-type)
72e5ffec 294 (destroy-gslist gslist element-type)))))
295
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)))
300
301(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
302 (declare (ignore type))
303 (destructuring-bind (element-type) args
304 #'(lambda (gslist)
305 (map-glist 'list #'identity gslist element-type))))
3846c0b6 306
72e5ffec 307(defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args)
9adccb27 308 (declare (ignore type args))
72e5ffec 309 (destructuring-bind (element-type) args
310 `(destroy-gslist ,gslist ',element-type)))
3846c0b6 311
9adccb27 312(defmethod cleanup-function ((type (eql 'gslist)) &rest args)
313 (declare (ignore type args))
72e5ffec 314 (destructuring-bind (element-type) args
315 #'(lambda (gslist)
316 (destroy-gslist gslist element-type))))
415444ae 317
5cae32e1 318
415444ae 319
9adccb27 320;;; Vector
415444ae 321
9adccb27 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)))
814ccf77 326 (etypecase content
327 (vector
328 (loop
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)))
333 (list
334 (loop
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))))
9adccb27 339 location))
340
341
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)))
dba0c446 345 (case seqtype
346 ((nil)
9adccb27 347 (loop
348 for i from 0 below length
349 as offset = 0 then (+ offset size-of-element)
350 do (funcall function (funcall reader location offset))))
dba0c446 351 (list
9adccb27 352 (loop
353 for i from 0 below length
354 as offset = 0 then (+ offset size-of-element)
355 collect (funcall function (funcall reader location offset))))
dba0c446 356 (t
9adccb27 357 (loop
358 with sequence = (make-sequence seqtype length)
359 for i from 0 below length
360 as offset = 0 then (+ offset size-of-element)
361 do (setf
dba0c446 362 (elt sequence i)
9adccb27 363 (funcall function (funcall reader location offset)))
364 finally (return sequence))))))
365
366
72e5ffec 367(defun destroy-c-vector (location element-type length)
368 (loop
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))
375
376
9adccb27 377(defmethod alien-type ((type (eql 'vector)) &rest args)
378 (declare (ignore type args))
379 (alien-type 'pointer))
380
381(defmethod size-of ((type (eql 'vector)) &rest args)
382 (declare (ignore type args))
383 (size-of 'pointer))
384
385(defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
386 (declare (ignore type))
387 (destructuring-bind (element-type &optional (length '*)) args
388 (if (eq length '*)
389 `(let* ((vector ,vector)
390 (location (sap+
391 (allocate-memory (+ ,+size-of-int+
392 (* ,(size-of element-type)
393 (length vector))))
394 ,+size-of-int+)))
395 (make-c-vector ',element-type (length vector) vector location)
396 (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
397 location)
398 `(make-c-vector ',element-type ,length ,vector))))
399
72e5ffec 400(defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args)
401 (declare (ignore type))
402 (destructuring-bind (element-type &optional (length '*)) args
403 (if (eq length '*)
404 (error "Can't use vector of variable size as return type")
405 `(let ((c-vector ,c-vector))
406 (prog1
407 (map-c-vector 'vector #'identity ',element-type ,length c-vector)
408 (destroy-c-vector c-vector ',element-type ,length))))))
409
410(defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args)
9adccb27 411 (declare (ignore type))
412 (destructuring-bind (element-type &optional (length '*)) args
413 (if (eq length '*)
414 (error "Can't use vector of variable size as return type")
72e5ffec 415 `(map-c-vector 'vector #'identity ',element-type ',length ,c-vector))))
9adccb27 416
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+))
423 length)))
424 (loop
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+))
431 'location)))))