diff options
Diffstat (limited to 'body/fltk-widgets.adb')
| -rw-r--r-- | body/fltk-widgets.adb | 64 |
1 files changed, 19 insertions, 45 deletions
diff --git a/body/fltk-widgets.adb b/body/fltk-widgets.adb index 8bc5c86..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 @@ -26,33 +24,6 @@ package body FLTK.Widgets is package Chk renames Ada.Assertions; - function "+" - (Left, Right : in Callback_Flag) - return Callback_Flag is - begin - return - (Changed => Left.Changed or Right.Changed, - Interact => Left.Interact or Right.Interact, - Release => Left.Release or Right.Release, - Enter_Key => Left.Enter_Key or Right.Enter_Key); - end "+"; - - - function "+" - (Left, Right : in Damage_Mask) - return Damage_Mask is - begin - return - (Child => Left.Child or Right.Child, - Expose => Left.Expose or Right.Expose, - Scroll => Left.Scroll or Right.Scroll, - Overlay => Left.Overlay or Right.Overlay, - User_1 => Left.User_1 or Right.User_1, - User_2 => Left.User_2 or Right.User_2, - Full => Left.Full or Right.Full); - end "+"; - - package Group_Convert is new System.Address_To_Access_Conversions (FLTK.Widgets.Groups.Group'Class); @@ -628,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); @@ -638,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; @@ -650,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))); @@ -666,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; @@ -1050,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; @@ -1163,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 @@ -1185,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 ""; @@ -1212,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 ""; @@ -1292,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 @@ -1690,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 |