chiark / gitweb /
Bug fix: boxed should have struct as super class
[clg] / glib / ginterface.lisp
... / ...
CommitLineData
1;; Common Lisp bindings for GTK+ v2.0
2;; Copyright (C) 2001 Espen S. Johnsen <espen@users.sourceforge.net>
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: ginterface.lisp,v 1.5 2004-11-07 15:54:15 espen Exp $
19
20(in-package "GLIB")
21
22(use-prefix "g")
23
24;;;;
25
26(defclass ginterface ()
27 ())
28
29;;;; Metaclass for interfaces
30
31(eval-when (:compile-toplevel :load-toplevel :execute)
32 (defclass ginterface-class (virtual-slots-class)
33 ()))
34
35(defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs)
36 (case (getf initargs :allocation)
37 (:property (find-class 'direct-property-slot-definition))
38 (t (call-next-method))))
39
40(defmethod effective-slot-definition-class ((class ginterface-class) &rest initargs)
41 (case (getf initargs :allocation)
42 (:property (find-class 'effective-property-slot-definition))
43 (t (call-next-method))))
44
45(defmethod compute-effective-slot-definition-initargs ((class ginterface-class) direct-slotds)
46 (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
47 (nconc
48 (list :pname (signal-name-to-string
49 (most-specific-slot-value direct-slotds 'pname))
50 :readable (most-specific-slot-value direct-slotds 'readable)
51 :writable (most-specific-slot-value direct-slotds 'writable)
52 :construct (most-specific-slot-value direct-slotds 'construct))
53 (call-next-method))
54 (call-next-method)))
55
56
57(defmethod shared-initialize ((class ginterface-class) names
58 &rest initargs &key name alien-name)
59 (declare (ignore initargs names))
60 (let* ((class-name (or name (class-name class)))
61 (type-number
62 (find-type-number
63 (or (first alien-name) (default-alien-type-name class-name)) t)))
64 (register-type class-name type-number))
65 (call-next-method))
66
67
68(defmethod validate-superclass
69 ((class ginterface-class) (super pcl::standard-class))
70 (subtypep (class-name super) 'ginterface))
71
72
73(defmethod alien-type ((class ginterface-class) &rest args)
74 (declare (ignore class args))
75 (alien-type 'gobject))
76
77(defmethod size-of ((class ginterface-class) &rest args)
78 (declare (ignore class args))
79 (size-of 'gobject))
80
81(defmethod from-alien-form (location (class ginterface-class) &rest args)
82 (declare (ignore class args))
83 (from-alien-form location 'gobject))
84
85(defmethod from-alien-function ((class ginterface-class) &rest args)
86 (declare (ignore class args))
87 (from-alien-function 'gobject))
88
89(defmethod to-alien-form (instance (class ginterface-class) &rest args)
90 (declare (ignore class args))
91 (to-alien-form instance 'gobject))
92
93(defmethod to-alien-function ((class ginterface-class) &rest args)
94 (declare (ignore class args))
95 (to-alien-function 'gobject))
96
97(defmethod reader-function ((class ginterface-class) &rest args)
98 (declare (ignore class args))
99 (reader-function 'gobject))
100
101(defmethod writer-function ((class ginterface-class) &rest args)
102 (declare (ignore class args))
103 (writer-function 'gobject))
104
105(defmethod destroy-function ((class ginterface-class) &rest args)
106 (declare (ignore class args))
107 (destroy-function 'gobject))
108
109
110;;;;
111
112
113(defbinding type-default-interface-ref (type) pointer
114 ((find-type-number type t) type-number))
115
116(defbinding type-default-interface-unref (type) nil
117 ((find-type-number type t) type-number))
118
119(defbinding type-default-interface-peek (type) pointer
120 ((find-type-number type t) type-number))
121
122(defbinding %object-interface-list-properties () pointer
123 (iface pointer)
124 (n-properties unsigned-int :out))
125
126(defun query-object-interface-properties (type &optional inherited-p)
127 (let* ((type-number (find-type-number type))
128 (iface (type-default-interface-ref type-number)))
129 (unwind-protect
130 (multiple-value-bind (array length)
131 (%object-interface-list-properties iface)
132 (unwind-protect
133 (%map-params array length type-number inherited-p)
134 (deallocate-memory array)))
135; (type-default-interface-unref type-number)
136 )))
137
138
139(defun expand-ginterface-type (type options &rest args)
140 (declare (ignore args))
141 (let ((class (type-from-number type))
142 (slots (getf options :slots)))
143 `(defclass ,class (,(supertype type))
144 ,(slot-definitions class (query-object-interface-properties type) slots)
145 (:metaclass ginterface-class)
146 (:alien-name ,(find-type-name type)))))
147
148
149(register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type)