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.31 2006-02-15 09:47:42 espen Exp $
31 ; (defun name-to-string (name)
32 ; (substitute #\_ #\- (string-downcase (string name))))
34 ; (defun string-to-name (name &optional (package "KEYWORD"))
35 ; (intern (substitute #\- #\_ (string-upcase name)) package))
39 ;;;; Superclass for the gtk class hierarchy
41 (eval-when (:compile-toplevel :load-toplevel :execute)
42 (init-types-in-library
43 #.(concatenate 'string (pkg-config:pkg-variable "gtk+-2.0" "libdir")
44 "/libgtk-x11-2.0.so"))
46 (defclass %object (gobject)
48 (:metaclass gobject-class)
49 (:gtype |gtk_object_get_type|)))
52 (defmethod initialize-instance ((object %object) &rest initargs &key signal)
53 (declare (ignore signal))
55 (dolist (signal-definition (get-all initargs :signal))
56 (apply #'signal-connect object signal-definition)))
58 (defmethod initialize-instance :around ((object %object) &rest initargs)
59 (declare (ignore initargs))
61 ;; Add a temorary reference which will be removed when the object is
63 (reference-foreign (class-of object) (foreign-location object))
64 (%object-sink object))
66 (defbinding %object-sink () nil
69 ;;;; Main loop and event handling
71 (declaim (inline events-pending-p main-iteration))
73 (defbinding events-pending-p () boolean)
75 (defbinding get-current-event () gdk:event)
77 (defbinding main-do-event () nil
80 (defbinding main () nil)
82 (defbinding main-level () int)
84 (defbinding main-quit () nil)
86 (defbinding main-iteration-do (&optional (blocking t)) boolean
89 (defun main-iterate-all (&rest args)
90 (declare (ignore args))
92 while (events-pending-p)
93 do (main-iteration-do nil)))
96 ;;;; Metaclass for child classes
98 (defvar *container-to-child-class-mappings* (make-hash-table))
100 (eval-when (:compile-toplevel :load-toplevel :execute)
101 (defclass child-class (virtual-slots-class)
104 (defclass direct-child-slot-definition (direct-virtual-slot-definition)
105 ((pname :reader slot-definition-pname :initarg :pname)))
107 (defclass effective-child-slot-definition (effective-virtual-slot-definition)
108 ((pname :reader slot-definition-pname :initarg :pname)))
111 (defmethod shared-initialize ((class child-class) names &key container)
114 (gethash (find-class (first container)) *container-to-child-class-mappings*)
117 (defmethod direct-slot-definition-class ((class child-class) &rest initargs)
118 (case (getf initargs :allocation)
119 (:property (find-class 'direct-child-slot-definition))
120 (t (call-next-method))))
122 (defmethod effective-slot-definition-class ((class child-class) &rest initargs)
123 (case (getf initargs :allocation)
124 (:property (find-class 'effective-child-slot-definition))
125 (t (call-next-method))))
127 (defmethod compute-effective-slot-definition-initargs ((class child-class) direct-slotds)
128 (if (eq (slot-definition-allocation (first direct-slotds)) :property)
130 (list :pname (most-specific-slot-value direct-slotds 'pname))
131 ;; Need this to prevent type expansion in SBCL (>= 0.9.8)
132 (list :type (most-specific-slot-value direct-slotds 'type))
137 #+cmu(declaim (optimize (inhibit-warnings 3)))
138 #+sbcl(declaim (muffle-conditions compiler-note))
139 (defun %container-child-get-property (parent child pname gvalue))
140 (defun %container-child-set-property (parent child pname gvalue)))
143 (defmethod initialize-internal-slot-functions ((slotd effective-child-slot-definition))
144 (let ((type (slot-definition-type slotd))
145 (pname (slot-definition-pname slotd)))
147 (slot-value slotd 'getter)
149 (with-slots (parent child) object
150 (let ((gvalue (gvalue-new type)))
151 (%container-child-get-property parent child pname gvalue)
153 (funcall (reader-function type) gvalue +gvalue-value-offset+)
154 (gvalue-free gvalue t))))))
157 (slot-value slotd 'setter)
158 #'(lambda (value object)
159 (with-slots (parent child) object
160 (let ((gvalue (gvalue-new type)))
161 (funcall (writer-function type) value gvalue +gvalue-value-offset+)
162 (%container-child-set-property parent child pname gvalue)
163 (gvalue-free gvalue t)
169 (defmethod add-reader-method ((class child-class) generic-function slot-name)
172 (make-instance 'standard-method
173 :specializers (list (find-class 'widget))
174 :lambda-list '(widget)
175 :function #'(lambda (args next-methods)
176 (declare (ignore next-methods))
177 (child-property-value (first args) slot-name)))))
179 (defmethod add-writer-method
180 ((class child-class) generic-function slot-name)
183 (make-instance 'standard-method
184 :specializers (list (find-class t) (find-class 'widget))
185 :lambda-list '(value widget)
186 :function #'(lambda (args next-methods)
187 (declare (ignore next-methods))
188 (destructuring-bind (value widget) args
189 (setf (child-property-value widget slot-name) value))))))
192 (defmethod validate-superclass ((class child-class) (super standard-class))
193 ;(subtypep (class-name super) 'container-child)
197 (defclass container-child ()
198 ((parent :initarg :parent :type container)
199 (child :initarg :child :type widget)))
204 (defbinding %container-class-list-child-properties () pointer
206 (n-properties unsigned-int :out))
208 (defun query-container-class-child-properties (type-number)
209 (let ((class (type-class-ref type-number)))
210 (multiple-value-bind (array length)
211 (%container-class-list-child-properties class)
213 (map-c-vector 'list #'identity array 'param length)
214 (deallocate-memory array)))))
216 (defun default-container-child-name (container-class)
217 (intern (format nil "~A-CHILD" container-class)))
219 (defun expand-container-type (type forward-p options)
220 (let* ((class (type-from-number type))
221 (super (supertype type))
222 (child-class (default-container-child-name class)))
224 (expand-gobject-type type t options)
226 ,(expand-gobject-type type nil options)
227 (defclass ,child-class (,(default-container-child-name super))
228 ,(slot-definitions child-class
229 (query-container-class-child-properties type) nil)
230 (:metaclass child-class)
231 (:container ,class))))))
234 (register-derivable-type 'container "GtkContainer" 'expand-container-type 'gobject-dependencies)