1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
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.
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.
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
18 ;; $Id: gobject.lisp,v 1.15 2004/10/31 00:56:29 espen Exp $
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (defclass gobject (ginstance)
26 (:metaclass ginstance-class)
27 (:alien-name "GObject")
29 (:free %object-unref)))
32 (defmethod initialize-instance ((object gobject) &rest initargs)
33 (let ((slotds (class-slots (class-of object)))
34 (names (make-array 0 :adjustable t :fill-pointer t))
35 (values (make-array 0 :adjustable t :fill-pointer t)))
38 as tmp = initargs then (cddr tmp) while tmp
40 as value = (second tmp)
43 (member key (slot-definition-initargs slotd)))
45 when (and (typep slotd 'effective-property-slot-definition)
46 (slot-value slotd 'construct))
47 do (let ((type (find-type-number (slot-definition-type slotd))))
48 (vector-push-extend (slot-definition-pname slotd) names)
49 (vector-push-extend (gvalue-new type value) values)
53 (slot-value object 'location)
54 (if (zerop (length names))
55 (%gobject-new (type-number-of object))
56 (%gobject-newvv (type-number-of object) (length names) names values)))
58 ; (map 'nil #'gvalue-free values)
61 (apply #'call-next-method object initargs))
65 (defbinding (%gobject-new "g_object_new") () pointer
69 (defbinding (%gobject-newvv "g_object_newvv") () pointer
71 (n-parameters unsigned-int)
72 (names (vector string))
73 (values (vector gvalue)))
76 (defbinding %object-ref (type location) pointer
79 (defbinding %object-unref (type location) nil
82 (defun object-ref (object)
83 (%object-ref nil (proxy-location object)))
85 (defun object-unref (object)
86 (%object-unref nil (proxy-location object)))
92 (defbinding %object-set-property () nil
97 (defbinding %object-get-property () nil
102 (defbinding %object-notify () nil
106 (defbinding object-freeze-notify () nil
109 (defbinding object-thaw-notify () nil
112 (defbinding %object-set-qdata-full () nil
116 (destroy-marshal pointer))
121 (defun (setf object-data) (data object key &key (test #'eq))
122 (%object-set-qdata-full
123 object (quark-from-object key :test test)
124 (register-user-data data) *destroy-notify*)
127 (defbinding %object-get-qdata () unsigned-long
131 (defun object-data (object key &key (test #'eq))
133 (%object-get-qdata object (quark-from-object key :test test))))
137 ;;;; Metaclass used for subclasses of gobject
139 (eval-when (:compile-toplevel :load-toplevel :execute)
140 (defclass gobject-class (ginstance-class)
143 (defclass direct-property-slot-definition (direct-virtual-slot-definition)
144 ((pname :reader slot-definition-pname :initarg :pname)
145 (readable :initform t :reader slot-readable-p :initarg :readable)
146 (writable :initform t :reader slot-writable-p :initarg :writable)
147 (construct :initform nil :initarg :construct)))
149 (defclass effective-property-slot-definition (effective-virtual-slot-definition)
150 ((pname :reader slot-definition-pname :initarg :pname)
151 (readable :reader slot-readable-p :initarg :readable)
152 (writable :reader slot-writable-p :initarg :writable)
153 (construct :initarg :construct))))
157 ; (defbinding object-class-install-param () nil
160 ; (parameter parameter))
162 ; (defbinding object-class-find-param-spec () parameter
166 (defun signal-name-to-string (name)
167 (substitute #\_ #\- (string-downcase (string name))))
170 (defmethod direct-slot-definition-class ((class gobject-class) &rest initargs)
171 (case (getf initargs :allocation)
172 (:property (find-class 'direct-property-slot-definition))
173 (t (call-next-method))))
175 (defmethod effective-slot-definition-class ((class gobject-class) &rest initargs)
176 (case (getf initargs :allocation)
177 (:property (find-class 'effective-property-slot-definition))
178 (t (call-next-method))))
180 (defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds)
181 (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
183 (list :pname (signal-name-to-string
184 (most-specific-slot-value direct-slotds 'pname))
185 :readable (most-specific-slot-value direct-slotds 'readable)
186 :writable (most-specific-slot-value direct-slotds 'writable)
187 :construct (most-specific-slot-value direct-slotds 'construct))
192 (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition))
193 (let* ((type (slot-definition-type slotd))
194 (pname (slot-definition-pname slotd))
195 (type-number (find-type-number type)))
196 (unless (slot-boundp slotd 'reader-function)
198 (slot-value slotd 'reader-function)
199 (if (slot-readable-p slotd)
202 (let ((gvalue (gvalue-new type-number)))
203 (%object-get-property object pname gvalue)
206 (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types
207 (gvalue-free gvalue t)))))
208 #'(lambda (value object)
209 (error "Slot is not readable: ~A" (slot-definition-name slotd))))))
211 (unless (slot-boundp slotd 'writer-function)
213 (slot-value slotd 'writer-function)
214 (if (slot-writable-p slotd)
215 #'(lambda (value object)
217 (let ((gvalue (gvalue-new type-number)))
219 (intern-writer-function (type-from-number type-number)) ; temporary
220 value gvalue +gvalue-value-offset+)
221 (%object-set-property object pname gvalue)
223 (intern-destroy-function (type-from-number type-number)) ; temporary
224 gvalue +gvalue-value-offset+)
225 (gvalue-free gvalue nil)
227 #'(lambda (value object)
228 (error "Slot is not writable: ~A" (slot-definition-name slotd))))))
230 (unless (slot-boundp slotd 'boundp-function)
232 (slot-value slotd 'boundp-function)
234 (declare (ignore object))
239 (defmethod validate-superclass ((class gobject-class)
240 (super pcl::standard-class))
241 ; (subtypep (class-name super) 'gobject)
248 (defbinding %object-class-list-properties () pointer
250 (n-properties unsigned-int :out))
253 (defun %map-params (params length type inherited-p)
255 (map-c-array 'list #'identity params 'param length)
256 (let ((properties ()))
259 (when (eql (param-owner-type param) type)
260 (push param properties)))
261 params 'param length)
262 (nreverse properties))))
264 (defun query-object-class-properties (type &optional inherited-p)
265 (let* ((type-number (find-type-number type))
266 (class (type-class-ref type-number)))
268 (multiple-value-bind (array length)
269 (%object-class-list-properties class)
271 (%map-params array length type-number inherited-p)
272 (deallocate-memory array)))
273 ; (type-class-unref type-number)
277 (defun default-slot-name (name)
278 (intern (substitute #\- #\_ (string-upcase (string-upcase name)))))
280 (defun default-slot-accessor (class-name slot-name type)
283 nil "~A-~A~A" class-name slot-name
284 (if (eq type 'boolean) "-P" ""))))
287 (defun slot-definition-from-property (class property)
288 (with-slots (name flags value-type documentation) property
289 (let* ((slot-name (default-slot-name name))
290 (slot-type (or (type-from-number value-type) value-type))
291 (accessor (default-slot-accessor class slot-name slot-type)))
294 :allocation :property :pname ,name
299 (member :writable flags) (member :readable flags)
300 (not (member :construct-only flags)))
301 (list :accessor accessor))
302 ((and (member :writable flags) (not (member :construct-only flags)))
303 (list :writer `(setf ,accessor)))
304 ((member :readable flags)
305 (list :reader accessor)))
307 ;; readable/writable/construct
308 ,@(when (or (not (member :writable flags))
309 (member :construct-only flags))
311 ,@(when (not (member :readable flags))
313 ,@(when (or (member :construct flags)
314 (member :construct-only flags))
318 ,@(when (or (member :construct flags)
319 (member :construct-only flags)
320 (member :writable flags))
321 (list :initarg (intern (string slot-name) "KEYWORD")))
324 :documentation ,documentation))))
327 (defun slot-definitions (class properties slots)
329 with manual-slots = slots
330 for property in properties
333 (destructuring-bind (name &rest args) slot
335 (equal (param-name property) (getf args :pname))
336 (eq (default-slot-name (param-name property)) name))))
338 do (push (slot-definition-from-property class property) slots))
339 (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots))
342 (defun expand-gobject-type (type &optional options (metaclass 'gobject-class))
343 (let ((supers (cons (supertype type) (implements type)))
344 (class (type-from-number type))
345 (slots (getf options :slots)))
346 `(defclass ,class ,supers
347 ,(slot-definitions class (query-object-class-properties type) slots)
348 (:metaclass ,metaclass)
349 (:alien-name ,(find-type-name type)))))
352 (register-derivable-type 'gobject "GObject" 'expand-gobject-type)