Updated for gtk+-1.3.9 and misc changes

diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp
index 717e05d2f98ce94b4f8dee034e81f0dc64fcbb80..3ac6019e4b7ba51e12eb14ed6f0902a33e8d1674 100644 (file)
--- a/gtk/gtk.lisp
+++ b/gtk/gtk.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; 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: gtk.lisp,v 1.5 2001/05/31 21:52:57 espen Exp $
+;; $Id: gtk.lisp,v 1.6 2001/10/21 23:22:04 espen Exp $

 
 
 (in-package "GTK")
 
 
 (in-package "GTK")


@@ -59,8 +59,8 @@ (defbinding accel-label-refetch () boolean
 
 ;;; Bin
 
 
 ;;; Bin
 

-(defun bin-child (bin)
-  (first (container-children bin)))
+(defbinding (bin-child "gtk_bin_get_child") () widget
+  (bin bin))

 
 (defun (setf bin-child) (child bin)
   (let ((old-child (bin-child bin)))
 
 (defun (setf bin-child) (child bin)
   (let ((old-child (bin-child bin)))


@@ -69,21 +69,6 @@ (defun (setf bin-child) (child bin)
   (container-add bin child)
   child)
 
   (container-add bin child)
   child)
 

-(defmethod initialize-instance ((bin bin) &rest initargs &key child)
-  (declare (ignore initargs))
-  (call-next-method)
-  (cond
-   ((consp child)
-    (container-add bin (first child))
-    (setf
-     (slot-value (first child) 'child-slots)
-     (apply
-      #'make-instance
-      (slot-value (class-of bin) 'child-class)
-      :parent bin :child (first child) (cdr child))))
-   (child
-    (container-add bin child))))
-

 
 ;;; Button
 
 
 ;;; Button
 


@@ -122,7 +107,7 @@ (defmethod (setf button-label) ((label string) (button check-button))
 
 ;;; Radio button
 
 
 ;;; Radio button
 

-(defbinding (%radio-button-get-group "gtk_radio_button_group") () pointer
+(defbinding %radio-button-get-group () pointer

   (radio-button radio-button))
 
 (defbinding %radio-button-set-group () nil
   (radio-button radio-button))
 
 (defbinding %radio-button-set-group () nil


@@ -133,11 +118,13 @@ (defun radio-button-add-to-group (button1 button2)
   "Add BUTTON1 to the group which BUTTON2 belongs to."
   (%radio-button-set-group button1 (%radio-button-get-group button2)))
 
   "Add BUTTON1 to the group which BUTTON2 belongs to."
   (%radio-button-set-group button1 (%radio-button-get-group button2)))
 

+

 (defmethod initialize-instance ((button radio-button)
 (defmethod initialize-instance ((button radio-button)

-                               &rest initargs &key group)
+                               &rest initargs &key group-with)
+  (declare (ignore initargs))

   (call-next-method)
   (call-next-method)

-  (when group
-    (radio-button-add-to-group item group)))
+  (when group-with
+    (radio-button-add-to-group item group-with)))

 
 
 ;;; Option menu
 
 
 ;;; Option menu


@@ -191,24 +178,6 @@ (defun (setf menu-item-submenu) (submenu menu-item)
     (%menu-item-set-submenu menu-item submenu))
   submenu)
 
     (%menu-item-set-submenu menu-item submenu))
   submenu)
 

-(defbinding %menu-item-configure () nil
-  (menu-item menu-item)
-  (show-toggle-indicator boolean)
-  (show-submenu-indicator boolean))
-
-(defun (setf menu-item-toggle-indicator-p) (show menu-item)
-  (%menu-item-configure
-   menu-item
-   show
-   (menu-item-submenu-indicator-p menu-item))
-  show)
-
-(defun (setf menu-item-submenu-indicator-p) (show menu-item)
-  (%menu-item-configure
-   menu-item
-   (menu-item-toggle-indicator-p menu-item)
-   show))
-

 (defbinding menu-item-select () nil
   (menu-item menu-item))
 
 (defbinding menu-item-select () nil
   (menu-item menu-item))
 


@@ -218,9 +187,6 @@ (defbinding menu-item-deselect () nil
 (defbinding menu-item-activate () nil
   (menu-item menu-item))
 
 (defbinding menu-item-activate () nil
   (menu-item menu-item))
 

-(defbinding menu-item-right-justify () nil
-  (menu-item menu-item))
-

 
 
 ;;; Check menu item
 
 
 ;;; Check menu item


@@ -232,8 +198,7 @@ (defbinding check-menu-item-toggled () nil
 
 ;;; Radio menu item
 
 
 ;;; Radio menu item
 

-(defbinding (%radio-menu-item-get-group
-            "gtk_radio_menu_item_group") () pointer
+(defbinding %radio-menu-item-get-group () pointer

   (radio-menu-item radio-menu-item))
 
 (defbinding %radio-menu-item-set-group () nil
   (radio-menu-item radio-menu-item))
 
 (defbinding %radio-menu-item-set-group () nil


@@ -245,10 +210,11 @@ (defun radio-menu-item-add-to-group (item1 item2)
   (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
 
 (defmethod initialize-instance ((item radio-menu-item)
   (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
 
 (defmethod initialize-instance ((item radio-menu-item)

-                               &rest initargs &key group)
+                               &rest initargs &key group-with)
+  (declare (ignore initargs))

   (call-next-method)
   (call-next-method)

-  (when group
-    (radio-menu-item-add-to-group item group)))
+  (when group-with
+    (radio-menu-item-add-to-group item group-with)))

   
 
 
   
 
 


@@ -297,12 +263,6 @@ (defbinding file-selection-complete () nil
   (file-selection file-selection)
   (pattern string))
 
   (file-selection file-selection)
   (pattern string))
 

-(defbinding file-selection-show-fileop-buttons () nil
-  (file-selection file-selection))
-
-(defbinding file-selection-hide-fileop-buttons () nil
-  (file-selection file-selection))
-

 
 
 ;;; Scrolled window
 
 
 ;;; Scrolled window


@@ -533,55 +493,55 @@ (defbinding notebook-popup-enable () nil
 (defbinding notebook-popup-disable () nil
   (notebook notebook))
 
 (defbinding notebook-popup-disable () nil
   (notebook notebook))
 

-(defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
-    (notebook ref) widget
-  (notebook notebook)
-  ((if (typep ref 'widget)
-       ref
-     (notebook-nth-page-child notebook ref))
-   widget))
-
-(defbinding %notebook-set-tab-label () nil
-  (notebook notebook)
-  (reference widget)
-  (tab-label widget))
-
-(defun (setf notebook-tab-label) (tab-label notebook reference)
-  (let ((tab-label-widget (if (stringp tab-label)
-                             (label-new tab-label)
-                           tab-label)))
-    (%notebook-set-tab-label
-     notebook
-     (if (typep reference 'widget)
-        reference
-       (notebook-nth-page-child notebook reference))
-     tab-label-widget)
-    tab-label-widget))
+; (defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
+;     (notebook ref) widget
+;   (notebook notebook)
+;   ((if (typep ref 'widget)
+;        ref
+;      (notebook-nth-page-child notebook ref))
+;    widget))
+
+; (defbinding %notebook-set-tab-label () nil
+;   (notebook notebook)
+;   (reference widget)
+;   (tab-label widget))
+
+; (defun (setf notebook-tab-label) (tab-label notebook reference)
+;   (let ((tab-label-widget (if (stringp tab-label)
+;                            (label-new tab-label)
+;                          tab-label)))
+;     (%notebook-set-tab-label
+;      notebook
+;      (if (typep reference 'widget)
+;       reference
+;        (notebook-nth-page-child notebook reference))
+;      tab-label-widget)
+;     tab-label-widget))

    
    

-(defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
-    (notebook ref) widget
-  (notebook notebook)
-  ((if (typep ref 'widget)
-       ref
-     (notebook-nth-page-child notebook ref))
-   widget))
-
-(defbinding %notebook-set-menu-label () nil
-  (notebook notebook)
-  (reference widget)
-  (menu-label widget))
-
-(defun (setf notebook-menu-label) (menu-label notebook reference)
-  (let ((menu-label-widget (if (stringp menu-label)
-                             (label-new menu-label)
-                           menu-label)))
-    (%notebook-set-menu-label
-     notebook
-     (if (typep reference 'widget)
-        reference
-       (notebook-nth-page-child notebook reference))
-     menu-label-widget)
-    menu-label-widget))
+; (defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
+;     (notebook ref) widget
+;   (notebook notebook)
+;   ((if (typep ref 'widget)
+;        ref
+;      (notebook-nth-page-child notebook ref))
+;    widget))
+
+; (defbinding %notebook-set-menu-label () nil
+;   (notebook notebook)
+;   (reference widget)
+;   (menu-label widget))
+
+; (defun (setf notebook-menu-label) (menu-label notebook reference)
+;   (let ((menu-label-widget (if (stringp menu-label)
+;                            (label-new menu-label)
+;                          menu-label)))
+;     (%notebook-set-menu-label
+;      notebook
+;      (if (typep reference 'widget)
+;       reference
+;        (notebook-nth-page-child notebook reference))
+;      menu-label-widget)
+;     menu-label-widget))

 
 (defbinding notebook-query-tab-label-packing (notebook ref) nil
   (notebook notebook)
 
 (defbinding notebook-query-tab-label-packing (notebook ref) nil
   (notebook notebook)


@@ -664,30 +624,11 @@ (defbinding layout-set-size () nil
   (width int)
   (height int))
 
   (width int)
   (height int))
 

-;; gtkglue.c

 (defbinding layout-get-size () nil
   (layout layout)
   (width int :out)
   (height int :out))
 
 (defbinding layout-get-size () nil
   (layout layout)
   (width int :out)
   (height int :out))
 

-(defun layout-x-size (layout)
-  (nth-value 0 (layout-get-size layout)))
-
-(defun layout-y-size (layout)
-  (nth-value 1 (layout-get-size layout)))
-
-(defun (setf layout-x-size) (x layout)
-  (layout-set-size layout x (layout-y-size layout)))
-
-(defun (setf layout-y-size) (y layout)
-  (layout-set-size layout (layout-x-size layout) y))
-
-(defbinding layout-freeze () nil
-  (layout layout))
-
-(defbinding layout-thaw () nil
-  (layout layout))
-

 
 
 ;;; Menu shell
 
 
 ;;; Menu shell


@@ -737,15 +678,6 @@ (defbinding menu-shell-activate-item () nil
 
 ; ;;; Menu
 
 
 ; ;;; Menu
 

-; (defun menu-insert (menu menu-item position)
-;   (menu-shell-insert menu menu-item position))
-
-; (defun menu-append (menu menu-item)
-;   (menu-shell-append menu menu-item))
-
-; (defun menu-prepend (menu menu-item)
-;   (menu-shell-prepend menu menu-item))
-

 ;(defun menu-popup ...)
 
 (defbinding menu-reposition () nil
 ;(defun menu-popup ...)
 
 (defbinding menu-reposition () nil


@@ -754,9 +686,6 @@ (defbinding menu-reposition () nil
 (defbinding menu-popdown () nil
   (menu menu))
 
 (defbinding menu-popdown () nil
   (menu menu))
 

-(defbinding (menu-active "gtk_menu_get_active") () widget
-  (menu menu))
-

 (defbinding %menu-set-active () nil
   (menu menu)
   (index unsigned-int))
 (defbinding %menu-set-active () nil
   (menu menu)
   (index unsigned-int))


@@ -764,14 +693,6 @@ (defbinding %menu-set-active () nil
 (defun (setf menu-active) (menu index)
   (%menu-set-active menu index))
   
 (defun (setf menu-active) (menu index)
   (%menu-set-active menu index))
   

-;(defun menu-attach-to-widget ...)
-
-(defbinding menu-detach () nil
-  (menu menu))
-
-(defbinding (menu-attach-widget "gtk_menu_get_attach_widget") () widget
-  (menu menu))
-

 (defbinding menu-reorder-child () nil
   (menu menu)
   (menu-item menu-item)
 (defbinding menu-reorder-child () nil
   (menu menu)
   (menu-item menu-item)


@@ -800,59 +721,173 @@ (defbinding table-attach (table child left right top bottom
   (x-padding unsigned-int)
   (y-padding unsigned-int))
 
   (x-padding unsigned-int)
   (y-padding unsigned-int))
 

+

 (defbinding %table-set-row-spacing () nil
   (table table)
   (row unsigned-int)
   (spacing unsigned-int))
 
 (defbinding %table-set-row-spacing () nil
   (table table)
   (row unsigned-int)
   (spacing unsigned-int))
 

-(defun (setf table-row-spacing) (spacing table row)
-  (%table-set-row-spacing table row spacing)
+(defbinding %table-set-row-spacings () nil
+  (table table)
+  (spacing unsigned-int))
+
+(defun (setf table-row-spacing) (spacing table &optional row)
+  (if row
+      (%table-set-row-spacing table row spacing)
+    (%table-set-row-spacings table spacing))

   spacing)
 
   spacing)
 

-;; gtkglue.c
-(defbinding table-row-spacing (table row) unsigned-int
+(defbinding %table-get-row-spacing () unsigned-int

   (table table)
   (table table)

-  ((progn
-     (assert (and (>= row 0) (< row (table-rows table))))
-     row) unsigned-int))
+  (row unsigned-int))
+
+(defbinding %table-get-default-row-spacing () unsigned-int
+  (table table))
+
+(defun table-row-spacing (table &optional row)
+  (if row
+      (%table-get-row-spacing table row)
+    (%table-get-default-row-spacing table)))
+

 
 (defbinding %table-set-col-spacing () nil
   (table table)
   (col unsigned-int)
   (spacing unsigned-int))
 
 
 (defbinding %table-set-col-spacing () nil
   (table table)
   (col unsigned-int)
   (spacing unsigned-int))
 

-(defun (setf table-column-spacing) (spacing table column)
-  (%table-set-col-spacing table column spacing)
+(defbinding %table-set-col-spacings () nil
+  (table table)
+  (spacing unsigned-int))
+
+(defun (setf table-col-spacing) (spacing table &optional col)
+  (if col
+      (%table-set-col-spacing table col spacing)
+    (%table-set-col-spacings table spacing))

   spacing)
 
   spacing)
 

-;; gtkglue.c
-(defbinding table-column-spacing (table col) unsigned-int
+(defbinding %table-get-col-spacing () unsigned-int

   (table table)
   (table table)

-  ((progn
-     (assert (and (>= col 0) (< col (table-columns table))))
-     col) unsigned-int))
+  (col unsigned-int))
+
+(defbinding %table-get-default-col-spacing () unsigned-int
+  (table table))
+
+(defun table-col-spacing (table &optional col)
+  (if col
+      (%table-get-col-spacing table col)
+    (%table-get-default-col-spacing table)))
+  
+
+;;; Dialog
+
+(defmethod initialize-instance ((dialog dialog) &rest initargs)
+  (apply #'call-next-method dialog (plist-remove initargs :child))
+  (dolist (button-definition (get-all initargs :button))
+    (apply #'dialog-add-button dialog button-definition))
+  (dolist (child (get-all initargs :child))
+    (apply #'dialog-add-child dialog (mklist child))))

 
 
 
 

-(defun %set-table-child-option (object slot flag value)
-  (let ((options (child-slot-value object slot)))
+(defvar %*response-id-key* (gensym))
+
+(defun %dialog-find-response-id-num (dialog response-id create-p)
+  (or
+   (cadr (assoc response-id (rest (type-expand-1 'response-type))))
+   (let* ((response-ids (object-data dialog %*response-id-key*))
+         (response-id-num (position response-id response-ids)))

     (cond
     (cond

-     ((and value (not (member flag options)))
-      (setf (child-slot-value object slot) (cons flag options)))
-     ((and (not value) (member flag options))
-      (setf (child-slot-value object slot) (delete flag options))))))
-
-(macrolet ((define-option-accessor (name slot flag)
-            `(progn
-               (defun ,name (object)
-                 (member ,flag (child-slot-value object ,slot)))
-               (defun (setf ,name) (value object)
-                 (%set-table-child-option object ,slot ,flag value)))))
-  (define-option-accessor table-child-x-expand-p :x-options :expand)
-  (define-option-accessor table-child-y-expand-p :y-options :expand)
-  (define-option-accessor table-child-x-shrink-p :x-options :shrink)
-  (define-option-accessor table-child-y-shrink-p :y-options :shrink)
-  (define-option-accessor table-child-x-fill-p :x-options :fill)
-  (define-option-accessor table-child-y-fill-p :y-options :fill))
+     (response-id-num)
+     (create-p
+      (cond
+       (response-ids
+       (setf (cdr (last response-ids)) (list response-id))
+       (1- (length response-ids)))
+       (t
+       (setf (object-data dialog %*response-id-key*) (list response-id))
+       0)))
+     (t
+      (error "Invalid response id: ~A" response-id))))))
+
+(defun %dialog-find-response-id (dialog response-id-num)
+  (if (< response-id-num 0)
+      (car
+       (rassoc
+       (list response-id-num)
+       (rest (type-expand-1 'response-type)) :test #'equalp))
+    (nth response-id-num (object-data dialog %*response-id-key*))))
+
+
+(defmethod signal-connect ((dialog dialog) signal function &key object)
+  (case signal
+    (response
+     #'(lambda (dialog response-id-num)
+        (let ((response-id (%dialog-find-response-id dialog response-id-num)))
+          (cond
+           ((eq object t)  (funcall function dialog response-id))
+           (object (funcall function object response-id))
+           (t (funcall function response-id))))))
+    (t
+     (call-next-method))))
+
+
+(defbinding dialog-response (dialog response-id) nil
+  (dialog dialog)
+  ((%dialog-find-response-id-num dialog response-id nil) int))
+  
+(defbinding %dialog-set-default-response () nil
+  (dialog dialog)
+  (response-id-num int))
+
+(defun dialog-set-default-response (dialog response-id)
+  (%dialog-set-default-response
+   dialog (%dialog-find-response-id-num dialog response-id nil)))
+
+(defbinding dialog-set-response-sensitive (dialog response-id sensitive) nil
+  (dialog dialog)
+  ((%dialog-find-response-id-num dialog response-id nil) int)
+  (sensitive boolean))
+
+
+(defbinding %dialog-add-button () button
+  (dialog dialog)
+  (text string)
+  (response-id-num int))
+
+(defun dialog-add-button (dialog label &optional response-id default-p)
+  (let* ((response-id-num
+         (if response-id
+             (%dialog-find-response-id-num dialog response-id t)
+           (length (object-data dialog %*response-id-key*))))
+        (button (%dialog-add-button dialog label response-id-num)))
+    (unless response-id
+      (%dialog-find-response-id-num dialog button t))
+    (when default-p
+      (%dialog-set-default-response dialog response-id-num))
+    button))
+
+
+(defbinding %dialog-add-action-widget () button
+  (dialog dialog)
+  (action-widget widget)
+  (response-id-num int))
+
+(defun dialog-add-action-widget (dialog widget &optional (response-id widget)
+                                default-p)
+  (let ((response-id-num (%dialog-find-response-id-num dialog response-id t)))
+    (%dialog-add-action-widget dialog widget response-id-num)
+    (when default-p
+      (%dialog-set-default-response dialog response-id-num))
+    widget))
+  
+
+(defun dialog-add-child (dialog child &rest args)
+  (apply #'container-add (slot-value dialog 'vbox) child args))
+
+(defmethod container-children ((dialog dialog))
+  (container-children (dialog-vbox dialog)))
+
+(defmethod (setf container-children) (children (dialog dialog))
+  (setf (container-children (dialog-vbox dialog)) children))

 
 
 
 
 
 


@@ -1176,26 +1211,8 @@ (defbinding range-default-vmotion () int
 
 ;;; Scale
 
 
 ;;; Scale
 

-(defbinding scale-draw-value () nil
-  (scale scale))
-
-
-
-;;; Progress
-
-(defbinding progress-configure () adjustment
-  (progress progress)
-  (value single-float)
-  (min single-float)
-  (max single-float))
-
-(defbinding (progress-text-from-value
-            "gtk_progress_get_text_from_value") () string
-  (progress progress))
-
-(defbinding (progress-percentage-from-value
-            "gtk_progress_get_percentage_from_value") () single-float
-  (progress progress))
+; (defbinding scale-draw-value () nil
+;   (scale scale))

 
 
 
 
 
 


@@ -1229,17 +1246,17 @@ (defbinding tooltips-enable () nil
 (defbinding tooltips-disable () nil
   (tooltips tooltips))
 
 (defbinding tooltips-disable () nil
   (tooltips tooltips))
 

+(defun (setf tooltips-enabled-p) (enable tooltips)
+  (if enable
+      (tooltips-enable tooltips)
+    (tooltips-disable tooltips)))
+

 (defbinding tooltips-set-tip () nil
   (tooltips tooltips)
   (widget widget)
   (tip-text string)
   (tip-private string))
 
 (defbinding tooltips-set-tip () nil
   (tooltips tooltips)
   (widget widget)
   (tip-text string)
   (tip-private string))
 

-(defbinding tooltips-set-colors (tooltips background foreground) nil
-  (tooltips tooltips)
-  ((gdk:ensure-color background) gdk:color)
-  ((gdk:ensure-color foreground) gdk:color))
-

 (defbinding tooltips-force-window () nil
   (tooltips tooltips))
 
 (defbinding tooltips-force-window () nil
   (tooltips tooltips))
 


@@ -1357,291 +1374,3 @@ (defbinding accel-group-handle-remove
   ((gdk:keyval-from-name key) unsigned-int)
   (modifiers gdk:modifier-type))
 |#
   ((gdk:keyval-from-name key) unsigned-int)
   (modifiers gdk:modifier-type))
 |#

-
-
-;;; Style
-
-; (defbinding style-new () style)
-
-; (defbinding style-copy () style
-;   (style style))
-#|
-(defbinding %style-get-color () gdk:color
-  (style style)
-  (color-type color-type)
-  (state-type state-type))
-
-(defbinding %style-set-color () gdk:color
-  (style style)
-  (color-type color-type)
-  (state-type state-type)
-  (color gdk:color))
-
-(defun style-fg (style state)
-  (%style-get-color style :foreground state))
-
-(defun (setf style-fg) (color style state)
-  (%style-set-color style :foreground state color))
-
-(defun style-bg (style state)
-  (%style-get-color style :background state))
-
-(defun (setf style-bg) (color style state)
-  (%style-set-color style :background state color))
-
-(defun style-text (style state)
-  (%style-get-color style :text state))
-
-(defun (setf style-text) (color style state)
-  (%style-set-color style :text state color))
-
-(defun style-base (style state)
-  (%style-get-color style :base state))
-
-(defun (setf style-base) (color style state)
-  (%style-set-color style :base state color))
-
-(defun style-white (style)
-  (%style-get-color style :white :normal))
-
-(defun (setf style-white) (color style)
-  (%style-set-color style :white :normal color))
-
-(defun style-black (style)
-  (%style-get-color style :black :normal))
-
-(defun (setf style-black) (color style)
-  (%style-set-color style :black :normal color))
-
-(defbinding style-get-gc () gdk:gc
-  (style style)
-  (color-type color-type)
-  (state-type state-type))
-
-|#
-(defbinding draw-hline () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (x1 int)
-  (x2 int)
-  (y int))
-
-(defbinding draw-vline () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (y1 int)
-  (y2 int)
-  (x int))
-
-(defbinding draw-shadow () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-
-; (defbinding draw-polygon () nil
-;   (style style)
-;   (window gdk:window)
-;   (state state-type)
-;   (shadow shadow-type)
-;   (points (vector gdk:point))
-;   ((length points) int)
-;   (fill boolean))
-
-(defbinding draw-arrow () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (arrow arrow-type)
-  (fill boolean)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-  
-(defbinding draw-diamond () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-
-; (defbinding draw-oval () nil
-;   (style style)
-;   (window gdk:window)
-;   (state state-type)
-;   (shadow shadow-type)
-;   (x int)
-;   (y int)
-;   (width int)
-;   (height int))
-
-(defbinding draw-string () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (x int)
-  (y int)
-  (string string))
-
-(defbinding draw-box () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-
-(defbinding draw-flat-box () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-
-(defbinding draw-check () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-
-(defbinding draw-option () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-
-; (defbinding draw-cross () nil
-;   (style style)
-;   (window gdk:window)
-;   (state state-type)
-;   (shadow shadow-type)
-;   (x int)
-;   (y int)
-;   (width int)
-;   (height int))
-
-; (defbinding draw-ramp () nil
-;   (style style)
-;   (window gdk:window)
-;   (state state-type)
-;   (shadow shadow-type)
-;   (arrow arrow-type)
-;   (x int)
-;   (y int)
-;   (width int)
-;   (height int))
-
-(defbinding draw-tab () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-
-(defbinding draw-shadow-gap () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int)
-  (gap-side position-type)
-  (gap-x int)
-  (gap-width int))
-
-(defbinding draw-box-gap () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int)
-  (gap-side position-type)
-  (gap-x int)
-  (gap-width int))
-
-(defbinding draw-extension () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-
-(defbinding draw-focus () nil
-  (style style)
-  (window gdk:window)
-  (x int)
-  (y int)
-  (width int)
-  (height int))
-
-(defbinding draw-slider () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int)
-  (orientation orientation))
-
-(defbinding draw-handle () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int)
-  (orientation orientation))
-
-(defbinding draw-handle () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (shadow shadow-type)
-  (x int)
-  (y int)
-  (width int)
-  (height int)
-  (orientation orientation))
-
-(defbinding paint-hline () nil
-  (style style)
-  (window gdk:window)
-  (state state-type)
-  (x1 int)
-  (x2 int)
-  (y int))

diff --git a/gtk/gtkcontainer.lisp b/gtk/gtkcontainer.lisp
index 4be4d2227edd8f8af251a0fe6238cb1561495ba6..bb8bb7613aab552bf725f328b6fd7b92995e8daf 100644 (file)
--- a/gtk/gtkcontainer.lisp
+++ b/gtk/gtkcontainer.lisp
@@ -15,49 +15,40 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; 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: gtkcontainer.lisp,v 1.3 2001/05/29 16:03:04 espen Exp $
+;; $Id: gtkcontainer.lisp,v 1.4 2001/10/21 23:20:13 espen Exp $

 
 (in-package "GTK")
 
 
 (in-package "GTK")
 

-
-(defmethod initialize-instance ((container container) &rest initargs
-                               &key children)
-  (declare (ignore initargs))
+(defmethod initialize-instance ((container container) &rest initargs)

   (call-next-method)
   (call-next-method)

-  (dolist (child children)
-    (cond
-     ((consp child)
-      (container-add container (first child))
-      (setf
-       (slot-value (first child) 'child-slots)
-       (apply
-       #'make-instance
-       (slot-value (class-of container) 'child-class)
-       :parent container :child (first child) (cdr child))))
-     (t
-      (container-add container child)))))
-
-(defbinding %container-child-getv () nil
-  (container container)
-  (child widget)
-  (1 unsigned-int)
-  (arg arg))
+  (dolist (child (get-all initargs :child))
+    (apply #'container-add container (mklist child))))

 
 

-(defbinding %container-child-setv () nil
-  (container container)
-  (child widget)
-  (1 unsigned-int)
-  (arg arg))
-  

 
 

-(defbinding container-add () nil
+(defbinding %container-add () nil

   (container container)
   (widget widget))
 
   (container container)
   (widget widget))
 

-(defbinding container-remove () nil
+(defun container-add (container widget &rest args)
+  (%container-add container widget)
+  (when args
+    (setf
+     (slot-value widget 'child-slots)
+     (apply
+      #'make-instance
+      (gethash (class-of container) *container-to-child-class-mappings*)
+      :parent container :child widget args))))
+
+
+(defbinding %container-remove () nil

   (container container)
   (widget widget))
 
   (container container)
   (widget widget))
 

+(defun container-remove (container widget)
+  (%container-remove container widget)
+  (slot-makunbound widget 'child-slots))
+
+

 (defbinding container-check-resize () nil
   (container container))
 
 (defbinding container-check-resize () nil
   (container container))
 


@@ -66,7 +57,7 @@ (defbinding (%container-foreach "gtk_container_foreach_full")
   (container container)
   (0 unsigned-long)
   (*callback-marshal* pointer)
   (container container)
   (0 unsigned-long)
   (*callback-marshal* pointer)

-  ((register-callback-function function) unsigned-long)
+  ((register-callback-function function) pointer)

   (*destroy-marshal* pointer))
 
 (defun map-container (seqtype func container)
   (*destroy-marshal* pointer))
 
 (defun map-container (seqtype func container)


@@ -104,10 +95,13 @@ (defmacro do-container ((var container &optional (result nil)) &body body)
                (setq ,continue t)))))
        ,result)))
 
                (setq ,continue t)))))
        ,result)))
 

-(defbinding container-children () (glist widget)
+(defbinding %container-get-children () (glist widget)

   (container container))
 
   (container container))
 

-(defun (setf container-children) (children container)
+(defmethod container-children ((container container))
+  (%container-get-children container))
+
+(defmethod (setf container-children) (children (container container))

   (dolist (child (container-children container))
     (container-remove container child))
   (dolist (child children)
   (dolist (child (container-children container))
     (container-remove container child))
   (dolist (child children)

diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp
index 626dca076533124ce51d193757e7298d75317fa9..9a07ec8cc2326d0b9ba2ef98c949c25e7bd3add9 100644 (file)
--- a/gtk/gtkwidget.lisp
+++ b/gtk/gtkwidget.lisp
@@ -1,5 +1,5 @@
 ;; Common Lisp bindings for GTK+ v2.0
 ;; Common Lisp bindings for GTK+ v2.0

-;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
+;; Copyright (C) 2000-2001 Espen S. Johnsen <espen@users.sourceforge.net>

 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public


@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; 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.4 2001/05/29 15:58:24 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.5 2001/10/21 23:22:04 espen Exp $

 
 (in-package "GTK")
 
 
 (in-package "GTK")
 


@@ -23,21 +23,19 @@ (in-package "GTK")
 (defmethod initialize-instance ((widget widget) &rest initargs &key parent)
   (declare (ignore initargs))
   (call-next-method)
 (defmethod initialize-instance ((widget widget) &rest initargs &key parent)
   (declare (ignore initargs))
   (call-next-method)

-  (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))))
+  (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 gobject) (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
   (cond
    ((and (eq slot 'child-slots) (slot-value object 'parent))
     (with-slots (parent child-slots) object


@@ -171,18 +169,6 @@ (defbinding widget-allocation () nil
   (width int :out)
   (height int :out))
 
   (width int :out)
   (height int :out))
 

-
-(defbinding 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))
-

 (defbinding widget-add-events () nil
   (widget widget)
   (events gdk:event-mask))
 (defbinding widget-add-events () nil
   (widget widget)
   (events gdk:event-mask))


@@ -194,12 +180,6 @@ (defbinding (widget-ancestor "gtk_widget_get_ancestor") (widget type) widget
   (widget widget)
   ((find-type-number type) type-number))
 
   (widget widget)
   ((find-type-number type) type-number))
 

-; (defbinding ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap
-;   (widget widget))
-
-; (defbinding ("gtk_widget_get_visual" widget-visual) () gdk:visual
-;   (widget widget))
-

 (defbinding (widget-pointer "gtk_widget_get_pointer") () nil
   (widget widget)
   (x int :out)
 (defbinding (widget-pointer "gtk_widget_get_pointer") () nil
   (widget widget)
   (x int :out)


@@ -209,15 +189,9 @@ (defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
   (widget widget)
   (ancestor widget))
 
   (widget widget)
   (ancestor widget))
 

-(defbinding widget-set-rc-style () nil
-  (widget widget))
-

 (defbinding widget-ensure-style () nil
   (widget widget))
 
 (defbinding widget-ensure-style () nil
   (widget widget))
 

-(defbinding widget-restore-default-style () nil
-  (widget widget))
-

 (defbinding widget-reset-rc-styles () nil
   (widget widget))
 
 (defbinding widget-reset-rc-styles () nil
   (widget widget))
 


@@ -232,43 +206,25 @@ (defun (setf widget-cursor) (cursor-type widget)
 ;; This will override the values that got set by the
 ;; widget-set-default-* functions.
 
 ;; This will override the values that got set by the
 ;; widget-set-default-* functions.
 

-(defbinding widget-push-style () nil
-  (style style))
-

 (defbinding widget-push-colormap () nil
   (colormap gdk:colormap))
 
 (defbinding widget-push-colormap () nil
   (colormap gdk:colormap))
 

-; (defbinding widget-push-visual () nil
-;   (visual gdk:visual))
-

 (defbinding widget-push-composite-child () nil)
 
 (defbinding widget-push-composite-child () nil)
 

-(defbinding widget-pop-style () nil)
-

 (defbinding widget-pop-colormap () nil)
 
 (defbinding widget-pop-colormap () nil)
 

-;(defbinding widget-pop-visual () nil)
-

 (defbinding widget-pop-composite-child () nil)
 
 
 ;; Set certain default values to be used at widget creation time.
 
 (defbinding widget-pop-composite-child () nil)
 
 
 ;; Set certain default values to be used at widget creation time.
 

-(defbinding widget-set-default-style () nil
-  (style style))
-

 (defbinding widget-set-default-colormap () nil
   (colormap gdk:colormap))
 
 (defbinding widget-set-default-colormap () nil
   (colormap gdk:colormap))
 

-; (defbinding widget-set-default-visual () nil
-;   (visual gdk:visual))
-

 (defbinding widget-get-default-style () style)
 
 (defbinding widget-get-default-colormap () gdk:colormap)
 
 (defbinding widget-get-default-style () style)
 
 (defbinding widget-get-default-colormap () gdk:colormap)
 

-(defbinding widget-get-default-visual () gdk:visual)
-

 (defbinding widget-shape-combine-mask () nil
   (widget widget)
   (shape-mask gdk:bitmap)
 (defbinding widget-shape-combine-mask () nil
   (widget widget)
   (shape-mask gdk:bitmap)