chiark / gitweb /
Changes necessary to allow saving of core images with clg.
[clg] / glib / ginterface.lisp
CommitLineData
573b21cc 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
dfa4f314 18;; $Id: ginterface.lisp,v 1.9 2005-03-06 17:26:23 espen Exp $
573b21cc 19
20(in-package "GLIB")
21
22(use-prefix "g")
23
24;;;;
25
4d83a8a6 26(defclass ginterface ()
27 ())
573b21cc 28
573b21cc 29;;;; Metaclass for interfaces
30
31(eval-when (:compile-toplevel :load-toplevel :execute)
9adccb27 32 (defclass ginterface-class (virtual-slots-class)
4d83a8a6 33 ()))
573b21cc 34
9c03a07c 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
573b21cc 56
dfa4f314 57(defmethod shared-initialize ((class ginterface-class) names &key name gtype)
58 (declare (ignore names))
59 (let ((class-name (or name (class-name class))))
60 (unless (find-type-number class-name)
61 (register-type class-name
62 (or (first gtype) (default-type-init-name class-name)))))
573b21cc 63 (call-next-method))
64
65
73572c12 66(defmethod validate-superclass ((class ginterface-class) (super standard-class))
573b21cc 67 (subtypep (class-name super) 'ginterface))
68
69
9adccb27 70(defmethod alien-type ((class ginterface-class) &rest args)
71 (declare (ignore class args))
72 (alien-type 'gobject))
73
74(defmethod size-of ((class ginterface-class) &rest args)
75 (declare (ignore class args))
76 (size-of 'gobject))
77
78(defmethod from-alien-form (location (class ginterface-class) &rest args)
79 (declare (ignore class args))
80 (from-alien-form location 'gobject))
81
82(defmethod from-alien-function ((class ginterface-class) &rest args)
83 (declare (ignore class args))
84 (from-alien-function 'gobject))
85
86(defmethod to-alien-form (instance (class ginterface-class) &rest args)
87 (declare (ignore class args))
88 (to-alien-form instance 'gobject))
89
90(defmethod to-alien-function ((class ginterface-class) &rest args)
91 (declare (ignore class args))
92 (to-alien-function 'gobject))
93
c5d37f4a 94(defmethod reader-function ((class ginterface-class) &rest args)
95 (declare (ignore class args))
96 (reader-function 'gobject))
97
98(defmethod writer-function ((class ginterface-class) &rest args)
99 (declare (ignore class args))
100 (writer-function 'gobject))
101
102(defmethod destroy-function ((class ginterface-class) &rest args)
103 (declare (ignore class args))
104 (destroy-function 'gobject))
105
9adccb27 106
573b21cc 107;;;;
108
9c03a07c 109
110(defbinding type-default-interface-ref (type) pointer
111 ((find-type-number type t) type-number))
112
113(defbinding type-default-interface-unref (type) nil
114 ((find-type-number type t) type-number))
115
116(defbinding type-default-interface-peek (type) pointer
117 ((find-type-number type t) type-number))
118
119(defbinding %object-interface-list-properties () pointer
120 (iface pointer)
121 (n-properties unsigned-int :out))
122
123(defun query-object-interface-properties (type &optional inherited-p)
124 (let* ((type-number (find-type-number type))
125 (iface (type-default-interface-ref type-number)))
126 (unwind-protect
127 (multiple-value-bind (array length)
128 (%object-interface-list-properties iface)
21299acf 129 (unless (null-pointer-p array)
130 (unwind-protect
131 (%map-params array length type-number inherited-p)
132 (deallocate-memory array))))
9c03a07c 133; (type-default-interface-unref type-number)
134 )))
135
136
62f12808 137(defun expand-ginterface-type (type forward-p options &rest args)
573b21cc 138 (declare (ignore args))
9c03a07c 139 (let ((class (type-from-number type))
62f12808 140 (slots (getf options :slots)))
9c03a07c 141 `(defclass ,class (,(supertype type))
62f12808 142 ,(unless forward-p
143 (slot-definitions class (query-object-interface-properties type) slots))
9c03a07c 144 (:metaclass ginterface-class)
dfa4f314 145 (:gtype ,(find-type-init-function type)))))
573b21cc 146
62f12808 147(defun ginterface-dependencies (type)
21299acf 148 (delete-duplicates
149 (cons
150 (supertype type)
151 (mapcar #'param-value-type (query-object-interface-properties type)))))
573b21cc 152
62f12808 153(register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)