chiark / gitweb /
Added type definition for gclosure
[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
c9219df2 18;; $Id: glib.lisp,v 1.23 2005-01-03 16:38:57 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
c9219df2 67(defun update-user-data (id object)
68 (check-type id fixnum)
69 (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
70 (cond
71 ((not exists-p) (error "User data id ~A does not exist" id))
72 (t
73 (when (cdr user-data)
74 (funcall (cdr user-data) (car user-data)))
75 (setf (car user-data) object)))))
76
c4e9d221 77(defun destroy-user-data (id)
78 (check-type id fixnum)
79 (let ((user-data (gethash id *user-data*)))
80 (when (cdr user-data)
81 (funcall (cdr user-data) (car user-data))))
82 (remhash id *user-data*))
83
560af5c5 84
0aef1da8 85;;;; Quarks
86
c4e9d221 87(internal *quark-counter* *quark-from-object* *quark-to-object*)
88
0aef1da8 89(deftype quark () 'unsigned)
90
5cae32e1 91;(defbinding %quark-get-reserved () quark)
415444ae 92
5cae32e1 93(defbinding %quark-from-string () quark
415444ae 94 (string string))
95
c4e9d221 96(defvar *quark-counter* 0)
415444ae 97
98(defun %quark-get-reserved ()
c4e9d221 99 ;; The string is just a dummy
100 (%quark-from-string (format nil "#@$%&-quark-~D" (incf *quark-counter*))))
0aef1da8 101
102(defvar *quark-from-object* (make-hash-table))
103(defvar *quark-to-object* (make-hash-table))
104
105(defun quark-from-object (object &key (test #'eq))
106 (let ((hash-code (sxhash object)))
107 (or
108 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
109 (let ((quark (%quark-get-reserved)))
ab566f2c 110 (setf
111 (gethash hash-code *quark-from-object*)
112 (append
113 (gethash hash-code *quark-from-object*)
114 (list (cons object quark))))
0aef1da8 115 (setf (gethash quark *quark-to-object*) object)
116 quark))))
117
118(defun quark-to-object (quark)
119 (gethash quark *quark-to-object*))
120
121(defun remove-quark (quark)
122 (let* ((object (gethash quark *quark-to-object*))
123 (hash-code (sxhash object)))
124 (remhash quark *quark-to-object*)
125 (unless (setf
126 (gethash hash-code *quark-from-object*)
127 (assoc-delete object (gethash hash-code *quark-from-object*)))
128 (remhash hash-code *quark-from-object*))))
129
130
131
3846c0b6 132;;;; Linked list (GList)
560af5c5 133
72e5ffec 134(deftype glist (type)
9adccb27 135 `(or (null (cons ,type list))))
560af5c5 136
72e5ffec 137(defbinding (%glist-append "g_list_append") () pointer
3846c0b6 138 (glist pointer)
72e5ffec 139 (nil null))
3846c0b6 140
9adccb27 141(defun make-glist (type list)
72e5ffec 142 (loop
143 with writer = (writer-function type)
144 for element in list
145 as glist = (%glist-append (or glist (make-pointer 0)))
146 do (funcall writer element glist)
147 finally (return glist)))
560af5c5 148
560af5c5 149(defun glist-next (glist)
150 (unless (null-pointer-p glist)
9adccb27 151 (sap-ref-sap glist +size-of-pointer+)))
560af5c5 152
9adccb27 153;; Also used for gslists
154(defun map-glist (seqtype function glist element-type)
155 (let ((reader (reader-function element-type)))
156 (case seqtype
157 ((nil)
158 (loop
159 as tmp = glist then (glist-next tmp)
160 until (null-pointer-p tmp)
161 do (funcall function (funcall reader tmp))))
162 (list
163 (loop
164 as tmp = glist then (glist-next tmp)
165 until (null-pointer-p tmp)
166 collect (funcall function (funcall reader tmp))))
167 (t
168 (coerce
169 (loop
170 as tmp = glist then (glist-next tmp)
171 until (null-pointer-p tmp)
172 collect (funcall function (funcall reader tmp)))
173 seqtype)))))
174
dba0c446 175(defbinding (glist-free "g_list_free") () nil
560af5c5 176 (glist pointer))
177
72e5ffec 178(defun destroy-glist (glist element-type)
179 (loop
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))
184 (glist-free glist))
415444ae 185
9adccb27 186(defmethod alien-type ((type (eql 'glist)) &rest args)
187 (declare (ignore type args))
188 (alien-type 'pointer))
189
190(defmethod size-of ((type (eql 'glist)) &rest args)
191 (declare (ignore type args))
415444ae 192 (size-of 'pointer))
560af5c5 193
9adccb27 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)))
198
199(defmethod to-alien-function ((type (eql 'glist)) &rest args)
8755b1a5 200 (declare (ignore type))
9adccb27 201 (destructuring-bind (element-type) args
202 #'(lambda (list)
203 (make-glist element-type list))))
204
205(defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
206 (declare (ignore type))
207 (destructuring-bind (element-type) args
560af5c5 208 `(let ((glist ,glist))
9adccb27 209 (unwind-protect
210 (map-glist 'list #'identity glist ',element-type)
72e5ffec 211 (destroy-glist glist ',element-type)))))
9adccb27 212
213(defmethod from-alien-function ((type (eql 'glist)) &rest args)
214 (declare (ignore type))
215 (destructuring-bind (element-type) args
216 #'(lambda (glist)
217 (unwind-protect
218 (map-glist 'list #'identity glist element-type)
72e5ffec 219 (destroy-glist glist element-type)))))
220
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)))
225
226(defmethod copy-from-alien-function ((type (eql 'glist)) &rest args)
227 (declare (ignore type))
228 (destructuring-bind (element-type) args
229 #'(lambda (glist)
230 (map-glist 'list #'identity glist element-type))))
9adccb27 231
232(defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
72e5ffec 233 (declare (ignore type))
234 (destructuring-bind (element-type) args
235 `(destroy-glist ,glist ',element-type)))
9adccb27 236
237(defmethod cleanup-function ((type (eql 'glist)) &rest args)
e8caa25a 238 (declare (ignore type))
72e5ffec 239 (destructuring-bind (element-type) args
240 #'(lambda (glist)
241 (destroy-glist glist element-type))))
560af5c5 242
e8caa25a 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))
247 (setf
248 (sap-ref-sap location offset)
249 (make-glist element-type list)))))
250
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)))))
257
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))))))
265
266
560af5c5 267
3846c0b6 268;;;; Single linked list (GSList)
269
270(deftype gslist (type) `(or (null (cons ,type list))))
271
72e5ffec 272(defbinding (%gslist-prepend "g_slist_prepend") () pointer
3846c0b6 273 (gslist pointer)
72e5ffec 274 (nil null))
3846c0b6 275
9adccb27 276(defun make-gslist (type list)
72e5ffec 277 (loop
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)))
9adccb27 283
dba0c446 284(defbinding (gslist-free "g_slist_free") () nil
3846c0b6 285 (gslist pointer))
286
72e5ffec 287(defun destroy-gslist (gslist element-type)
288 (loop
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))
3846c0b6 294
9adccb27 295(defmethod alien-type ((type (eql 'gslist)) &rest args)
296 (declare (ignore type args))
297 (alien-type 'pointer))
298
299(defmethod size-of ((type (eql 'gslist)) &rest args)
300 (declare (ignore type args))
3846c0b6 301 (size-of 'pointer))
302
9adccb27 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)))
307
308(defmethod to-alien-function ((type (eql 'gslist)) &rest args)
8755b1a5 309 (declare (ignore type))
9adccb27 310 (destructuring-bind (element-type) args
311 #'(lambda (list)
312 (make-gslist element-type list))))
313
314(defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
315 (declare (ignore type))
316 (destructuring-bind (element-type) args
3846c0b6 317 `(let ((gslist ,gslist))
9adccb27 318 (unwind-protect
319 (map-glist 'list #'identity gslist ',element-type)
72e5ffec 320 (destroy-gslist gslist ',element-type)))))
3846c0b6 321
9adccb27 322(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
323 (declare (ignore type))
324 (destructuring-bind (element-type) args
325 #'(lambda (gslist)
326 (unwind-protect
327 (map-glist 'list #'identity gslist element-type)
72e5ffec 328 (destroy-gslist gslist element-type)))))
329
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)))
334
335(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
336 (declare (ignore type))
337 (destructuring-bind (element-type) args
338 #'(lambda (gslist)
339 (map-glist 'list #'identity gslist element-type))))
3846c0b6 340
72e5ffec 341(defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args)
e8caa25a 342 (declare (ignore type))
72e5ffec 343 (destructuring-bind (element-type) args
344 `(destroy-gslist ,gslist ',element-type)))
3846c0b6 345
9adccb27 346(defmethod cleanup-function ((type (eql 'gslist)) &rest args)
e8caa25a 347 (declare (ignore type))
72e5ffec 348 (destructuring-bind (element-type) args
349 #'(lambda (gslist)
350 (destroy-gslist gslist element-type))))
415444ae 351
e8caa25a 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))
356 (setf
357 (sap-ref-sap location offset)
358 (make-gslist element-type list)))))
359
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)))))
366
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))))))
5cae32e1 374
415444ae 375
9adccb27 376;;; Vector
415444ae 377
9adccb27 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)))
814ccf77 382 (etypecase content
383 (vector
384 (loop
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)))
389 (list
390 (loop
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))))
9adccb27 395 location))
396
397
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)))
dba0c446 401 (case seqtype
402 ((nil)
9adccb27 403 (loop
404 for i from 0 below length
405 as offset = 0 then (+ offset size-of-element)
406 do (funcall function (funcall reader location offset))))
dba0c446 407 (list
9adccb27 408 (loop
409 for i from 0 below length
410 as offset = 0 then (+ offset size-of-element)
411 collect (funcall function (funcall reader location offset))))
dba0c446 412 (t
9adccb27 413 (loop
414 with sequence = (make-sequence seqtype length)
415 for i from 0 below length
416 as offset = 0 then (+ offset size-of-element)
417 do (setf
dba0c446 418 (elt sequence i)
9adccb27 419 (funcall function (funcall reader location offset)))
420 finally (return sequence))))))
421
422
72e5ffec 423(defun destroy-c-vector (location element-type length)
424 (loop
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))
431
432
9adccb27 433(defmethod alien-type ((type (eql 'vector)) &rest args)
434 (declare (ignore type args))
435 (alien-type 'pointer))
436
437(defmethod size-of ((type (eql 'vector)) &rest args)
438 (declare (ignore type args))
439 (size-of 'pointer))
440
441(defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
442 (declare (ignore type))
443 (destructuring-bind (element-type &optional (length '*)) args
444 (if (eq length '*)
445 `(let* ((vector ,vector)
446 (location (sap+
447 (allocate-memory (+ ,+size-of-int+
448 (* ,(size-of element-type)
449 (length vector))))
450 ,+size-of-int+)))
451 (make-c-vector ',element-type (length vector) vector location)
452 (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
453 location)
454 `(make-c-vector ',element-type ,length ,vector))))
455
72e5ffec 456(defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args)
457 (declare (ignore type))
458 (destructuring-bind (element-type &optional (length '*)) args
459 (if (eq length '*)
460 (error "Can't use vector of variable size as return type")
461 `(let ((c-vector ,c-vector))
462 (prog1
c9219df2 463 (map-c-vector 'vector #'identity c-vector ',element-type ,length)
72e5ffec 464 (destroy-c-vector c-vector ',element-type ,length))))))
465
466(defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args)
9adccb27 467 (declare (ignore type))
468 (destructuring-bind (element-type &optional (length '*)) args
469 (if (eq length '*)
470 (error "Can't use vector of variable size as return type")
c9219df2 471 `(map-c-vector 'vector #'identity ,c-vector ',element-type ',length))))
9adccb27 472
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+))
479 length)))
480 (loop
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+))
487 'location)))))
16bf1149 488
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))
493 (setf
494 (sap-ref-sap location offset)
495 (make-c-vector element-type length vector)))))
496
497(defmethod reader-function ((type (eql 'vector)) &rest args)
498 (declare (ignore type))
499 (destructuring-bind (element-type &optional (length '*)) args
500 (if (eq length '*)
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))))))
506
507(defmethod destroy-function ((type (eql 'vector)) &rest args)
508 (declare (ignore type))
509 (destructuring-bind (element-type &optional (length '*)) args
510 (if (eq length '*)
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))
514 (destroy-c-vector
515 (sap-ref-sap location offset) element-type length)
516 (setf (sap-ref-sap location offset) (make-pointer 0)))))))