chiark / gitweb /
220002efd145a059d09b7cfc9b2d3f74997fbcd8
[clg] / glib / glib.lisp
1 ;; Common Lisp bindings for GTK+ 2.x
2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
3 ;;
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
11 ;;
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
14 ;;
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23 ;; $Id: glib.lisp,v 1.43 2008-04-01 21:17:59 espen Exp $
24
25
26 (in-package "GLIB")
27
28 (use-prefix "g")
29
30 #-sb-thread
31 (progn
32   (defun make-mutex ()
33     nil)
34   
35   (defmacro with-mutex ((mutex) &body body)
36     (declare (ignore mutex))
37     `(progn ,@body)))
38
39
40 ;;;; Memory management
41
42 (defbinding (%allocate-memory "g_malloc0") () pointer
43   (size unsigned-long))
44
45 (defbinding (%deallocate-memory "g_free") () nil
46   (address pointer))
47
48 ;; (setf
49 ;;  (symbol-function 'allocate-memory) #'%allocate-memory
50 ;;  (symbol-function 'deallocate-memory) #'%deallocate-memory)
51
52 (setf *memory-allocator* #'%allocate-memory)
53 (setf *memory-deallocator* #'%deallocate-memory)
54
55 (defbinding (reallocate-memory "g_realloc") () pointer
56   (address pointer)
57   (size unsigned-long))
58
59 (deftype gsize () 'unsigned-int)
60
61 (defbinding (slice-alloc "g_slice_alloc0") () pointer
62   (block-size gsize))
63
64 ;;;; User data is a mechanism to store references to lisp objects in
65 ;;;; foreign code
66
67 (defvar *user-data-lock* (make-mutex))
68 (defvar *user-data* (make-hash-table))
69 (defvar *user-data-next-id* 1)
70
71 (defun register-user-data (object &optional destroy-function)
72   (check-type destroy-function (or null symbol function))
73   (with-mutex (*user-data-lock*)
74     (setf
75      (gethash *user-data-next-id* *user-data*)
76      (cons object destroy-function))
77     (1- (incf *user-data-next-id*))))
78
79 (defun find-user-data (id)
80   (check-type id fixnum)
81   (with-mutex (*user-data-lock*)
82     (multiple-value-bind (user-data p) (gethash id *user-data*)
83       (values (car user-data) p))))
84
85 (defun user-data-exists-p (id)
86   (nth-value 1 (find-user-data id)))
87
88 (defun update-user-data (id object)
89   (check-type id fixnum)
90   (with-mutex (*user-data-lock*)
91     (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
92       (cond
93        ((not exists-p) (error "User data id ~A does not exist" id))
94        (t 
95         (when (cdr user-data)
96           (funcall (cdr user-data) (car user-data)))
97         (setf (car user-data) object))))))
98
99 (defun destroy-user-data (id)
100   (check-type id fixnum)
101   (with-mutex (*user-data-lock*)
102     (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
103       (cond
104 ;       ((not exists-p) (error "User data id ~A does not exist" id))
105        (t
106         (when (cdr user-data)
107           (funcall (cdr user-data) (car user-data)))
108         (remhash id *user-data*))))))
109
110 (defun take-user-data (id)
111   (check-type id fixnum)
112   (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
113     (cond
114       ((not exists-p) (error "User data id ~A does not exist" id))
115       (t 
116         (when (cdr user-data)
117           (funcall (cdr user-data) (car user-data)))
118         (remhash id *user-data*)
119         (car user-data)))))
120
121 (defmacro with-user-data ((var object) &body body)
122   `(let ((,var (register-user-data ,object)))
123      (unwind-protect
124           ,@body
125        (destroy-user-data ,var))))
126
127
128 (deftype user-data-id () 'pointer-data)
129
130
131 ;;;; Quarks
132
133 (deftype quark () 'unsigned)
134
135 (defbinding %quark-from-string () quark
136   (string string))
137
138 (defun quark-intern (object)
139   (etypecase object
140     (quark object)
141     (string (%quark-from-string object))
142     (symbol (%quark-from-string (format nil "clg-~A:~A" 
143                                  (package-name (symbol-package object)) 
144                                  object)))))
145
146 (defbinding quark-to-string () (static string)
147   (quark quark))
148
149
150 ;;;; Linked list (GList)
151
152 (deftype glist (type) 
153   `(or null (cons ,type list)))
154
155 (defbinding (%glist-prepend "g_list_prepend") () pointer
156   (glist (or null pointer))
157   (nil null))
158
159 (defbinding (%glist-reverse "g_list_reverse") () pointer
160   (glist (or null pointer)))
161
162 (defun make-glist (element-type list &optional temp-p)
163   (let ((writer (if (functionp element-type)
164                     element-type
165                   (writer-function element-type :temp temp-p))))
166     (loop
167      for element in list
168      as glist = (%glist-prepend nil) then (%glist-prepend glist)
169      do (funcall writer element glist)
170      finally (return (%glist-reverse glist)))))
171
172 (defun glist-next (glist)
173   (unless (null-pointer-p glist)
174     (ref-pointer glist #.(size-of 'pointer))))
175   
176 ;; Also used for gslists
177 (defun map-glist (seqtype function glist element-type &optional (ref :read))
178   (let ((reader (if (functionp element-type)
179                     element-type
180                   (reader-function element-type :ref ref))))
181     (case seqtype 
182      ((nil)
183       (loop
184        as element = glist then (glist-next element)
185        until (null-pointer-p element)
186        do (funcall function (funcall reader element))))
187      (list
188       (loop
189        as element = glist then (glist-next element)
190        until (null-pointer-p element)
191        collect (funcall function (funcall reader element))))
192      (t
193       (coerce 
194        (loop
195         as element = glist then (glist-next element)
196         until (null-pointer-p element)
197         collect (funcall function (funcall reader element)))
198        seqtype)))))
199
200 (defbinding (glist-free "g_list_free") () nil
201   (glist pointer))
202
203 (defun destroy-glist (glist element-type &optional temp-p)
204   (let ((destroy (if (functionp element-type)
205                      element-type
206                    (destroy-function element-type :temp temp-p))))
207     (loop
208      as element = glist then (glist-next element)
209      until (null-pointer-p element)
210      do (funcall destroy element)))
211   (glist-free glist))
212
213 (define-type-method alien-type ((type glist))
214   (declare (ignore type))
215   (alien-type 'pointer))
216
217 (define-type-method argument-type ((type glist))
218   'list)
219
220 (define-type-method return-type ((type glist))
221   'list)
222
223 (define-type-method size-of ((type glist) &key inlined)
224   (assert-not-inlined type inlined)
225   (size-of 'pointer))
226
227 (define-type-method type-alignment ((type glist) &key inlined)
228   (assert-not-inlined type inlined)
229   (type-alignment 'pointer))
230
231 (define-type-method alien-arg-wrapper ((type glist) var list style form &optional copy-in-p)
232   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
233     (cond
234       ((and (in-arg-p style) (not (out-arg-p style)))
235        `(with-pointer (,var (make-glist ',element-type ,list ,(not copy-in-p)))
236           (unwind-protect
237               ,form
238             ,(unless copy-in-p
239                `(destroy-glist ,var ',element-type t)))))
240       ((and (in-arg-p style) (out-arg-p style))
241        (let ((glist (make-symbol "GLIST")))
242          `(with-pointer (,glist (make-glist ',element-type ,list ,(not copy-in-p)))
243             (with-pointer (,var ,glist)               
244               (unwind-protect
245                   ,form
246                 ,(unless copy-in-p
247                    `(destroy-glist ,glist ',element-type t)))))))
248       ((and (out-arg-p style) (not (in-arg-p style)))
249        `(with-pointer (,var)
250           ,form)))))
251
252 (define-type-method to-alien-form ((type glist) list &optional copy-p)
253   (declare (ignore copy-p))
254   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
255     `(make-glist ',element-type ,list)))
256
257 (define-type-method to-alien-function ((type glist) &optional copy-p)
258   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
259     (values
260      #'(lambda (list)
261          (make-glist element-type list (not copy-p)))
262      (unless copy-p
263        #'(lambda (list glist)
264            (declare (ignore list))
265            (destroy-glist glist element-type t))))))
266
267 (define-type-method from-alien-form ((type glist) form &key (ref :free))
268   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
269     `(let ((glist ,form))
270        (unwind-protect
271            (map-glist 'list #'identity glist ',element-type 
272             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
273          ,(when (eq ref :free)
274             `(destroy-glist glist ',element-type))))))
275
276 (define-type-method from-alien-function ((type glist) &key (ref :free))
277   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
278     (ecase ref
279       (:free 
280        #'(lambda (glist)
281            (prog1
282                (map-glist 'list #'identity glist element-type :get)
283              (glist-free glist))))
284       (:copy
285        #'(lambda (glist)
286            (map-glist 'list #'identity glist element-type :read)))
287       ((:static :temp)
288        #'(lambda (glist)
289            (map-glist 'list #'identity glist element-type :peek))))))
290
291 (define-type-method writer-function ((type glist) &key temp inlined)
292   (assert-not-inlined type inlined)
293   (let ((element-type (second (type-expand-to 'glist type))))
294     #'(lambda (list location &optional (offset 0))
295         (setf 
296          (ref-pointer location offset)
297          (make-glist element-type list temp)))))
298
299 (define-type-method reader-function ((type glist) &key (ref :read) inlined)
300   (assert-not-inlined type inlined)
301   (let ((element-type (second (type-expand-to 'glist type))))
302     (ecase ref
303       ((:read :peek)
304        #'(lambda (location &optional (offset 0))
305            (unless (null-pointer-p (ref-pointer location offset))
306              (map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
307       (:get
308        #'(lambda (location &optional (offset 0))
309            (unless (null-pointer-p (ref-pointer location offset))
310              (prog1
311                  (map-glist 'list #'identity (ref-pointer location offset) element-type :get)
312                (glist-free (ref-pointer location offset))
313                (setf (ref-pointer location offset) (make-pointer 0)))))))))
314
315 (define-type-method destroy-function ((type glist) &key temp inlined)
316   (assert-not-inlined type inlined)
317   (let ((element-type (second (type-expand-to 'glist type))))
318     #'(lambda (location &optional (offset 0))
319         (unless (null-pointer-p (ref-pointer location offset))
320           (destroy-glist (ref-pointer location offset) element-type temp)
321           (setf (ref-pointer location offset) (make-pointer 0))))))
322
323 (define-type-method copy-function ((type glist) &key inlined)
324   (assert-not-inlined type inlined)
325   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
326     (let ((copy-element (copy-function element-type)))
327       #'(lambda (from to &optional (offset 0))
328           (unless (null-pointer-p (ref-pointer from offset))
329             (loop
330              as from-list = (ref-pointer from offset) then (glist-next from-list)
331              as to-list = (%glist-prepend nil) then (%glist-prepend to-list)
332              do (funcall copy-element from-list to-list)
333              while (glist-next from-list)
334              finally (setf (ref-pointer to offset) (%glist-reverse to-list))))))))
335
336
337 ;;;; Single linked list (GSList)
338
339 (deftype gslist (type) `(or null (cons ,type list)))
340
341 (defbinding (%gslist-prepend "g_slist_prepend") () pointer
342   (gslist pointer)
343   (nil null))
344
345 (defbinding (%gslist-append "g_slist_append") () pointer
346   (glist (or null pointer))
347   (nil null))
348
349
350 (defun make-gslist (element-type list &optional temp-p)
351   (let ((writer (if (functionp element-type)
352                     element-type
353                   (writer-function element-type :temp temp-p))))
354     (loop
355      for element in (reverse list)
356      as gslist = (%gslist-prepend (make-pointer 0)) then (%gslist-prepend gslist)
357      do (funcall writer element gslist)
358      finally (return gslist))))
359
360 (defbinding (gslist-free "g_slist_free") () nil
361   (gslist pointer))
362
363 (defun destroy-gslist (gslist element-type &optional temp-p)
364   (loop
365    with destroy = (destroy-function element-type :temp temp-p)
366    as element = gslist then (glist-next element)
367    until (null-pointer-p element)
368    do (funcall destroy element 0))
369   (gslist-free gslist))
370
371 (define-type-method alien-type ((type gslist))
372   (declare (ignore type))
373   (alien-type 'pointer))
374
375 (define-type-method argument-type ((type gslist))
376   'list)
377
378 (define-type-method return-type ((type gslist))
379   'list)
380
381 (define-type-method size-of ((type gslist) &key inlined)
382   (assert-not-inlined type inlined)
383   (size-of 'pointer))
384
385 (define-type-method type-alignment ((type gslist) &key inlined)
386   (assert-not-inlined type inlined)
387   (type-alignment 'pointer))
388
389 (define-type-method alien-arg-wrapper ((type gslist) var list style form &optional copy-in-p)
390   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
391     (cond
392       ((and (in-arg-p style) (not (out-arg-p style)))
393        `(with-pointer (,var (make-gslist ',element-type ,list ,(not copy-in-p)))
394           (unwind-protect
395               ,form
396             ,(unless copy-in-p
397                `(destroy-gslist ,var ',element-type t)))))
398       ((and (in-arg-p style) (out-arg-p style))
399        (let ((gslist (make-symbol "GSLIST")))
400          `(with-pointer (,gslist (make-gslist ',element-type ,list ,(not copy-in-p)))
401             (with-pointer (,var ,gslist)                      
402               (unwind-protect
403                   ,form
404                 ,(unless copy-in-p
405                    `(destroy-gslist ,gslist ',element-type t)))))))
406       ((and (out-arg-p style) (not (in-arg-p style)))
407        `(with-pointer (,var)
408           ,form)))))
409
410 (define-type-method to-alien-form ((type gslist) list &optional copy-p)
411   (declare (ignore copy-p))
412   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
413     `(make-gslist ',element-type ,list)))
414
415 (define-type-method to-alien-function ((type gslist) &optional copy-p)
416   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
417     (values
418      #'(lambda (list)
419          (make-gslist element-type list (not copy-p)))
420      (unless copy-p
421        #'(lambda (list gslist)
422            (declare (ignore list))
423            (destroy-gslist gslist element-type t))))))
424
425 (define-type-method from-alien-form ((type gslist) form &key (ref :free))
426   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
427     `(let ((gslist ,form))
428        (unwind-protect
429            (map-glist 'list #'identity gslist ',element-type
430             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
431          ,(when (eq ref :free)
432             `(destroy-gslist gslist ',element-type))))))
433
434 (define-type-method from-alien-function ((type gslist)  &key (ref :free))
435   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
436     (ecase ref
437       (:free 
438        #'(lambda (glist)
439            (prog1
440                (map-glist 'list #'identity glist element-type :get)
441              (gslist-free glist))))
442       (:copy
443        #'(lambda (glist)
444            (map-glist 'list #'identity glist element-type :read)))
445       ((:static :temp)
446        #'(lambda (glist)
447            (map-glist 'list #'identity glist element-type :peek))))))
448
449 (define-type-method writer-function ((type gslist) &key temp inlined)
450   (assert-not-inlined type inlined)
451   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
452     (let ((element-writer (writer-function element-type :temp temp)))
453       #'(lambda (list location &optional (offset 0))
454           (setf 
455            (ref-pointer location offset)
456            (make-gslist element-writer list))))))
457
458 (define-type-method reader-function ((type gslist) &key (ref :read) inlined)
459   (assert-not-inlined type inlined)
460   (let ((element-type (second (type-expand-to 'gslist type))))
461     (ecase ref
462       ((:read :peek)
463        #'(lambda (location &optional (offset 0))
464            (unless (null-pointer-p (ref-pointer location offset))
465              (map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
466       (:get
467        #'(lambda (location &optional (offset 0))
468            (unless (null-pointer-p (ref-pointer location offset))
469              (prog1
470                  (map-glist 'list #'identity (ref-pointer location offset) element-type :get)
471                (gslist-free (ref-pointer location offset))
472                (setf (ref-pointer location offset) (make-pointer 0)))))))))
473
474 (define-type-method destroy-function ((type gslist) &key temp inlined)
475   (assert-not-inlined type inlined)
476   (let ((element-type (second (type-expand-to 'gslist type))))
477     #'(lambda (location &optional (offset 0))
478         (unless (null-pointer-p (ref-pointer location offset))
479           (destroy-gslist (ref-pointer location offset) element-type temp)
480           (setf (ref-pointer location offset) (make-pointer 0))))))
481
482 (define-type-method copy-function ((type gslist) &key inlined)
483   (assert-not-inlined type inlined)
484   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
485     (let ((copy-element (copy-function element-type)))
486       #'(lambda (from to &optional (offset 0))
487           (unless (null-pointer-p (ref-pointer from offset))
488             (loop
489              as from-list = (ref-pointer from offset) 
490                             then (glist-next from-list)
491              as to-list = (setf (ref-pointer to offset) (%gslist-append nil)) 
492                           then (%gslist-append to-list)
493              do (funcall copy-element from-list to-list)
494              while (glist-next from-list)))))))