diff options
Diffstat (limited to 'body/fltk-widgets-menus.adb')
| -rw-r--r-- | body/fltk-widgets-menus.adb | 148 |
1 files changed, 96 insertions, 52 deletions
diff --git a/body/fltk-widgets-menus.adb b/body/fltk-widgets-menus.adb index 034cd4c..1295d76 100644 --- a/body/fltk-widgets-menus.adb +++ b/body/fltk-widgets-menus.adb @@ -32,6 +32,8 @@ package body FLTK.Widgets.Menus is -- Functions From C -- ------------------------ + -- Allocation -- + function null_fl_menu_item return Storage.Integer_Address; pragma Import (C, null_fl_menu_item, "null_fl_menu_item"); @@ -57,6 +59,8 @@ package body FLTK.Widgets.Menus is + -- Menu Items -- + function fl_menu_add (M : in Storage.Integer_Address; T : in Interfaces.C.char_array) @@ -135,6 +139,8 @@ package body FLTK.Widgets.Menus is + -- Item Query -- + function fl_menu_get_item (M : in Storage.Integer_Address; I : in Interfaces.C.int) @@ -179,6 +185,8 @@ package body FLTK.Widgets.Menus is + -- Selection -- + function fl_menu_text (M : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -207,6 +215,8 @@ package body FLTK.Widgets.Menus is + -- Label, Shortcut, Flags -- + procedure fl_menu_setonly (M, I : in Storage.Integer_Address); pragma Import (C, fl_menu_setonly, "fl_menu_setonly"); @@ -250,6 +260,8 @@ package body FLTK.Widgets.Menus is + -- Text Settings -- + function fl_menu_get_textcolor (M : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -289,6 +301,8 @@ package body FLTK.Widgets.Menus is + -- Miscellaneous -- + function fl_menu_get_down_box (M : in Storage.Integer_Address) return Interfaces.C.int; @@ -317,6 +331,8 @@ package body FLTK.Widgets.Menus is + -- Menu Item Methods -- + function fl_menu_popup (M : in Storage.Integer_Address; X, Y : in Interfaces.C.int; @@ -356,6 +372,8 @@ package body FLTK.Widgets.Menus is + -- Dimensions -- + procedure fl_menu_size2 (M : in Storage.Integer_Address; W, H : in Interfaces.C.int); @@ -365,6 +383,8 @@ package body FLTK.Widgets.Menus is + -- Drawing, Events -- + procedure fl_menu_draw_item (M : in Storage.Integer_Address; I : in Interfaces.C.int; @@ -395,7 +415,7 @@ package body FLTK.Widgets.Menus is procedure Adjust_Item_Store (This : in out Menu) is - Target : Natural := This.Number_Of_Items; + Target : constant Natural := This.Number_Of_Items; begin while Natural (This.My_Items.Length) > Target loop Free_Item (This.My_Items.Reference (This.My_Items.Last_Index)); @@ -426,9 +446,9 @@ package body FLTK.Widgets.Menus is procedure Item_Hook (C_Obj, User_Data : in Storage.Integer_Address) is - Ada_Ptr : Storage.Integer_Address := fl_widget_get_user_data (C_Obj); + Ada_Ptr : constant Storage.Integer_Address := fl_widget_get_user_data (C_Obj); Ada_Widget : access Widget'Class; - Action : Widget_Callback := Callback_Convert.To_Access (User_Data); + Action : constant Widget_Callback := Callback_Convert.To_Access (User_Data); begin pragma Assert (Ada_Ptr /= Null_Pointer); Ada_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Ada_Ptr)); @@ -542,11 +562,13 @@ package body FLTK.Widgets.Menus is -- API Subprograms -- ----------------------- + -- Menu Items -- + procedure Add (This : in out Menu; Text : in String) is - Added_Spot : Interfaces.C.int := fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); + Ignore : constant Interfaces.C.int := fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); begin This.Adjust_Item_Store; end Add; @@ -557,7 +579,8 @@ package body FLTK.Widgets.Menus is Text : in String) return Index is - Added_Spot : Interfaces.C.int := fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); + Added_Spot : constant Interfaces.C.int := + fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -571,12 +594,12 @@ package body FLTK.Widgets.Menus is Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_menu_add2 + Ignore : constant Interfaces.C.int := fl_menu_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Add; @@ -590,12 +613,12 @@ package body FLTK.Widgets.Menus is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_menu_add2 + Added_Spot : constant Interfaces.C.int := fl_menu_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -609,12 +632,12 @@ package body FLTK.Widgets.Menus is Shortcut : in String; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_menu_add3 + Ignore : constant Interfaces.C.int := fl_menu_add3 (This.Void_Ptr, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Add; @@ -628,12 +651,12 @@ package body FLTK.Widgets.Menus is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_menu_add3 + Added_Spot : constant Interfaces.C.int := fl_menu_add3 (This.Void_Ptr, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -648,13 +671,13 @@ package body FLTK.Widgets.Menus is Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_menu_insert + Ignore : constant Interfaces.C.int := fl_menu_insert (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Insert; @@ -669,13 +692,13 @@ package body FLTK.Widgets.Menus is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_menu_insert + Added_Spot : constant Interfaces.C.int := fl_menu_insert (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -690,13 +713,13 @@ package body FLTK.Widgets.Menus is Shortcut : in String; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_menu_insert2 + Ignore : constant Interfaces.C.int := fl_menu_insert2 (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Insert; @@ -711,13 +734,13 @@ package body FLTK.Widgets.Menus is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_menu_insert2 + Added_Spot : constant Interfaces.C.int := fl_menu_insert2 (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -728,7 +751,8 @@ package body FLTK.Widgets.Menus is (This : in out Menu; Items : in FLTK.Menu_Items.Menu_Item_Array) is - Pointers : aliased array (Items'First .. Items'Last + 1) of Storage.Integer_Address; + Pointers : aliased array + (Items'First .. Integer'Max (Items'First, Items'Last + 1)) of Storage.Integer_Address; pragma Convention (C, Pointers); begin for Place in Pointers'First .. Pointers'Last - 1 loop @@ -774,7 +798,7 @@ package body FLTK.Widgets.Menus is (This : in out Menu; Place : in Index) is - Result : Interfaces.C.int := fl_menu_clear_submenu + Result : constant Interfaces.C.int := fl_menu_clear_submenu (This.Void_Ptr, Interfaces.C.int (Place) - 1); begin @@ -793,6 +817,8 @@ package body FLTK.Widgets.Menus is + -- Item Query -- + function Has_Item (This : in Menu; Place : in Index) @@ -842,7 +868,7 @@ package body FLTK.Widgets.Menus is Name : in String) return FLTK.Menu_Items.Menu_Item_Reference is - Place : Extended_Index := This.Find_Index (Name); + Place : constant Extended_Index := This.Find_Index (Name); begin if Place = No_Index then raise No_Reference_Error; @@ -856,7 +882,7 @@ package body FLTK.Widgets.Menus is Action : in Widget_Callback) return FLTK.Menu_Items.Menu_Item_Reference is - Place : Extended_Index := This.Find_Index (Action); + Place : constant Extended_Index := This.Find_Index (Action); begin if Place = No_Index then raise No_Reference_Error; @@ -870,7 +896,8 @@ package body FLTK.Widgets.Menus is Name : in String) return Extended_Index is - Result : Interfaces.C.int := fl_menu_find_index (This.Void_Ptr, Interfaces.C.To_C (Name)); + Result : constant Interfaces.C.int := + fl_menu_find_index (This.Void_Ptr, Interfaces.C.To_C (Name)); begin return Extended_Index (Result + 1); end Find_Index; @@ -881,7 +908,8 @@ package body FLTK.Widgets.Menus is Item : in FLTK.Menu_Items.Menu_Item) return Extended_Index is - Result : Interfaces.C.int := fl_menu_find_index2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); + Result : constant Interfaces.C.int := + fl_menu_find_index2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); begin return Extended_Index (Result + 1); end Find_Index; @@ -907,7 +935,7 @@ package body FLTK.Widgets.Menus is is Buffer : Interfaces.C.char_array := (0 .. Interfaces.C.size_t (Item_Path_Max) => Interfaces.C.nul); - Result : Interfaces.C.int := fl_menu_item_pathname + Result : constant Interfaces.C.int := fl_menu_item_pathname (This.Void_Ptr, Buffer, Interfaces.C.int (Item_Path_Max), @@ -935,7 +963,7 @@ package body FLTK.Widgets.Menus is is Buffer : Interfaces.C.char_array := (0 .. Interfaces.C.size_t (Item_Path_Max) => Interfaces.C.nul); - Result : Interfaces.C.int := fl_menu_item_pathname + Result : constant Interfaces.C.int := fl_menu_item_pathname (This.Void_Ptr, Buffer, Interfaces.C.int (Item_Path_Max), @@ -969,11 +997,13 @@ package body FLTK.Widgets.Menus is + -- Iteration -- + function Iterate (This : in Menu) return Menu_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; @@ -981,7 +1011,7 @@ package body FLTK.Widgets.Menus 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; @@ -992,7 +1022,7 @@ package body FLTK.Widgets.Menus is Place : in Cursor) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Place.My_Container, My_Index => Place.My_Index + 1); end Next; @@ -1002,7 +1032,7 @@ package body FLTK.Widgets.Menus 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_Items); end Last; @@ -1013,7 +1043,7 @@ package body FLTK.Widgets.Menus is Place : in Cursor) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Place.My_Container, My_Index => Place.My_Index - 1); end Previous; @@ -1021,11 +1051,13 @@ package body FLTK.Widgets.Menus is + -- Selection -- + function Chosen (This : in Menu) return FLTK.Menu_Items.Menu_Item_Reference is - Place : Extended_Index := This.Chosen_Index; + Place : constant Extended_Index := This.Chosen_Index; begin if Place = No_Index then raise No_Reference_Error; @@ -1038,7 +1070,7 @@ package body FLTK.Widgets.Menus is (This : in Menu) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_menu_text (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_menu_text (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1102,6 +1134,8 @@ package body FLTK.Widgets.Menus is + -- Label, Shortcut, Flags -- + procedure Set_Only (This : in out Menu; Item : in out FLTK.Menu_Items.Menu_Item) is @@ -1115,7 +1149,7 @@ package body FLTK.Widgets.Menus is Place : in Index) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_menu_text2 + Result : constant Interfaces.C.Strings.chars_ptr := fl_menu_text2 (This.Void_Ptr, Interfaces.C.int (Place) - 1); begin @@ -1147,7 +1181,7 @@ package body FLTK.Widgets.Menus is fl_menu_shortcut (This.Void_Ptr, Interfaces.C.int (Place) - 1, - To_C (Press)); + Interfaces.C.int (To_C (Press))); end Set_Shortcut; @@ -1156,7 +1190,7 @@ package body FLTK.Widgets.Menus is Place : in Index) return Menu_Flag is begin - return Menu_Flag (fl_menu_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1)); + return Cint_To_MFlag (fl_menu_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1)); end Get_Flags; @@ -1168,12 +1202,14 @@ package body FLTK.Widgets.Menus is fl_menu_set_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1, - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); end Set_Flags; + -- Text Settings -- + function Get_Text_Color (This : in Menu) return Color is @@ -1194,7 +1230,7 @@ package body FLTK.Widgets.Menus is (This : in Menu) return Font_Kind is - Result : Interfaces.C.int := fl_menu_get_textfont (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_menu_get_textfont (This.Void_Ptr); begin return Font_Kind'Val (Result); exception @@ -1216,7 +1252,7 @@ package body FLTK.Widgets.Menus is (This : in Menu) return Font_Size is - Result : Interfaces.C.int := fl_menu_get_textsize (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_menu_get_textsize (This.Void_Ptr); begin return Font_Size (Result); exception @@ -1236,11 +1272,13 @@ package body FLTK.Widgets.Menus is + -- Miscellaneous -- + function Get_Down_Box (This : in Menu) return Box_Kind is - Result : Interfaces.C.int := fl_menu_get_down_box (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_menu_get_down_box (This.Void_Ptr); begin return Box_Kind'Val (Result); exception @@ -1279,6 +1317,8 @@ package body FLTK.Widgets.Menus is + -- Menu Item Methods -- + function Popup (This : in Menu; X, Y : in Integer; @@ -1287,7 +1327,7 @@ package body FLTK.Widgets.Menus is return Extended_Index is C_Title : aliased Interfaces.C.char_array := Interfaces.C.To_C (Title); - Ptr : Storage.Integer_Address := fl_menu_popup + Ptr : constant Storage.Integer_Address := fl_menu_popup (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y), @@ -1306,7 +1346,7 @@ package body FLTK.Widgets.Menus is Initial : in Extended_Index := No_Index) return Extended_Index is - Ptr : Storage.Integer_Address := fl_menu_pulldown + Ptr : constant Storage.Integer_Address := fl_menu_pulldown (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y), @@ -1335,7 +1375,7 @@ package body FLTK.Widgets.Menus is Require_Alt : in Boolean := False) return access FLTK.Menu_Items.Menu_Item'Class is - Tentative_Result : Storage.Integer_Address := fl_menu_find_shortcut + Tentative_Result : constant Storage.Integer_Address := fl_menu_find_shortcut (This.Void_Ptr, Null_Pointer, Boolean'Pos (Require_Alt)); @@ -1356,7 +1396,7 @@ package body FLTK.Widgets.Menus is return access FLTK.Menu_Items.Menu_Item'Class is C_Place : Interfaces.C.int; - Tentative_Result : Storage.Integer_Address := fl_menu_find_shortcut + Tentative_Result : constant Storage.Integer_Address := fl_menu_find_shortcut (This.Void_Ptr, Storage.To_Integer (C_Place'Address), Boolean'Pos (Require_Alt)); @@ -1376,7 +1416,7 @@ package body FLTK.Widgets.Menus is (This : in out Menu) return access FLTK.Menu_Items.Menu_Item'Class is - Tentative_Pick : Storage.Integer_Address := fl_menu_test_shortcut (This.Void_Ptr); + Tentative_Pick : constant Storage.Integer_Address := fl_menu_test_shortcut (This.Void_Ptr); begin if Tentative_Pick = Null_Pointer then return null; @@ -1389,6 +1429,8 @@ package body FLTK.Widgets.Menus is + -- Dimensions -- + procedure Resize (This : in out Menu; W, H : in Integer) is @@ -1402,6 +1444,8 @@ package body FLTK.Widgets.Menus is + -- Drawing -- + procedure Draw_Item (This : in out Menu; Item : in Index; |