chiark / gitweb /
Added pseudo type COPY-OF
[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
814ccf77 18;; $Id: glib.lisp,v 1.19 2004-11-12 13:27:41 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
9adccb27 124(deftype glist (type &key copy)
125 (declare (ignore copy))
126 `(or (null (cons ,type list))))
560af5c5 127
dba0c446 128(defbinding (%glist-append-unsigned "g_list_append") () pointer
3846c0b6 129 (glist pointer)
560af5c5 130 (data unsigned))
131
dba0c446 132(defbinding (%glist-append-signed "g_list_append") () pointer
3846c0b6 133 (glist pointer)
134 (data signed))
135
dba0c446 136(defbinding (%glist-append-sap "g_list_append") () pointer
3846c0b6 137 (glist pointer)
138 (data pointer))
139
9adccb27 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)))
149 (loop
150 for element in list
151 as glist = (funcall new-element (or glist (make-pointer 0))
152 (funcall to-alien element))
153 finally (return glist))))
560af5c5 154
560af5c5 155(defun glist-next (glist)
156 (unless (null-pointer-p glist)
9adccb27 157 (sap-ref-sap glist +size-of-pointer+)))
560af5c5 158
9adccb27 159;; Also used for gslists
160(defun map-glist (seqtype function glist element-type)
161 (let ((reader (reader-function element-type)))
162 (case seqtype
163 ((nil)
164 (loop
165 as tmp = glist then (glist-next tmp)
166 until (null-pointer-p tmp)
167 do (funcall function (funcall reader tmp))))
168 (list
169 (loop
170 as tmp = glist then (glist-next tmp)
171 until (null-pointer-p tmp)
172 collect (funcall function (funcall reader tmp))))
173 (t
174 (coerce
175 (loop
176 as tmp = glist then (glist-next tmp)
177 until (null-pointer-p tmp)
178 collect (funcall function (funcall reader tmp)))
179 seqtype)))))
180
dba0c446 181(defbinding (glist-free "g_list_free") () nil
560af5c5 182 (glist pointer))
183
415444ae 184
9adccb27 185(defmethod alien-type ((type (eql 'glist)) &rest args)
186 (declare (ignore type args))
187 (alien-type 'pointer))
188
189(defmethod size-of ((type (eql 'glist)) &rest args)
190 (declare (ignore type args))
415444ae 191 (size-of 'pointer))
560af5c5 192
9adccb27 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)))
197
198(defmethod to-alien-function ((type (eql 'glist)) &rest args)
8755b1a5 199 (declare (ignore type))
9adccb27 200 (destructuring-bind (element-type) args
201 #'(lambda (list)
202 (make-glist element-type list))))
203
204(defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
205 (declare (ignore type))
206 (destructuring-bind (element-type) args
560af5c5 207 `(let ((glist ,glist))
9adccb27 208 (unwind-protect
209 (map-glist 'list #'identity glist ',element-type)
210 (glist-free glist)))))
211
212(defmethod from-alien-function ((type (eql 'glist)) &rest args)
213 (declare (ignore type))
214 (destructuring-bind (element-type) args
215 #'(lambda (glist)
216 (unwind-protect
217 (map-glist 'list #'identity glist element-type)
218 (glist-free glist)))))
219
220(defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
221 (declare (ignore type args))
222 `(glist-free ,glist))
223
224(defmethod cleanup-function ((type (eql 'glist)) &rest args)
225 (declare (ignore type args))
226 #'glist-free)
227
560af5c5 228
229
3846c0b6 230;;;; Single linked list (GSList)
231
232(deftype gslist (type) `(or (null (cons ,type list))))
233
dba0c446 234(defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer
3846c0b6 235 (gslist pointer)
236 (data unsigned))
237
dba0c446 238(defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer
3846c0b6 239 (gslist pointer)
240 (data signed))
241
dba0c446 242(defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
3846c0b6 243 (gslist pointer)
244 (data pointer))
245
9adccb27 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)))
255 (loop
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))))
260
dba0c446 261(defbinding (gslist-free "g_slist_free") () nil
3846c0b6 262 (gslist pointer))
263
3846c0b6 264
9adccb27 265(defmethod alien-type ((type (eql 'gslist)) &rest args)
266 (declare (ignore type args))
267 (alien-type 'pointer))
268
269(defmethod size-of ((type (eql 'gslist)) &rest args)
270 (declare (ignore type args))
3846c0b6 271 (size-of 'pointer))
272
9adccb27 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)))
277
278(defmethod to-alien-function ((type (eql 'gslist)) &rest args)
8755b1a5 279 (declare (ignore type))
9adccb27 280 (destructuring-bind (element-type) args
281 #'(lambda (list)
282 (make-gslist element-type list))))
283
284(defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
285 (declare (ignore type))
286 (destructuring-bind (element-type) args
3846c0b6 287 `(let ((gslist ,gslist))
9adccb27 288 (unwind-protect
289 (map-glist 'list #'identity gslist ',element-type)
290 (gslist-free gslist)))))
3846c0b6 291
9adccb27 292(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
293 (declare (ignore type))
294 (destructuring-bind (element-type) args
295 #'(lambda (gslist)
296 (unwind-protect
297 (map-glist 'list #'identity gslist element-type)
298 (gslist-free gslist)))))
3846c0b6 299
9adccb27 300(defmethod cleanup-form (list (type (eql 'gslist)) &rest args)
301 (declare (ignore type args))
302 `(gslist-free ,list))
3846c0b6 303
9adccb27 304(defmethod cleanup-function ((type (eql 'gslist)) &rest args)
305 (declare (ignore type args))
306 #'gslist-free)
415444ae 307
5cae32e1 308
415444ae 309
9adccb27 310;;; Vector
415444ae 311
9adccb27 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)))
814ccf77 316 (etypecase content
317 (vector
318 (loop
319 for element across content
320 for i from 0 below length
321 as offset = 0 then (+ offset size-of-type)
322 do (funcall writer element location offset)))
323 (list
324 (loop
325 for element in content
326 for i from 0 below length
327 as offset = 0 then (+ offset size-of-type)
328 do (funcall writer element location offset))))
9adccb27 329 location))
330
331
332(defun map-c-vector (seqtype function location element-type length)
333 (let ((reader (reader-function element-type))
334 (size-of-element (size-of element-type)))
dba0c446 335 (case seqtype
336 ((nil)
9adccb27 337 (loop
338 for i from 0 below length
339 as offset = 0 then (+ offset size-of-element)
340 do (funcall function (funcall reader location offset))))
dba0c446 341 (list
9adccb27 342 (loop
343 for i from 0 below length
344 as offset = 0 then (+ offset size-of-element)
345 collect (funcall function (funcall reader location offset))))
dba0c446 346 (t
9adccb27 347 (loop
348 with sequence = (make-sequence seqtype length)
349 for i from 0 below length
350 as offset = 0 then (+ offset size-of-element)
351 do (setf
dba0c446 352 (elt sequence i)
9adccb27 353 (funcall function (funcall reader location offset)))
354 finally (return sequence))))))
355
356
357(defmethod alien-type ((type (eql 'vector)) &rest args)
358 (declare (ignore type args))
359 (alien-type 'pointer))
360
361(defmethod size-of ((type (eql 'vector)) &rest args)
362 (declare (ignore type args))
363 (size-of 'pointer))
364
365(defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
366 (declare (ignore type))
367 (destructuring-bind (element-type &optional (length '*)) args
368 (if (eq length '*)
369 `(let* ((vector ,vector)
370 (location (sap+
371 (allocate-memory (+ ,+size-of-int+
372 (* ,(size-of element-type)
373 (length vector))))
374 ,+size-of-int+)))
375 (make-c-vector ',element-type (length vector) vector location)
376 (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
377 location)
378 `(make-c-vector ',element-type ,length ,vector))))
379
380(defmethod from-alien-form (location (type (eql 'vector)) &rest args)
381 (declare (ignore type))
382 (destructuring-bind (element-type &optional (length '*)) args
383 (if (eq length '*)
384 (error "Can't use vector of variable size as return type")
385 `(map-c-vector 'vector #'identity ',element-type ',length ,location))))
386
387(defmethod cleanup-form (location (type (eql 'vector)) &rest args)
388 (declare (ignore type))
389 (destructuring-bind (element-type &optional (length '*)) args
390 `(let* ((location ,location)
391 (length ,(if (eq length '*)
392 `(sap-ref-32 location ,(- +size-of-int+))
393 length)))
394 (loop
395 with destroy = (destroy-function ',element-type)
396 for i from 0 below length
397 as offset = 0 then (+ offset ,(size-of element-type))
398 do (funcall destroy location offset))
399 (deallocate-memory ,(if (eq length '*)
400 `(sap+ location ,(- +size-of-int+))
401 'location)))))