From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Fri, 16 Sep 2011 19:18:07 +0000 (-0700)
Subject: Propagate destroy through <gtk-container>.  Use it with <fix-layout>s.
X-Git-Tag: mit-scheme-pucked-9.2.12~619
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c82e171568e854170917b2b6e8840c7a85c470f3;p=mit-scheme.git

Propagate destroy through <gtk-container>.  Use it with <fix-layout>s.
---

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index fe51b033b..31c7f46a4 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -65,6 +65,11 @@ USA.
 
 (define-guarantee fix-layout "a <fix-layout>")
 
+(define-method gtk-object-destroy-callback ((layout <fix-layout>))
+  (call-next-method layout)
+  (let ((drawing (fix-layout-drawing layout)))
+    (if drawing (fix-drawing-remove-widget! drawing layout))))
+
 (define-integrable (allocate-color! layout spec)
   (let* ((colors (fix-layout-colors layout))
 	 (entry (assoc spec colors)))
diff --git a/src/gtk/gtk-object.scm b/src/gtk/gtk-object.scm
index e9ae02d38..f8969b569 100644
--- a/src/gtk/gtk-object.scm
+++ b/src/gtk/gtk-object.scm
@@ -452,6 +452,10 @@ USA.
   ;; they were added.
   (reverse-children define standard initial-value '()))
 
+(define-method gtk-object-destroy-callback ((container <gtk-container>))
+  (call-next-method container)
+  (for-each gtk-object-destroy (gtk-container-reverse-children container)))
+
 (define-guarantee gtk-container "a <gtk-container>")
 
 (define (gtk-container-children container)
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 94d470498..c1041f6cd 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -213,7 +213,9 @@ USA.
   (import (gtk pango)
 	   make-pango-layout pango-rectangle pangos->pixels pixels->pangos)
   (import (gtk gtk-object)
-	  parse-gdkcolor set-gtk-object-destroy-callback!)
+	  parse-gdkcolor
+	  set-gtk-object-destroy-callback!
+	  gtk-object-destroy-callback)
   (export (gtk)
 
 	  <fix-layout> fix-layout? make-fix-layout set-fix-layout-size!