New function UPDATE-USER-DATA and some bug fixes
[clg] / glib / gboxed.lisp
1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2001 Espen S. Johnsen <esj@stud.cs.uit.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
18 ;; $Id: gboxed.lisp,v 1.13 2004-11-09 10:10:59 espen Exp $
19
20 (in-package "GLIB")
21
22
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (init-types-in-library #.(concatenate 'string
25 (pkg-config:pkg-variable "glib-2.0" "libdir")
26 "/libgobject-2.0.so")))
27
28 (defclass boxed (struct)
29 ()
30 (:metaclass struct-class))
31
32 (defmethod instance-finalizer ((instance boxed))
33 (let ((location (proxy-location instance))
34 (type-number (type-number-of instance)))
35 #'(lambda ()
36 (remove-cached-instance location)
37 (%boxed-free type-number location))))
38
39
40 ;;;; Metaclass for boxed classes
41
42 (eval-when (:compile-toplevel :load-toplevel :execute)
43 (defclass boxed-class (struct-class)
44 ())
45
46 (defmethod validate-superclass ((class boxed-class) (super standard-class))
47 (subtypep (class-name super) 'boxed)))
48
49
50 (defmethod shared-initialize ((class boxed-class) names
51 &rest initargs &key name alien-name)
52 (declare (ignore initargs names))
53 (call-next-method)
54
55 (let* ((class-name (or name (class-name class)))
56 (type-number
57 (find-type-number
58 (or (first alien-name) (default-alien-type-name class-name)))))
59 (register-type class-name type-number)))
60
61
62 (defbinding %boxed-copy () pointer
63 (type-number type-number)
64 (location pointer))
65
66 (defbinding %boxed-free () nil
67 (type-number type-number)
68 (location pointer))
69
70 (defmethod reference-foreign ((class boxed-class) location)
71 (%boxed-copy (find-type-number class) location))
72
73 (defmethod unreference-foreign ((class boxed-class) location)
74 (%boxed-free (find-type-number class) location))
75
76
77 ;;;;
78
79 (defun expand-boxed-type (type-number &optional slots)
80 `(defclass ,(type-from-number type-number) (boxed)
81 ,slots
82 (:metaclass boxed-class)
83 (:alien-name ,(find-type-name type-number))))
84
85 (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type)
86
87 ;;;; Special boxed types
88
89 ;; (defclass gstring (boxed)
90 ;; ()
91 ;; (:metaclass boxed-class)
92 ;; (:alien-name "GString"))
93
94 ;; (deftype-method translate-from-alien
95 ;; gstring (type-spec location &optional weak-ref)
96 ;; `(let ((location ,location))
97 ;; (unless (null-pointer-p location)
98 ;; (prog1
99 ;; (c-call::%naturalize-c-string location)
100 ;; ,(unless weak-ref
101 ;; (unreference-alien type-spec location))))))
102
103 ;; (deftype-method translate-to-alien
104 ;; gstring (type-spec string &optional weak-ref)
105 ;; (declare (ignore weak-ref))
106 ;; `(let ((string ,string))
107 ;; ;; Always copy strings to prevent seg fault due to GC
108 ;; (funcall
109 ;; ',(proxy-class-copy (find-class type-spec))
110 ;; ',type-spec
111 ;; (make-pointer (1+ (kernel:get-lisp-obj-address string))))))
112
113 ;; (deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref)
114 ;; (when weak-ref
115 ;; (unreference-alien type-spec c-string)))
116