1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
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:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
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.
23 ;; $Id: gtkobject.lisp,v 1.49 2008-10-09 18:45:01 espen Exp $
29 ;;;; Superclass for the gtk class hierarchy
31 (eval-when (:compile-toplevel :load-toplevel :execute)
32 (init-types-in-library gtk "libgtk-2.0"))
34 (defclass %object (initially-unowned)
36 (:metaclass gobject-class)
37 (:gtype |gtk_object_get_type|))
40 (defmethod initialize-instance ((object %object) &rest initargs &key signal)
41 (declare (ignore signal))
43 (dolist (signal-definition (get-all initargs :signal))
44 (apply #'signal-connect object signal-definition)))
46 #?-(pkg-exists-p "glib-2.0" :atleast-version "2.10.0")
48 (defmethod initialize-instance :around ((object %object) &rest initargs)
49 (declare (ignore initargs))
51 ;; Add a temorary reference which will be removed when the object is
53 (funcall (reference-function '%object) (foreign-location object))
54 (%object-sink object))
56 (defbinding %object-sink () nil
59 ;;;; Main loop and event handling
61 (defparameter *reentrant-main-iteration* t)
62 (defvar *running-main-iteration* nil)
64 (defbinding events-pending-p () boolean)
66 (defbinding get-current-event () gdk:event)
68 (defbinding main-do-event () nil
71 (defbinding main () nil)
73 (defbinding main-level () int)
75 (defbinding main-quit () nil)
77 (defbinding main-iteration-do (&optional (blocking t)) boolean
80 (defun main-iterate-all (&rest args)
81 (declare (ignore args))
82 (unless (and (not *reentrant-main-iteration*) *running-main-iteration*)
83 (let ((*running-main-iteration* t))
85 while (events-pending-p)
86 do (main-iteration-do nil))))
90 (define-callback fd-source-callback-marshal nil
91 ((callback-id unsigned-int) (fd unsigned-int))
92 (glib::invoke-source-callback callback-id fd))
94 (defbinding (input-add "gtk_input_add_full") (fd condition function) unsigned-int
96 (condition gdk:input-condition)
97 (fd-source-callback-marshal callback)
99 ((register-callback-function function) unsigned-long)
100 (user-data-destroy-callback callback))
103 ;;;; Metaclass for child classes
105 (defvar *container-to-child-class-mappings* (make-hash-table))
107 (eval-when (:compile-toplevel :load-toplevel :execute)
108 (defclass container-child-class (virtual-slots-class)
111 (defclass direct-child-slot-definition (direct-virtual-slot-definition)
112 ((pname :reader slot-definition-pname :initarg :pname)))
114 (defclass effective-child-slot-definition (effective-virtual-slot-definition)
115 ((pname :reader slot-definition-pname :initarg :pname))))
118 (defmethod shared-initialize ((class container-child-class) names &key container)
119 (declare (ignore names))
122 (gethash (find-class (first container)) *container-to-child-class-mappings*)
126 for slotd in (class-direct-slots class)
127 when (typep slotd 'direct-child-slot-definition)
129 for reader in (slot-definition-readers slotd)
130 do (add-reader-method class
131 (ensure-generic-function reader :lambda-list '(object))
132 (slot-definition-name slotd)))
134 for writer in (slot-definition-writers slotd)
135 do (add-writer-method class
136 (ensure-generic-function writer :lambda-list '(value object))
137 (slot-definition-name slotd)))))
139 (defmethod direct-slot-definition-class ((class container-child-class) &rest initargs)
140 (case (getf initargs :allocation)
141 (:property (find-class 'direct-child-slot-definition))
142 (t (call-next-method))))
144 (defmethod effective-slot-definition-class ((class container-child-class) &rest initargs)
145 (case (getf initargs :allocation)
146 (:property (find-class 'effective-child-slot-definition))
147 (t (call-next-method))))
149 (defmethod compute-effective-slot-definition-initargs ((class container-child-class) direct-slotds)
150 (if (eq (slot-definition-allocation (first direct-slotds)) :property)
152 (list :pname (most-specific-slot-value direct-slotds 'pname))
156 (defmethod slot-readable-p ((slotd effective-child-slot-definition))
157 (declare (ignore slotd))
160 (defmethod compute-slot-reader-function ((slotd effective-child-slot-definition) &optional signal-unbound-p)
161 (declare (ignore signal-unbound-p))
162 (let* ((type (slot-definition-type slotd))
163 (pname (slot-definition-pname slotd))
164 (reader (reader-function type :ref :get)))
166 (with-slots (parent child) object
167 (with-memory (gvalue +gvalue-size+)
168 (glib::%gvalue-init gvalue (find-type-number type))
169 (%container-child-get-property parent child pname gvalue)
170 (funcall reader gvalue +gvalue-value-offset+))))))
172 (defmethod slot-writable-p ((slotd effective-child-slot-definition))
173 (declare (ignore slotd))
176 (defmethod compute-slot-writer-function ((slotd effective-child-slot-definition))
177 (let* ((type (slot-definition-type slotd))
178 (pname (slot-definition-pname slotd))
179 (writer (writer-function type :temp t))
180 (destroy (destroy-function type :temp t)))
181 #'(lambda (value object)
182 (with-slots (parent child) object
183 (with-memory (gvalue +gvalue-size+)
184 (glib::%gvalue-init gvalue (find-type-number type))
185 (funcall writer value gvalue +gvalue-value-offset+)
186 (%container-child-set-property parent child pname gvalue)
187 (funcall destroy gvalue +gvalue-value-offset+))
191 (defmethod add-reader-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation #?(sbcl>= 1 0 14)source-location)
194 (make-instance 'standard-method
195 :specializers (list (find-class 'widget))
196 :lambda-list '(widget)
197 :documentation (or #?(sbcl>= 1 0 2)slot-documentation "automatically generated reader method")
198 :function #'(lambda (args next-methods)
199 (declare (ignore next-methods))
200 (child-property-value (first args) slot-name)))))
202 (defmethod add-writer-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation #?(sbcl>= 1 0 14)source-location)
205 (make-instance 'standard-method
206 :specializers (list (find-class t) (find-class 'widget))
207 :lambda-list '(value widget)
208 :documentation (or #?(sbcl>= 1 0 2)slot-documentation "automatically generated reader method")
209 :function #'(lambda (args next-methods)
210 (declare (ignore next-methods))
211 (destructuring-bind (value widget) args
212 (setf (child-property-value widget slot-name) value))))))
215 (defmethod validate-superclass ((class container-child-class) (super standard-class))
216 ;(subtypep (class-name super) 'container-child)
220 (defclass container-child (virtual-slots-object)
221 ((parent :initarg :parent :type container)
222 (child :initarg :child :type widget)))
227 (defbinding %container-class-list-child-properties () pointer
229 (n-properties unsigned-int :out))
231 (defun query-container-class-child-properties (type-number &optional owner-only-p)
232 (let ((class (type-class-ref type-number)))
233 (multiple-value-bind (array length)
234 (%container-class-list-child-properties class)
236 (let ((properties (map-c-vector 'list #'identity array 'param length)))
240 (not (eql (slot-value property 'glib::owner-type) type-number)))
243 (deallocate-memory array)))))
245 (defun default-container-child-name (container-class)
246 (intern (format nil "~A-CHILD" container-class)))
248 (defun expand-container-type (type forward-p options)
249 (let* ((class (type-from-number type))
250 (super (supertype type))
251 (child-class (default-container-child-name class)))
253 (expand-gobject-type type t options)
255 ,(expand-gobject-type type nil options)
256 ,(let ((child-properties (query-container-class-child-properties type t)))
257 (when child-properties
258 `(defclass ,child-class (,(default-container-child-name super))
259 ,(slot-definitions child-class child-properties nil)
260 (:metaclass container-child-class)
261 (:container ,class))))))))
263 (defun container-dependencies (type options)
266 (gobject-dependencies type options)
267 (mapcar #'param-value-type (query-container-class-child-properties type)))))
269 (register-derivable-type 'container "GtkContainer" 'expand-container-type 'container-dependencies)
272 (defmacro define-callback-setter (name arg return-type &rest rest-args)
273 (let ((callback (gensym)))
276 (define-callback-marshal ,callback ,return-type
277 ,(cons arg rest-args))
278 (defbinding ,name () nil
281 (function user-callback)
282 (user-data-destroy-callback callback)))
284 (define-callback-marshal ,callback ,return-type ,rest-args)
285 (defbinding ,name () nil
287 (function user-callback)
288 (user-data-destroy-callback callback))))))