diff options
Diffstat (limited to 'body/fltk-widgets-groups.adb')
| -rw-r--r-- | body/fltk-widgets-groups.adb | 85 |
1 files changed, 61 insertions, 24 deletions
diff --git a/body/fltk-widgets-groups.adb b/body/fltk-widgets-groups.adb index 3b2e287..d6b51d4 100644 --- a/body/fltk-widgets-groups.adb +++ b/body/fltk-widgets-groups.adb @@ -26,6 +26,8 @@ package body FLTK.Widgets.Groups is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_group (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -41,6 +43,8 @@ package body FLTK.Widgets.Groups is + -- Contents Modification -- + procedure fl_group_add (G, W : in Storage.Integer_Address); pragma Import (C, fl_group_add, "fl_group_add"); @@ -71,6 +75,8 @@ package body FLTK.Widgets.Groups is + -- Contents Query -- + function fl_group_child (G : in Storage.Integer_Address; I : in Interfaces.C.int) @@ -93,6 +99,8 @@ package body FLTK.Widgets.Groups is + -- Clipping -- + function fl_group_get_clip_children (G : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -108,6 +116,8 @@ package body FLTK.Widgets.Groups is + -- Dimensions -- + procedure fl_group_add_resizable (G, W : in Storage.Integer_Address); pragma Import (C, fl_group_add_resizable, "fl_group_add_resizable"); @@ -138,6 +148,8 @@ package body FLTK.Widgets.Groups is + -- Current -- + function fl_group_get_current return Storage.Integer_Address; pragma Import (C, fl_group_get_current, "fl_group_get_current"); @@ -161,6 +173,8 @@ package body FLTK.Widgets.Groups is + -- Drawing, Events -- + procedure fl_group_draw (W : in Storage.Integer_Address); pragma Import (C, fl_group_draw, "fl_group_draw"); @@ -203,7 +217,9 @@ package body FLTK.Widgets.Groups is procedure Extra_Final (This : in out Group) is begin - This.Clear; + if This.Needs_Dealloc then + This.Clear; + end if; Extra_Final (Widget (This)); end Extra_Final; @@ -252,11 +268,11 @@ package body FLTK.Widgets.Groups is begin return This : Group do This.Void_Ptr := new_fl_group - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -282,6 +298,8 @@ package body FLTK.Widgets.Groups is -- API Subprograms -- ----------------------- + -- Contents Modification -- + procedure Add (This : in out Group; Item : in out Widget'Class) is @@ -296,9 +314,9 @@ package body FLTK.Widgets.Groups is Place : in Index) is begin fl_group_insert - (This.Void_Ptr, - Item.Void_Ptr, - Interfaces.C.int (Place) - 1); + (This.Void_Ptr, + Item.Void_Ptr, + Interfaces.C.int (Place) - 1); end Insert; @@ -308,9 +326,9 @@ package body FLTK.Widgets.Groups is Before : in Widget'Class) is begin fl_group_insert2 - (This.Void_Ptr, - Item.Void_Ptr, - Before.Void_Ptr); + (This.Void_Ptr, + Item.Void_Ptr, + Before.Void_Ptr); end Insert; @@ -343,6 +361,8 @@ package body FLTK.Widgets.Groups is + -- Contents Query -- + function Has_Child (This : in Group; Place : in Index) @@ -374,7 +394,8 @@ package body FLTK.Widgets.Groups is Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Widget_Ptr)); return (Data => Actual_Widget); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Group::child returned Widget with no user_data reference back to Ada"; end Child; @@ -392,7 +413,7 @@ package body FLTK.Widgets.Groups is Item : in Widget'Class) return Extended_Index is - Result : Interfaces.C.int := fl_group_find (This.Void_Ptr, Item.Void_Ptr); + Result : constant Interfaces.C.int := fl_group_find (This.Void_Ptr, Item.Void_Ptr); begin if Result = fl_group_children (This.Void_Ptr) then return No_Index; @@ -411,11 +432,13 @@ package body FLTK.Widgets.Groups is + -- Iteration -- + function Iterate (This : in Group) return Group_Iterators.Reversible_Iterator'Class is begin - return It : Iterator := (My_Container => This'Unrestricted_Access); + return It : constant Iterator := (My_Container => This'Unrestricted_Access); end Iterate; @@ -423,7 +446,7 @@ package body FLTK.Widgets.Groups is (Object : in Iterator) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Object.My_Container, My_Index => 1); end First; @@ -437,7 +460,7 @@ package body FLTK.Widgets.Groups is if Object.My_Container /= Place.My_Container then raise Program_Error; end if; - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Place.My_Container, My_Index => Place.My_Index + 1); end Next; @@ -447,7 +470,7 @@ package body FLTK.Widgets.Groups is (Object : in Iterator) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Object.My_Container, My_Index => Object.My_Container.Number_Of_Children); end Last; @@ -461,7 +484,7 @@ package body FLTK.Widgets.Groups is if Object.My_Container /= Place.My_Container then raise Program_Error; end if; - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Place.My_Container, My_Index => Place.My_Index - 1); end Previous; @@ -469,13 +492,19 @@ package body FLTK.Widgets.Groups is + -- Clipping -- + function Get_Clip_Mode (This : in Group) - return Clip_Mode is + return Clip_Mode + is + Result : constant Interfaces.C.unsigned := fl_group_get_clip_children (This.Void_Ptr); begin - return Clip_Mode'Val (fl_group_get_clip_children (This.Void_Ptr)); + return Clip_Mode'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Group::clip_children returned unexpected unsigned int value of " & + Interfaces.C.unsigned'Image (Result); end Get_Clip_Mode; @@ -489,6 +518,8 @@ package body FLTK.Widgets.Groups is + -- Dimensions -- + procedure Add_Resizable (This : in out Group; Item : in out Widget'Class) is @@ -511,7 +542,8 @@ package body FLTK.Widgets.Groups is end if; return Actual_Widget; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Group::resizable returned Widget with no user_data reference back to Ada"; end Get_Resizable; @@ -545,6 +577,8 @@ package body FLTK.Widgets.Groups is + -- Current -- + function Get_Current return access Group'Class is @@ -558,7 +592,8 @@ package body FLTK.Widgets.Groups is end if; return Actual_Group; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Group::current returned Widget with no user_data reference back to Ada"; end Get_Current; @@ -585,6 +620,8 @@ package body FLTK.Widgets.Groups is + -- Drawing, Events -- + procedure Draw (This : in out Group) is begin |