X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/aace61f56d713c69ac6b0f2930c415438e8d4424..d67f8348100c77f08d37961cf8e21c1df2a3745b:/gtk/gtkwidget.lisp diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp index 6097a2f..d9bdc1a 100644 --- a/gtk/gtkwidget.lisp +++ b/gtk/gtkwidget.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000 Espen S. Johnsen +;; Copyright (C) 2000-2001 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -15,157 +15,34 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gtkwidget.lisp,v 1.2 2000-08-16 22:16:44 espen Exp $ +;; $Id: gtkwidget.lisp,v 1.5 2001-10-21 23:22:04 espen Exp $ (in-package "GTK") -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass widget (object) - ((child-slots - :allocation :instance - :accessor widget-child-slots - :type container-child) - (name - :allocation :arg - :accessor widget-name - :initarg :name - :type string) - (parent - :allocation :arg - :accessor widget-parent -; :initarg :parent - :type container) - (x - :allocation :arg - :accessor widget-x-position - :initarg :x - :type int) - (y - :allocation :arg - :accessor widget-y-position - :initarg :y - :type int) - (width - :allocation :arg - :accessor widget-width - :initarg :width - :type int) - (height - :allocation :arg - :accessor widget-height - :initarg :height - :type int) - (visible - :allocation :arg - :accessor widget-visible-p - :initarg :visible - :type boolean) - (sensitive - :allocation :arg - :accessor widget-sensitive-p - :initarg :sensitive - :type boolean) - (app-paintable - :allocation :arg - :reader widget-app-paintable-p -; :access :read-only - :type boolean) - (can-focus - :allocation :arg - :accessor widget-can-focus-p - :initarg :can-focus - :type boolean) - (has-focus - :allocation :arg - :accessor widget-has-focus-p - :initarg :has-focus - :type boolean) - (can-default - :allocation :arg - :accessor widget-can-default-p - :initarg :can-default - :type boolean) - (has-default - :allocation :arg - :accessor widget-has-default-p - :initarg :has-default - :type boolean) - (receives-default - :allocation :arg - :accessor widget-receives-default-p - :initarg :receives-default - :type boolean) - (composite-child - :allocation :arg - :accessor widget-composite-child-p - :initarg :composite-child - :type boolean) -; (style -; :allocation :arg -; :accessor widget-style -; :initarg :style -; :type style) - (events - :allocation :arg - :accessor widget-events - :initarg :events - :type gdk:event-mask) - (extension-events - :allocation :arg - :accessor widget-extension-events - :initarg :extpension-events - :type gdk:event-mask) - (state - :allocation :virtual - :location ("gtk_widget_get_state" "gtk_widget_set_state") - :accessor widget-state - :initarg :state - :type state-type) - (window - :allocation :virtual - :location "gtk_widget_get_window" - :reader widget-window - :type gdk:window) - (colormap - :allocation :virtual - :location "gtk_widget_get_colormap" - :reader widget-colormap - :type gdk:colormap) - (visual - :allocation :virtual - :location "gtk_widget_get_visual" - :reader widget-visual - :type gdk:visual)) - (:metaclass object-class) - (:alien-name "GtkWidget"))) - - (defmethod initialize-instance ((widget widget) &rest initargs &key parent) (declare (ignore initargs)) - (cond - ((consp parent) - (with-slots ((container parent) child-slots) widget - (setf - container (car parent) - child-slots - (apply - #'make-instance - (slot-value (class-of container) 'child-class) - :parent container :child widget (cdr parent))))) - (parent - (setf (slot-value widget 'parent) parent))) - (call-next-method)) + (call-next-method) + (when parent + (let ((parent-widget (first (mklist parent))) + (args (rest (mklist parent)))) + (apply #'container-add parent-widget widget args)))) + +(defmethod initialize-instance :after ((widget widget) &rest initargs + &key show-all) + (declare (ignore initargs)) + (when show-all + (widget-show-all widget))) -(defmethod slot-unbound ((class object-class) (object widget) slot) +(defmethod slot-unbound ((class gobject-class) (object widget) slot) (cond ((and (eq slot 'child-slots) (slot-value object 'parent)) (with-slots (parent child-slots) object (setf child-slots (make-instance - (slot-value (class-of parent) 'child-class) + (gethash (class-of parent) *container-to-child-class-mappings*) :parent parent :child object)))) (t (call-next-method)))) @@ -183,40 +60,40 @@ (defmacro with-child-slots (slots widget &body body) (defmacro widget-destroyed (place) `(setf ,place nil)) -(define-foreign widget-destroy () nil +(defbinding widget-destroy () nil (widget widget)) -(define-foreign widget-unparent () nil +(defbinding widget-unparent () nil (widget widget)) -(define-foreign widget-show () nil +(defbinding widget-show () nil (widget widget)) -(define-foreign widget-show-now () nil +(defbinding widget-show-now () nil (widget widget)) -(define-foreign widget-hide () nil +(defbinding widget-hide () nil (widget widget)) -(define-foreign widget-show-all () nil +(defbinding widget-show-all () nil (widget widget)) -(define-foreign widget-hide-all () nil +(defbinding widget-hide-all () nil (widget widget)) -(define-foreign widget-map () nil +(defbinding widget-map () nil (widget widget)) -(define-foreign widget-unmap () nil +(defbinding widget-unmap () nil (widget widget)) -(define-foreign widget-realize () nil +(defbinding widget-realize () nil (widget widget)) -(define-foreign widget-unrealize () nil +(defbinding widget-unrealize () nil (widget widget)) -(define-foreign widget-add-accelerator +(defbinding widget-add-accelerator (widget signal accel-group key modifiers flags) nil (widget widget) ((name-to-string signal) string) @@ -225,122 +102,97 @@ (define-foreign widget-add-accelerator (modifiers gdk:modifier-type) (flags accel-flags)) -(define-foreign widget-remove-accelerator +(defbinding widget-remove-accelerator (widget accel-group key modifiers) nil (widget widget) (accel-group accel-group) ((gdk:keyval-from-name key) unsigned-int) (modifiers gdk:modifier-type)) -(define-foreign widget-accelerator-signal +(defbinding widget-accelerator-signal (widget accel-group key modifiers) unsigned-int (widget widget) (accel-group accel-group) ((gdk:keyval-from-name key) unsigned-int) (modifiers gdk:modifier-type)) -(define-foreign widget-lock-accelerators () nil +(defbinding widget-lock-accelerators () nil (widget widget)) -(define-foreign widget-unlock-accelerators () nil +(defbinding widget-unlock-accelerators () nil (widget widget)) -(define-foreign - ("gtk_widget_accelerators_locked" widget-accelerators-locked-p) () boolean +(defbinding (widget-accelerators-locked-p "gtk_widget_accelerators_locked") + () boolean (widget widget)) -(define-foreign widget-event () int +(defbinding widget-event () int (widget widget) (event gdk:event)) -(define-foreign get-event-widget () widget +(defbinding get-event-widget () widget (event gdk:event)) -(define-foreign widget-activate () boolean +(defbinding widget-activate () boolean (widget widget)) -(define-foreign widget-set-scroll-adjustments () boolean +(defbinding widget-set-scroll-adjustments () boolean (widget widget) (hadjustment adjustment) (vadjustment adjustment)) -(define-foreign widget-reparent () nil +(defbinding widget-reparent () nil (widget widget) (new-parent widget)) -(define-foreign widget-popup () nil - (widget widget) - (x int) - (y int)) +; (defbinding widget-popup () nil +; (widget widget) +; (x int) +; (y int)) -(define-foreign widget-grab-focus () nil +(defbinding widget-grab-focus () nil (widget widget)) -(define-foreign widget-grab-default () nil +(defbinding widget-grab-default () nil (widget widget)) -(define-foreign grab-add () nil +(defbinding grab-add () nil (widget widget)) -(define-foreign grab-get-current () widget) +(defbinding grab-get-current () widget) -(define-foreign grab-remove () nil +(defbinding grab-remove () nil (widget widget)) -(define-foreign widget-allocation () nil +(defbinding widget-allocation () nil (widget widget) (width int :out) (height int :out)) - -(define-foreign widget-set-uposition (widget &key (x t) (y t)) nil - (widget widget) - ((case x - ((t) -2) - ((nil) -1) - (otherwise x)) int) - ((case y - ((t) -2) - ((nil) -1) - (otherwise y)) int)) - -(define-foreign widget-add-events () nil +(defbinding widget-add-events () nil (widget widget) (events gdk:event-mask)) -(define-foreign ("gtk_widget_get_toplevel" widget-toplevel) () widget +(defbinding (widget-toplevel "gtk_widget_get_toplevel") () widget (widget widget)) -(define-foreign ("gtk_widget_get_ancestor" - widget-ancestor) (widget type) widget +(defbinding (widget-ancestor "gtk_widget_get_ancestor") (widget type) widget (widget widget) ((find-type-number type) type-number)) -; (define-foreign ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap -; (widget widget)) - -; (define-foreign ("gtk_widget_get_visual" widget-visual) () gdk:visual -; (widget widget)) - -(define-foreign ("gtk_widget_get_pointer" widget-pointer) () nil +(defbinding (widget-pointer "gtk_widget_get_pointer") () nil (widget widget) (x int :out) (y int :out)) -(define-foreign ("gtk_widget_is_ancestor" widget-is-ancestor-p) () boolean +(defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean (widget widget) (ancestor widget)) -(define-foreign widget-set-rc-style () nil +(defbinding widget-ensure-style () nil (widget widget)) -(define-foreign widget-ensure-style () nil - (widget widget)) - -(define-foreign widget-restore-default-style () nil - (widget widget)) - -(define-foreign widget-reset-rc-styles () nil +(defbinding widget-reset-rc-styles () nil (widget widget)) (defun (setf widget-cursor) (cursor-type widget) @@ -354,50 +206,32 @@ (defun (setf widget-cursor) (cursor-type widget) ;; This will override the values that got set by the ;; widget-set-default-* functions. -(define-foreign widget-push-style () nil - (style style)) - -(define-foreign widget-push-colormap () nil +(defbinding widget-push-colormap () nil (colormap gdk:colormap)) -; (define-foreign widget-push-visual () nil -; (visual gdk:visual)) - -(define-foreign widget-push-composite-child () nil) +(defbinding widget-push-composite-child () nil) -(define-foreign widget-pop-style () nil) +(defbinding widget-pop-colormap () nil) -(define-foreign widget-pop-colormap () nil) - -;(define-foreign widget-pop-visual () nil) - -(define-foreign widget-pop-composite-child () nil) +(defbinding widget-pop-composite-child () nil) ;; Set certain default values to be used at widget creation time. -(define-foreign widget-set-default-style () nil - (style style)) - -(define-foreign widget-set-default-colormap () nil +(defbinding widget-set-default-colormap () nil (colormap gdk:colormap)) -; (define-foreign widget-set-default-visual () nil -; (visual gdk:visual)) - -(define-foreign widget-get-default-style () style) - -(define-foreign widget-get-default-colormap () gdk:colormap) +(defbinding widget-get-default-style () style) -(define-foreign widget-get-default-visual () gdk:visual) +(defbinding widget-get-default-colormap () gdk:colormap) -(define-foreign widget-shape-combine-mask () nil +(defbinding widget-shape-combine-mask () nil (widget widget) (shape-mask gdk:bitmap) (x-offset int) (y-offset int)) ;; defined in gtkglue.c -(define-foreign widget-mapped-p () boolean +(defbinding widget-mapped-p () boolean (widget widget))