From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Thu, 22 Sep 2011 17:55:29 +0000 (-0700)
Subject: Fixed <fix-widget> init.  Free colors upon destruction.
X-Git-Tag: mit-scheme-pucked-9.2.12~613
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b1eb757d9429e1446c5a25806c9a5cb66207c918;p=mit-scheme.git

Fixed <fix-widget> init.  Free colors upon destruction.
---

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index 065fda1d1..ec5fe8411 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -41,7 +41,8 @@ USA.
   ;; GdkColor structs with .pixels courtesy of gdk_rgb_find_color.
   ;; This is oblivious to GtkStyle settings, e.g. set with
   ;; set-gtk-widget-bg-color!.  It may (re)allocate a previously set
-  ;; background color (but just once).
+  ;; background color (but just once).  Upon destruction, these are
+  ;; just freed -- no GdkColor de-allocating required.
   (colors define standard initial-value '())
 
   ;; Our window geometry (allocation) -- a rectangular extent in
@@ -59,10 +60,22 @@ USA.
 
   (call-next-method widget)
   (%trace "; (initialize-instance <fix-widget>) "widget" "width" "height"\n")
+
+  (let ((alien (gobject-alien widget)))
+    (let ((w (->requisition-fixnum width))
+	  (h (->requisition-fixnum height)))
+      (C-call "gtk_widget_set_size_request" alien w h))
+    (C-call "gtk_widget_set_has_window" alien 1)) ; WILL have when realized
+
   (set-gtk-object-destroy-callback! widget)
   (set-gtk-widget-realize-callback! widget fix-widget-realize-callback)
   (set-gtk-widget-size-allocate-callback! widget fix-widget-allocate-callback))
 
+(define-method gtk-object-destroy-callback ((widget <fix-widget>))
+  (call-next-method widget)
+  (for-each (lambda (spec.gdkcolor) (free (cdr spec.gdkcolor)))
+	    (fix-widget-colors widget)))
+
 (define-generic fix-widget-realize-callback (widget))
 
 (define-method fix-widget-realize-callback ((widget <fix-widget>))
@@ -109,9 +122,12 @@ USA.
       (set-fix-rect! (fix-widget-geometry widget) #f #f width height)
       (%trace ";  window: "main-GdkWindow"\n"))
 
-    (let ((GtkStyle (C-> GtkWidget "GtkWidget style")))
-      (C-call "gtk_style_attach" GtkStyle GtkStyle main-GdkWindow)
-      (C->= GtkWidget "GtkWidget style" GtkStyle))
+    (let ((alien (C-> GtkWidget "GtkWidget style")))
+      (C-call "gtk_style_attach" alien alien main-GdkWindow)
+      (C-> GtkWidget "GtkWidget style" alien)
+      (C-> alien "GtkStyle bg" alien)
+      (C-array-loc! alien "GdkColor" (C-enum "GTK_STATE_NORMAL"))
+      (C-call "gdk_window_set_background" main-GdkWindow alien))
 
     unspecific))