1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000-2001 Espen S. Johnsen <espen@users.sourceforge.net>
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: gtkwidget.lisp,v 1.6 2001-11-20 18:25:53 espen Exp $
23 (defmethod shared-initialize ((widget widget) names &rest initargs &key parent)
24 (declare (ignore initargs names))
27 (let ((old-parent (widget-parent widget))
28 (parent-widget (first (mklist parent)))
29 (args (rest (mklist parent))))
31 (container-remove old-parent widget))
32 (apply #'container-add parent-widget widget args))))
34 (defmethod shared-initialize :after ((widget widget) names &rest initargs
36 (declare (ignore initargs names))
38 (widget-show-all widget)))
41 (defmethod slot-unbound ((class gobject-class) (object widget) slot)
43 ((and (eq slot 'child-slots) (slot-value object 'parent))
44 (with-slots (parent child-slots) object
48 (gethash (class-of parent) *container-to-child-class-mappings*)
49 :parent parent :child object))))
50 (t (call-next-method))))
53 (defun child-slot-value (widget slot)
54 (slot-value (widget-child-slots widget) slot))
56 (defun (setf child-slot-value) (value widget slot)
57 (setf (slot-value (widget-child-slots widget) slot) value))
59 (defmacro with-child-slots (slots widget &body body)
60 `(with-slots ,slots (widget-child-slots ,widget)
63 (defmacro widget-destroyed (place)
66 (defbinding widget-destroy () nil
69 (defbinding widget-unparent () nil
72 (defbinding widget-show () nil
75 (defbinding widget-show-now () nil
78 (defbinding widget-hide () nil
81 (defbinding widget-show-all () nil
84 (defbinding widget-hide-all () nil
87 (defbinding widget-map () nil
90 (defbinding widget-unmap () nil
93 (defbinding widget-realize () nil
96 (defbinding widget-unrealize () nil
99 (defbinding widget-add-accelerator
100 (widget signal accel-group key modifiers flags) nil
102 ((name-to-string signal) string)
103 (accel-group accel-group)
104 ((gdk:keyval-from-name key) unsigned-int)
105 (modifiers gdk:modifier-type)
108 (defbinding widget-remove-accelerator
109 (widget accel-group key modifiers) nil
111 (accel-group accel-group)
112 ((gdk:keyval-from-name key) unsigned-int)
113 (modifiers gdk:modifier-type))
115 (defbinding widget-accelerator-signal
116 (widget accel-group key modifiers) unsigned-int
118 (accel-group accel-group)
119 ((gdk:keyval-from-name key) unsigned-int)
120 (modifiers gdk:modifier-type))
122 (defbinding widget-lock-accelerators () nil
125 (defbinding widget-unlock-accelerators () nil
128 (defbinding (widget-accelerators-locked-p "gtk_widget_accelerators_locked")
132 (defbinding widget-event () int
136 (defbinding get-event-widget () widget
139 (defbinding widget-activate () boolean
142 (defbinding widget-set-scroll-adjustments () boolean
144 (hadjustment adjustment)
145 (vadjustment adjustment))
147 (defbinding widget-reparent () nil
151 ; (defbinding widget-popup () nil
156 (defbinding widget-grab-focus () nil
159 (defbinding widget-grab-default () nil
162 (defbinding grab-add () nil
165 (defbinding grab-get-current () widget)
167 (defbinding grab-remove () nil
170 (defbinding widget-allocation () nil
175 (defbinding widget-add-events () nil
177 (events gdk:event-mask))
179 (defbinding (widget-toplevel "gtk_widget_get_toplevel") () widget
182 (defbinding (widget-ancestor "gtk_widget_get_ancestor") (widget type) widget
184 ((find-type-number type) type-number))
186 (defbinding (widget-pointer "gtk_widget_get_pointer") () nil
191 (defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
195 (defbinding widget-ensure-style () nil
198 (defbinding widget-reset-rc-styles () nil
201 (defun (setf widget-cursor) (cursor-type widget)
202 (let ((cursor (gdk:cursor-new cursor-type))
203 (window (widget-window widget)))
204 (gdk:window-set-cursor window cursor)
205 ;(gdk:cursor-destroy cursor)
208 ;; Push/pop pairs, to change default values upon a widget's creation.
209 ;; This will override the values that got set by the
210 ;; widget-set-default-* functions.
212 (defbinding widget-push-colormap () nil
213 (colormap gdk:colormap))
215 (defbinding widget-push-composite-child () nil)
217 (defbinding widget-pop-colormap () nil)
219 (defbinding widget-pop-composite-child () nil)
222 ;; Set certain default values to be used at widget creation time.
224 (defbinding widget-set-default-colormap () nil
225 (colormap gdk:colormap))
227 (defbinding widget-get-default-style () style)
229 (defbinding widget-get-default-colormap () gdk:colormap)
231 (defbinding widget-shape-combine-mask () nil
233 (shape-mask gdk:bitmap)
237 ;; defined in gtkglue.c
238 (defbinding widget-mapped-p () boolean