diff options
Diffstat (limited to 'body/fltk-widgets-groups-browsers.adb')
| -rw-r--r-- | body/fltk-widgets-groups-browsers.adb | 153 |
1 files changed, 71 insertions, 82 deletions
diff --git a/body/fltk-widgets-groups-browsers.adb b/body/fltk-widgets-groups-browsers.adb index 36b9f2f..13cdba7 100644 --- a/body/fltk-widgets-groups-browsers.adb +++ b/body/fltk-widgets-groups-browsers.adb @@ -7,7 +7,7 @@ with Ada.Assertions, - Interfaces.C.Strings, + Interfaces.C, System.Address_To_Access_Conversions; @@ -36,6 +36,8 @@ package body FLTK.Widgets.Groups.Browsers is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_abstract_browser (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -51,6 +53,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Attributes -- + function fl_abstract_browser_hscrollbar (B : in Storage.Integer_Address) return Storage.Integer_Address; @@ -66,6 +70,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Items -- + function fl_abstract_browser_select (B, I : in Storage.Integer_Address; V, C : in Interfaces.C.int) @@ -126,6 +132,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Scrollbar Settings -- + function fl_abstract_browser_get_has_scrollbar (B : in Storage.Integer_Address) return Interfaces.C.unsigned_char; @@ -191,6 +199,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Text Settings -- + function fl_abstract_browser_get_textcolor (B : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -230,6 +240,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Dimensions, Redrawing -- + procedure fl_abstract_browser_resize (B : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int); @@ -261,6 +273,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Optional Overrides -- + function fl_abstract_browser_full_width (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -289,6 +303,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Cache Invalidation -- + procedure fl_abstract_browser_new_list (B : in Storage.Integer_Address); pragma Import (C, fl_abstract_browser_new_list, "fl_abstract_browser_new_list"); @@ -317,6 +333,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Drawing, Events -- + procedure fl_abstract_browser_draw (B : in Storage.Integer_Address); pragma Import (C, fl_abstract_browser_draw, "fl_abstract_browser_draw"); @@ -348,7 +366,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Full_List_Width); @@ -364,7 +382,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Full_List_Height); @@ -380,7 +398,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Average_Item_Height); @@ -396,7 +414,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Item_Quick_Height (Address_To_Cursor (Item_Ptr))); @@ -412,7 +430,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Item_Width (Address_To_Cursor (Item_Ptr))); @@ -428,7 +446,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Item_Height (Address_To_Cursor (Item_Ptr))); @@ -444,7 +462,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Cursor_To_Address (Ada_Object.Item_First); @@ -460,7 +478,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Cursor_To_Address (Ada_Object.Item_Last); @@ -476,7 +494,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Cursor_To_Address (Ada_Object.Item_Next (Address_To_Cursor (Item_Ptr))); @@ -492,7 +510,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Cursor_To_Address (Ada_Object.Item_Previous (Address_To_Cursor (Item_Ptr))); @@ -510,7 +528,7 @@ package body FLTK.Widgets.Groups.Browsers is Index : in Interfaces.C.int) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); use type Interfaces.C.int; begin @@ -527,7 +545,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address; Int_State : in Interfaces.C.int) is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); use type Interfaces.C.int; begin @@ -546,7 +564,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Boolean'Pos (Ada_Object.Item_Selected (Address_To_Cursor (Item_Ptr))); @@ -560,7 +578,7 @@ package body FLTK.Widgets.Groups.Browsers is procedure Item_Swap_Hook (Ada_Addr, A_Ptr, B_Ptr : in Storage.Integer_Address) is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin Ada_Object.Item_Swap (Address_To_Cursor (A_Ptr), Address_To_Cursor (B_Ptr)); @@ -588,13 +606,13 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin Interfaces.C.Strings.Free (Ada_Object.Text_Store (Ada_Object.Current)); Ada_Object.Text_Store (Ada_Object.Current) := Interfaces.C.Strings.New_String (Ada_Object.Item_Text (Address_To_Cursor (Item_Ptr))); - return C_Char_Is_Not_A_String : Interfaces.C.Strings.chars_ptr := + return C_Char_Is_Not_A_String : constant Interfaces.C.Strings.chars_ptr := Ada_Object.Text_Store (Ada_Object.Current) do Ada_Object.Current := Ada_Object.Current + 1; @@ -614,7 +632,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int) is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin Ada_Object.Item_Draw @@ -632,18 +650,9 @@ package body FLTK.Widgets.Groups.Browsers is -- Destructors -- ------------------- - -- Preparing to use morse code - 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 Browser) 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)); for Index in This.Text_Store'Range loop Interfaces.C.Strings.Free (This.Text_Store (Index)); @@ -756,7 +765,7 @@ package body FLTK.Widgets.Groups.Browsers is -- API Subprograms -- ----------------------- - -- Access to the Browser's self contained scrollbars + -- Attributes -- function H_Bar (This : in out Browser) @@ -776,7 +785,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Item related settings + -- Items -- function Set_Select (This : in out Browser; @@ -785,7 +794,7 @@ package body FLTK.Widgets.Groups.Browsers is Do_Callbacks : in Boolean := False) return Boolean is - Code : Interfaces.C.int := fl_abstract_browser_select + Code : constant Interfaces.C.int := fl_abstract_browser_select (This.Void_Ptr, Cursor_To_Address (Item), Boolean'Pos (State), @@ -794,7 +803,8 @@ package body FLTK.Widgets.Groups.Browsers is pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select returned unexpected int value of " & Interfaces.C.int'Image (Code); end Set_Select; @@ -804,7 +814,7 @@ package body FLTK.Widgets.Groups.Browsers is State : in Boolean := True; Do_Callbacks : in Boolean := False) is - Code : Interfaces.C.int := fl_abstract_browser_select + Code : constant Interfaces.C.int := fl_abstract_browser_select (This.Void_Ptr, Cursor_To_Address (Item), Boolean'Pos (State), @@ -812,7 +822,8 @@ package body FLTK.Widgets.Groups.Browsers is begin pragma Assert (Code in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select returned unexpected int value of " & Interfaces.C.int'Image (Code); end Set_Select; @@ -822,7 +833,7 @@ package body FLTK.Widgets.Groups.Browsers is Do_Callbacks : in Boolean := False) return Boolean is - Code : Interfaces.C.int := fl_abstract_browser_select_only + Code : constant Interfaces.C.int := fl_abstract_browser_select_only (This.Void_Ptr, Cursor_To_Address (Item), Boolean'Pos (Do_Callbacks)); @@ -830,7 +841,9 @@ package body FLTK.Widgets.Groups.Browsers is pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select_only returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Select_Only; @@ -839,14 +852,16 @@ package body FLTK.Widgets.Groups.Browsers is Item : in Item_Cursor; Do_Callbacks : in Boolean := False) is - Code : Interfaces.C.int := fl_abstract_browser_select_only + Code : constant Interfaces.C.int := fl_abstract_browser_select_only (This.Void_Ptr, Cursor_To_Address (Item), Boolean'Pos (Do_Callbacks)); begin pragma Assert (Code in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select_only returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Select_Only; @@ -863,14 +878,16 @@ package body FLTK.Widgets.Groups.Browsers is Do_Callbacks : in Boolean := False) return Boolean is - Code : Interfaces.C.int := fl_abstract_browser_deselect + Code : constant Interfaces.C.int := fl_abstract_browser_deselect (This.Void_Ptr, Boolean'Pos (Do_Callbacks)); begin pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::deselect returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Deselect; @@ -878,13 +895,15 @@ package body FLTK.Widgets.Groups.Browsers is (This : in out Browser; Do_Callbacks : in Boolean := False) is - Code : Interfaces.C.int := fl_abstract_browser_deselect + Code : constant Interfaces.C.int := fl_abstract_browser_deselect (This.Void_Ptr, Boolean'Pos (Do_Callbacks)); begin pragma Assert (Code in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::deselect returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Deselect; @@ -901,13 +920,15 @@ package body FLTK.Widgets.Groups.Browsers is Item : in Item_Cursor) return Boolean is - Code : Interfaces.C.int := fl_abstract_browser_displayed + Code : constant Interfaces.C.int := fl_abstract_browser_displayed (This.Void_Ptr, Cursor_To_Address (Item)); begin pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::displayed returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Is_Displayed; @@ -934,7 +955,7 @@ package body FLTK.Widgets.Groups.Browsers is (This : in out Browser; Order : in Sort_Order) is - Code : Interfaces.C.int := + Code : constant Interfaces.C.int := (case Order is when Ascending => fl_sort_ascending, when Descending => fl_sort_descending); @@ -945,7 +966,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Scrollbar related settings + -- Scrollbar Settings -- function Get_Scrollbar_Mode (This : in Browser) @@ -1033,7 +1054,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Text related settings + -- Text Settings -- function Get_Text_Color (This : in Browser) @@ -1085,7 +1106,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Graphical dimensions and redrawing + -- Dimensions, Redrawing -- procedure Resize (This : in out Browser; @@ -1138,7 +1159,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Optional Override API + -- Optional Overrides -- function Full_List_Width (This : in Browser) @@ -1201,7 +1222,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Mandatory Override API + -- Mandatory Overrides -- function Item_Width (This : in Browser; @@ -1299,7 +1320,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Cache invalidation + -- Cache Invalidation -- procedure New_List (This : in out Browser) is @@ -1351,38 +1372,6 @@ package body FLTK.Widgets.Groups.Browsers is end Swapping; - - - -- Standard Override API - - procedure Draw - (This : in out Browser) - is - procedure my_draw - (V : in Storage.Integer_Address); - for my_draw'Address use This.Draw_Ptr; - pragma Import (Ada, my_draw); - begin - my_draw (This.Void_Ptr); - end Draw; - - - function Handle - (This : in out Browser; - Event : in Event_Kind) - return Event_Outcome - is - function my_handle - (V : in Storage.Integer_Address; - E : in Interfaces.C.int) - return Interfaces.C.int; - for my_handle'Address use This.Handle_Ptr; - pragma Import (Ada, my_handle); - begin - return Event_Outcome'Val (my_handle (This.Void_Ptr, Event_Kind'Pos (Event))); - end Handle; - - end FLTK.Widgets.Groups.Browsers; |