1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.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: gtkwidget.lisp,v 1.3 2000-10-05 17:34:53 espen Exp $
23 (defmethod initialize-instance ((widget widget) &rest initargs &key parent)
24 (declare (ignore initargs))
27 (with-slots ((container parent) child-slots) widget
29 container (car parent)
33 (slot-value (class-of container) 'child-class)
34 :parent container :child widget (cdr parent)))))
36 (setf (slot-value widget 'parent) parent)))
40 (defmethod slot-unbound ((class object-class) (object widget) slot)
42 ((and (eq slot 'child-slots) (slot-value object 'parent))
43 (with-slots (parent child-slots) object
47 (slot-value (class-of parent) 'child-class)
48 :parent parent :child object))))
49 (t (call-next-method))))
52 (defun child-slot-value (widget slot)
53 (slot-value (widget-child-slots widget) slot))
55 (defun (setf child-slot-value) (value widget slot)
56 (setf (slot-value (widget-child-slots widget) slot) value))
58 (defmacro with-child-slots (slots widget &body body)
59 `(with-slots ,slots (widget-child-slots ,widget)
62 (defmacro widget-destroyed (place)
65 (define-foreign widget-destroy () nil
68 (define-foreign widget-unparent () nil
71 (define-foreign widget-show () nil
74 (define-foreign widget-show-now () nil
77 (define-foreign widget-hide () nil
80 (define-foreign widget-show-all () nil
83 (define-foreign widget-hide-all () nil
86 (define-foreign widget-map () nil
89 (define-foreign widget-unmap () nil
92 (define-foreign widget-realize () nil
95 (define-foreign widget-unrealize () nil
98 (define-foreign widget-add-accelerator
99 (widget signal accel-group key modifiers flags) nil
101 ((name-to-string signal) string)
102 (accel-group accel-group)
103 ((gdk:keyval-from-name key) unsigned-int)
104 (modifiers gdk:modifier-type)
107 (define-foreign widget-remove-accelerator
108 (widget accel-group key modifiers) nil
110 (accel-group accel-group)
111 ((gdk:keyval-from-name key) unsigned-int)
112 (modifiers gdk:modifier-type))
114 (define-foreign widget-accelerator-signal
115 (widget accel-group key modifiers) unsigned-int
117 (accel-group accel-group)
118 ((gdk:keyval-from-name key) unsigned-int)
119 (modifiers gdk:modifier-type))
121 (define-foreign widget-lock-accelerators () nil
124 (define-foreign widget-unlock-accelerators () nil
128 ("gtk_widget_accelerators_locked" widget-accelerators-locked-p) () boolean
131 (define-foreign widget-event () int
135 (define-foreign get-event-widget () widget
138 (define-foreign widget-activate () boolean
141 (define-foreign widget-set-scroll-adjustments () boolean
143 (hadjustment adjustment)
144 (vadjustment adjustment))
146 (define-foreign widget-reparent () nil
150 (define-foreign widget-popup () nil
155 (define-foreign widget-grab-focus () nil
158 (define-foreign widget-grab-default () nil
161 (define-foreign grab-add () nil
164 (define-foreign grab-get-current () widget)
166 (define-foreign grab-remove () nil
169 (define-foreign widget-allocation () nil
175 (define-foreign widget-set-uposition (widget &key (x t) (y t)) nil
186 (define-foreign widget-add-events () nil
188 (events gdk:event-mask))
190 (define-foreign ("gtk_widget_get_toplevel" widget-toplevel) () widget
193 (define-foreign ("gtk_widget_get_ancestor"
194 widget-ancestor) (widget type) widget
196 ((find-type-number type) type-number))
198 ; (define-foreign ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap
201 ; (define-foreign ("gtk_widget_get_visual" widget-visual) () gdk:visual
204 (define-foreign ("gtk_widget_get_pointer" widget-pointer) () nil
209 (define-foreign ("gtk_widget_is_ancestor" widget-is-ancestor-p) () boolean
213 (define-foreign widget-set-rc-style () nil
216 (define-foreign widget-ensure-style () nil
219 (define-foreign widget-restore-default-style () nil
222 (define-foreign widget-reset-rc-styles () nil
225 (defun (setf widget-cursor) (cursor-type widget)
226 (let ((cursor (gdk:cursor-new cursor-type))
227 (window (widget-window widget)))
228 (gdk:window-set-cursor window cursor)
229 ;(gdk:cursor-destroy cursor)
232 ;; Push/pop pairs, to change default values upon a widget's creation.
233 ;; This will override the values that got set by the
234 ;; widget-set-default-* functions.
236 (define-foreign widget-push-style () nil
239 (define-foreign widget-push-colormap () nil
240 (colormap gdk:colormap))
242 ; (define-foreign widget-push-visual () nil
243 ; (visual gdk:visual))
245 (define-foreign widget-push-composite-child () nil)
247 (define-foreign widget-pop-style () nil)
249 (define-foreign widget-pop-colormap () nil)
251 ;(define-foreign widget-pop-visual () nil)
253 (define-foreign widget-pop-composite-child () nil)
256 ;; Set certain default values to be used at widget creation time.
258 (define-foreign widget-set-default-style () nil
261 (define-foreign widget-set-default-colormap () nil
262 (colormap gdk:colormap))
264 ; (define-foreign widget-set-default-visual () nil
265 ; (visual gdk:visual))
267 (define-foreign widget-get-default-style () style)
269 (define-foreign widget-get-default-colormap () gdk:colormap)
271 (define-foreign widget-get-default-visual () gdk:visual)
273 (define-foreign widget-shape-combine-mask () nil
275 (shape-mask gdk:bitmap)
279 ;; defined in gtkglue.c
280 (define-foreign widget-mapped-p () boolean