diff options
Diffstat (limited to 'body/fltk-widgets.adb')
| -rw-r--r-- | body/fltk-widgets.adb | 37 |
1 files changed, 19 insertions, 18 deletions
diff --git a/body/fltk-widgets.adb b/body/fltk-widgets.adb index f5ae433..f4409e4 100644 --- a/body/fltk-widgets.adb +++ b/body/fltk-widgets.adb @@ -8,9 +8,7 @@ with Ada.Assertions, Interfaces.C.Strings, - System.Address_To_Access_Conversions, - FLTK.Widgets.Groups.Windows, - FLTK.Images; + FLTK.Widgets.Groups.Windows; use type @@ -601,7 +599,7 @@ package body FLTK.Widgets is procedure Callback_Hook (W, U : in Storage.Integer_Address) is - Ada_Widget : access Widget'Class := + Ada_Widget : constant access Widget'Class := Widget_Convert.To_Pointer (Storage.To_Address (U)); begin Ada_Widget.Callback.all (Ada_Widget.all); @@ -611,7 +609,7 @@ package body FLTK.Widgets is procedure Draw_Hook (U : in Storage.Integer_Address) is - Ada_Widget : access Widget'Class := + Ada_Widget : constant access Widget'Class := Widget_Convert.To_Pointer (Storage.To_Address (U)); begin Ada_Widget.Draw; @@ -623,7 +621,7 @@ package body FLTK.Widgets is E : in Interfaces.C.int) return Interfaces.C.int is - Ada_Widget : access Widget'Class := + Ada_Widget : constant access Widget'Class := Widget_Convert.To_Pointer (Storage.To_Address (U)); begin return Event_Outcome'Pos (Ada_Widget.Handle (Event_Kind'Val (E))); @@ -639,10 +637,13 @@ package body FLTK.Widgets is procedure Extra_Final (This : in out Widget) is - Maybe_Parent : access FLTK.Widgets.Groups.Group'Class := This.Parent; + Maybe_Parent : access FLTK.Widgets.Groups.Group'Class; begin - if Maybe_Parent /= null then - Maybe_Parent.Remove (This); + if This.Needs_Dealloc then + Maybe_Parent := This.Parent; + if Maybe_Parent /= null then + Maybe_Parent.Remove (This); + end if; end if; end Extra_Final; @@ -1023,13 +1024,13 @@ package body FLTK.Widgets is begin if Parent_Ptr /= Null_Pointer then Parent_Ptr := fl_widget_get_user_data (Parent_Ptr); - pragma Assert (Parent_Ptr /= Null_Pointer); + -- Can't assert user data being not null here because fl_ask is a bitch, + -- so have to fall back on saying that if it's null then you get nothing. + -- Any widget created by users of this binding will have appropriate back + -- reference to the corresponding Ada object in the user data anyway. 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 with - "Widget returned by Fl_Widget::parent has no user_data reference back to Ada"; end Parent; @@ -1136,7 +1137,7 @@ package body FLTK.Widgets is (This : in Widget) return Box_Kind is - Result : Interfaces.C.int := fl_widget_get_box (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_widget_get_box (This.Void_Ptr); begin return Box_Kind'Val (Result); exception @@ -1158,7 +1159,7 @@ package body FLTK.Widgets is (This : in Widget) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_widget_tooltip (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_widget_tooltip (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1185,7 +1186,7 @@ package body FLTK.Widgets is (This : in Widget) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_widget_get_label (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_widget_get_label (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1265,7 +1266,7 @@ package body FLTK.Widgets is (This : in Widget) return Label_Kind is - Result : Interfaces.C.int := fl_widget_get_labeltype (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_widget_get_labeltype (This.Void_Ptr); begin return Label_Kind'Val (Result); exception @@ -1663,7 +1664,7 @@ package body FLTK.Widgets is for my_handle'Address use This.Handle_Ptr; pragma Import (Ada, my_handle); - Result : Interfaces.C.int := my_handle (This.Void_Ptr, Event_Kind'Pos (Event)); + Result : constant Interfaces.C.int := my_handle (This.Void_Ptr, Event_Kind'Pos (Event)); begin return Event_Outcome'Val (Result); exception |