Ensured Widgets will remove themselves from a Group upon dealloc and Groups won't inadvertantly dealloc Widgets upon Clear

6 files changed, 143 insertions, 37 deletions

diff --git a/src/c_fl_scroll.cpp b/src/c_fl_scroll.cpp
index ab63827..b3d2c14 100644
--- a/src/c_fl_scroll.cpp
+++ b/src/c_fl_scroll.cpp
@@ -56,8 +56,12 @@ void free_fl_scroll(SCROLL s) {
 
 
 
-void fl_scroll_clear(SCROLL s) {
-    reinterpret_cast<Fl_Scroll*>(s)->clear();
+void * fl_scroll_hscrollbar(SCROLL s) {
+    return &static_cast<Fl_Scroll*>(s)->hscrollbar;
+}
+
+void * fl_scroll_scrollbar(SCROLL s) {
+    return &static_cast<Fl_Scroll*>(s)->scrollbar;
 }
 
 
diff --git a/src/c_fl_scroll.h b/src/c_fl_scroll.h
index 9bbd749..a6f3767 100644
--- a/src/c_fl_scroll.h
+++ b/src/c_fl_scroll.h
@@ -15,7 +15,8 @@ extern "C" SCROLL new_fl_scroll(int x, int y, int w, int h, char* label);
 extern "C" void free_fl_scroll(SCROLL s);
 
 
-extern "C" void fl_scroll_clear(SCROLL s);
+extern "C" void * fl_scroll_hscrollbar(SCROLL s);
+extern "C" void * fl_scroll_scrollbar(SCROLL s);
 
 
 extern "C" void fl_scroll_to(SCROLL s, int x, int y);
diff --git a/src/fltk-widgets-groups-scrolls.adb b/src/fltk-widgets-groups-scrolls.adb
index f2adadd..ebffdbe 100644
--- a/src/fltk-widgets-groups-scrolls.adb
+++ b/src/fltk-widgets-groups-scrolls.adb
@@ -31,10 +31,17 @@ package body FLTK.Widgets.Groups.Scrolls is
 
 
 
-    procedure fl_scroll_clear
-           (S : in Storage.Integer_Address);
-    pragma Import (C, fl_scroll_clear, "fl_scroll_clear");
-    pragma Inline (fl_scroll_clear);
+    function fl_scroll_hscrollbar
+           (S : in Storage.Integer_Address)
+        return Storage.Integer_Address;
+    pragma Import (C, fl_scroll_hscrollbar, "fl_scroll_hscrollbar");
+    pragma Inline (fl_scroll_hscrollbar);
+
+    function fl_scroll_scrollbar
+           (S : in Storage.Integer_Address)
+        return Storage.Integer_Address;
+    pragma Import (C, fl_scroll_scrollbar, "fl_scroll_scrollbar");
+    pragma Inline (fl_scroll_scrollbar);
 
 
 
@@ -100,9 +107,18 @@ package body FLTK.Widgets.Groups.Scrolls is
     --  Destructors  --
     -------------------
 
+    --  It's the only way to be sure
+    procedure fl_scrollbar_extra_final
+           (Ada_Obj : in Storage.Integer_Address);
+    pragma Import (C, fl_scrollbar_extra_final, "fl_scrollbar_extra_final");
+    pragma Inline (fl_scrollbar_extra_final);
+
+
     procedure Extra_Final
            (This : in out Scroll) is
     begin
+        fl_scrollbar_extra_final (Storage.To_Integer (This.Horizon'Address));
+        fl_scrollbar_extra_final (Storage.To_Integer (This.Vertigo'Address));
         Extra_Final (Group (This));
     end Extra_Final;
 
@@ -124,11 +140,38 @@ package body FLTK.Widgets.Groups.Scrolls is
     --  Constructors  --
     --------------------
 
+    --  Hold on, I know a shortcut
+    procedure fl_scrollbar_extra_init
+           (Ada_Obj    : in Storage.Integer_Address;
+            X, Y, W, H : in Interfaces.C.int;
+            C_Str      : in Interfaces.C.char_array);
+    pragma Import (C, fl_scrollbar_extra_init, "fl_scrollbar_extra_init");
+    pragma Inline (fl_scrollbar_extra_init);
+
+
     procedure Extra_Init
            (This       : in out Scroll;
             X, Y, W, H : in     Integer;
             Text       : in     String) is
     begin
+        Widget (This.Horizon).Void_Ptr := fl_scroll_hscrollbar (This.Void_Ptr);
+        Widget (This.Horizon).Needs_Dealloc := False;
+        fl_scrollbar_extra_init
+           (Storage.To_Integer (This.Horizon'Address),
+            Interfaces.C.int (This.Horizon.Get_X),
+            Interfaces.C.int (This.Horizon.Get_Y),
+            Interfaces.C.int (This.Horizon.Get_W),
+            Interfaces.C.int (This.Horizon.Get_H),
+            Interfaces.C.To_C (This.Horizon.Get_Label));
+        Widget (This.Vertigo).Void_Ptr := fl_scroll_scrollbar (This.Void_Ptr);
+        Widget (This.Vertigo).Needs_Dealloc := False;
+        fl_scrollbar_extra_init
+           (Storage.To_Integer (This.Vertigo'Address),
+            Interfaces.C.int (This.Vertigo.Get_X),
+            Interfaces.C.int (This.Vertigo.Get_Y),
+            Interfaces.C.int (This.Vertigo.Get_W),
+            Interfaces.C.int (This.Vertigo.Get_H),
+            Interfaces.C.To_C (This.Vertigo.Get_Label));
         Extra_Init (Group (This), X, Y, W, H, Text);
     end Extra_Init;
 
@@ -164,6 +207,28 @@ package body FLTK.Widgets.Groups.Scrolls is
 
 
 
+    ------------------
+    --  Attributes  --
+    ------------------
+
+    function H_Bar
+           (This : in out Scroll)
+        return Valuators.Sliders.Scrollbars.Scrollbar_Reference is
+    begin
+        return (Data => This.Horizon'Unchecked_Access);
+    end H_Bar;
+
+
+    function V_Bar
+           (This : in out Scroll)
+        return Valuators.Sliders.Scrollbars.Scrollbar_Reference is
+    begin
+        return (Data => This.Vertigo'Unchecked_Access);
+    end V_Bar;
+
+
+
+
     -----------------------
     --  API Subprograms  --
     -----------------------
@@ -171,7 +236,14 @@ package body FLTK.Widgets.Groups.Scrolls is
     procedure Clear
            (This : in out Scroll) is
     begin
-        fl_scroll_clear (This.Void_Ptr);
+        --  Can't use the actual clear method here because that would
+        --  delete the widgets from memory, and the binding is meant to
+        --  handle that, not the library.
+        This.Remove (This.Horizon);
+        This.Remove (This.Vertigo);
+        Group (This).Clear;
+        This.Add (This.Horizon);
+        This.Add (This.Vertigo);
     end Clear;
 
 
diff --git a/src/fltk-widgets-groups-scrolls.ads b/src/fltk-widgets-groups-scrolls.ads
index 11b7f9a..8030fcd 100644
--- a/src/fltk-widgets-groups-scrolls.ads
+++ b/src/fltk-widgets-groups-scrolls.ads
@@ -4,6 +4,11 @@
 --  Released into the public domain
 
 
+with
+
+    FLTK.Widgets.Valuators.Sliders.Scrollbars;
+
+
 package FLTK.Widgets.Groups.Scrolls is
 
 
@@ -36,6 +41,17 @@ package FLTK.Widgets.Groups.Scrolls is
 
 
 
+    function H_Bar
+           (This : in out Scroll)
+        return Valuators.Sliders.Scrollbars.Scrollbar_Reference;
+
+    function V_Bar
+           (This : in out Scroll)
+        return Valuators.Sliders.Scrollbars.Scrollbar_Reference;
+
+
+
+
     procedure Clear
            (This : in out Scroll);
 
@@ -86,7 +102,9 @@ package FLTK.Widgets.Groups.Scrolls is
 private
 
 
-    type Scroll is new Group with null record;
+    type Scroll is new Group with record
+        Horizon, Vertigo : aliased Valuators.Sliders.Scrollbars.Scrollbar;
+    end record;
 
     overriding procedure Initialize
            (This : in out Scroll);
@@ -97,12 +115,10 @@ private
     procedure Extra_Init
            (This       : in out Scroll;
             X, Y, W, H : in     Integer;
-            Text       : in     String)
-    with Inline;
+            Text       : in     String);
 
     procedure Extra_Final
-           (This : in out Scroll)
-    with Inline;
+           (This : in out Scroll);
 
 
     pragma Inline (Clear);
diff --git a/src/fltk-widgets.adb b/src/fltk-widgets.adb
index 870eade..beae56d 100644
--- a/src/fltk-widgets.adb
+++ b/src/fltk-widgets.adb
@@ -6,6 +6,7 @@
 
 with
 
+    Ada.Assertions,
     Interfaces.C.Strings,
     System.Address_To_Access_Conversions,
     FLTK.Widgets.Groups.Windows,
@@ -21,6 +22,9 @@ use type
 package body FLTK.Widgets is
 
 
+    package Chk renames Ada.Assertions;
+
+
     function "+"
            (Left, Right : in Callback_Flag)
         return Callback_Flag is
@@ -29,8 +33,6 @@ package body FLTK.Widgets is
     end "+";
 
 
-
-
     package Group_Convert is new
         System.Address_To_Access_Conversions (FLTK.Widgets.Groups.Group'Class);
 
@@ -516,9 +518,13 @@ package body FLTK.Widgets is
     -------------------
 
     procedure Extra_Final
-           (This : in out Widget) is
+           (This : in out Widget)
+    is
+        Maybe_Parent : access FLTK.Widgets.Groups.Group'Class := This.Parent;
     begin
-        null;
+        if Maybe_Parent /= null then
+            Maybe_Parent.Remove (This);
+        end if;
     end Extra_Final;
 
 
@@ -772,15 +778,17 @@ package body FLTK.Widgets is
            (This : in Widget)
         return access FLTK.Widgets.Groups.Group'Class
     is
-        Parent_Ptr : Storage.Integer_Address;
+        Parent_Ptr : Storage.Integer_Address := fl_widget_get_parent (This.Void_Ptr);
         Actual_Parent : access FLTK.Widgets.Groups.Group'Class;
     begin
-        Parent_Ptr := fl_widget_get_parent (This.Void_Ptr);
         if Parent_Ptr /= Null_Pointer then
-            Actual_Parent := Group_Convert.To_Pointer
-                (Storage.To_Address (fl_widget_get_user_data (Parent_Ptr)));
+            Parent_Ptr := fl_widget_get_user_data (Parent_Ptr);
+            pragma Assert (Parent_Ptr /= Null_Pointer);
+            Actual_Parent := Group_Convert.To_Pointer (Storage.To_Address (Parent_Ptr));
         end if;
         return Actual_Parent;
+    exception
+    when Chk.Assertion_Error => raise Internal_FLTK_Error;
     end Parent;
 
 
@@ -806,15 +814,17 @@ package body FLTK.Widgets is
            (This : in Widget)
         return access FLTK.Widgets.Groups.Windows.Window'Class
     is
-        Window_Ptr : Storage.Integer_Address;
+        Window_Ptr : Storage.Integer_Address := fl_widget_window (This.Void_Ptr);
         Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class;
     begin
-        Window_Ptr := fl_widget_window (This.Void_Ptr);
         if Window_Ptr /= Null_Pointer then
-            Actual_Window := Window_Convert.To_Pointer
-                (Storage.To_Address (fl_widget_get_user_data (Window_Ptr)));
+            Window_Ptr := fl_widget_get_user_data (Window_Ptr);
+            pragma Assert (Window_Ptr /= Null_Pointer);
+            Actual_Window := Window_Convert.To_Pointer (Storage.To_Address (Window_Ptr));
         end if;
         return Actual_Window;
+    exception
+    when Chk.Assertion_Error => raise Internal_FLTK_Error;
     end Nearest_Window;
 
 
@@ -822,15 +832,17 @@ package body FLTK.Widgets is
            (This : in Widget)
         return access FLTK.Widgets.Groups.Windows.Window'Class
     is
-        Window_Ptr : Storage.Integer_Address;
+        Window_Ptr : Storage.Integer_Address := fl_widget_top_window (This.Void_Ptr);
         Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class;
     begin
-        Window_Ptr := fl_widget_top_window (This.Void_Ptr);
         if Window_Ptr /= Null_Pointer then
-            Actual_Window := Window_Convert.To_Pointer
-                (Storage.To_Address (fl_widget_get_user_data (Window_Ptr)));
+            Window_Ptr := fl_widget_get_user_data (Window_Ptr);
+            pragma Assert (Window_Ptr /= Null_Pointer);
+            Actual_Window := Window_Convert.To_Pointer (Storage.To_Address (Window_Ptr));
         end if;
         return Actual_Window;
+    exception
+    when Chk.Assertion_Error => raise Internal_FLTK_Error;
     end Top_Window;
 
 
@@ -839,18 +851,20 @@ package body FLTK.Widgets is
             Offset_X, Offset_Y : out Integer)
         return access FLTK.Widgets.Groups.Windows.Window'Class
     is
-        Window_Ptr : Storage.Integer_Address;
-        Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class;
-    begin
-        Window_Ptr := fl_widget_top_window_offset
+        Window_Ptr : Storage.Integer_Address := fl_widget_top_window_offset
            (This.Void_Ptr,
             Interfaces.C.int (Offset_X),
             Interfaces.C.int (Offset_Y));
+        Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class;
+    begin
         if Window_Ptr /= Null_Pointer then
-            Actual_Window := Window_Convert.To_Pointer
-                (Storage.To_Address (fl_widget_get_user_data (Window_Ptr)));
+            Window_Ptr := fl_widget_get_user_data (Window_Ptr);
+            pragma Assert (Window_Ptr /= Null_Pointer);
+            Actual_Window := Window_Convert.To_Pointer (Storage.To_Address (Window_Ptr));
         end if;
         return Actual_Window;
+    exception
+    when Chk.Assertion_Error => raise Internal_FLTK_Error;
     end Top_Window_Offset;
 
 
diff --git a/src/fltk-widgets.ads b/src/fltk-widgets.ads
index 3381e6e..5765196 100644
--- a/src/fltk-widgets.ads
+++ b/src/fltk-widgets.ads
@@ -382,8 +382,7 @@ private
             Text       : in     String);
 
     procedure Extra_Final
-           (This : in out Widget)
-    with Inline;
+           (This : in out Widget);
 
 
     type Callback_Flag is new Interfaces.C.unsigned;