diff options
Diffstat (limited to 'body/fltk-widgets.adb')
| -rw-r--r-- | body/fltk-widgets.adb | 557 |
1 files changed, 484 insertions, 73 deletions
diff --git a/body/fltk-widgets.adb b/body/fltk-widgets.adb index a312641..f4409e4 100644 --- a/body/fltk-widgets.adb +++ b/body/fltk-widgets.adb @@ -8,14 +8,13 @@ with Ada.Assertions, Interfaces.C.Strings, - System.Address_To_Access_Conversions, - FLTK.Widgets.Groups.Windows, - FLTK.Images; + FLTK.Widgets.Groups.Windows; use type Interfaces.C.int, Interfaces.C.unsigned, + Interfaces.C.unsigned_char, Interfaces.C.Strings.chars_ptr; @@ -25,14 +24,6 @@ package body FLTK.Widgets is package Chk renames Ada.Assertions; - function "+" - (Left, Right : in Callback_Flag) - return Callback_Flag is - begin - return Left or Right; - end "+"; - - package Group_Convert is new System.Address_To_Access_Conversions (FLTK.Widgets.Groups.Group'Class); @@ -46,6 +37,8 @@ package body FLTK.Widgets is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_widget (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -61,6 +54,8 @@ package body FLTK.Widgets is + -- Activity -- + procedure fl_widget_activate (W : in Storage.Integer_Address); pragma Import (C, fl_widget_activate, "fl_widget_activate"); @@ -96,6 +91,8 @@ package body FLTK.Widgets is + -- Changed and Output -- + function fl_widget_changed (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -128,6 +125,11 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_clear_output, "fl_widget_clear_output"); pragma Inline (fl_widget_clear_output); + + + + -- Visibility -- + function fl_widget_visible (W : in Storage.Integer_Address) return Interfaces.C.int; @@ -150,21 +152,43 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_clear_visible, "fl_widget_clear_visible"); pragma Inline (fl_widget_clear_visible); + procedure fl_widget_show + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_show, "fl_widget_show"); + pragma Inline (fl_widget_show); + + procedure fl_widget_hide + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_hide, "fl_widget_hide"); + pragma Inline (fl_widget_hide); + + -- Focus -- + function fl_widget_get_visible_focus (W : in Storage.Integer_Address) return Interfaces.C.int; pragma Import (C, fl_widget_get_visible_focus, "fl_widget_get_visible_focus"); pragma Inline (fl_widget_get_visible_focus); + procedure fl_widget_set_visible_focus2 + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_visible_focus2, "fl_widget_set_visible_focus2"); + pragma Inline (fl_widget_set_visible_focus2); + procedure fl_widget_set_visible_focus (W : in Storage.Integer_Address; T : in Interfaces.C.int); pragma Import (C, fl_widget_set_visible_focus, "fl_widget_set_visible_focus"); pragma Inline (fl_widget_set_visible_focus); + procedure fl_widget_clear_visible_focus + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_clear_visible_focus, "fl_widget_clear_visible_focus"); + pragma Inline (fl_widget_clear_visible_focus); + function fl_widget_take_focus (W : in Storage.Integer_Address) return Interfaces.C.int; @@ -180,6 +204,8 @@ package body FLTK.Widgets is + -- Colors -- + function fl_widget_get_color (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -204,9 +230,17 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_set_selection_color, "fl_widget_set_selection_color"); pragma Inline (fl_widget_set_selection_color); + procedure fl_widget_set_colors + (W : in Storage.Integer_Address; + B, S : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_set_colors, "fl_widget_set_colors"); + pragma Inline (fl_widget_set_colors); + + -- Relatives -- + function fl_widget_get_parent (W : in Storage.Integer_Address) return Storage.Integer_Address; @@ -247,6 +281,8 @@ package body FLTK.Widgets is + -- Alignment, Box, Tooltip -- + function fl_widget_get_align (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -286,6 +322,8 @@ package body FLTK.Widgets is + -- Labels -- + function fl_widget_get_label (W : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -349,26 +387,35 @@ package body FLTK.Widgets is + -- Callbacks -- + procedure fl_widget_set_callback (W, C : in Storage.Integer_Address); pragma Import (C, fl_widget_set_callback, "fl_widget_set_callback"); pragma Inline (fl_widget_set_callback); + procedure fl_widget_default_callback + (W, U : in Storage.Integer_Address); + pragma Import (C, fl_widget_default_callback, "fl_widget_default_callback"); + pragma Inline (fl_widget_default_callback); + function fl_widget_get_when (W : in Storage.Integer_Address) - return Interfaces.C.unsigned; + return Interfaces.C.unsigned_char; pragma Import (C, fl_widget_get_when, "fl_widget_get_when"); pragma Inline (fl_widget_get_when); procedure fl_widget_set_when (W : in Storage.Integer_Address; - T : in Interfaces.C.unsigned); + T : in Interfaces.C.unsigned_char); pragma Import (C, fl_widget_set_when, "fl_widget_set_when"); pragma Inline (fl_widget_set_when); + -- Dimensions -- + function fl_widget_get_x (W : in Storage.Integer_Address) return Interfaces.C.int; @@ -399,6 +446,12 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_size, "fl_widget_size"); pragma Inline (fl_widget_size); + procedure fl_widget_resize + (O : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_widget_resize, "fl_widget_resize"); + pragma Inline (fl_widget_resize); + procedure fl_widget_position (W : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -408,6 +461,8 @@ package body FLTK.Widgets is + -- Images -- + procedure fl_widget_set_image (W, I : in Storage.Integer_Address); pragma Import (C, fl_widget_set_image, "fl_widget_set_image"); @@ -421,31 +476,90 @@ package body FLTK.Widgets is + -- Damage, Drawing, Events -- + function fl_widget_damage (W : in Storage.Integer_Address) - return Interfaces.C.int; + return Interfaces.C.unsigned_char; pragma Import (C, fl_widget_damage, "fl_widget_damage"); pragma Inline (fl_widget_damage); procedure fl_widget_set_damage (W : in Storage.Integer_Address; - T : in Interfaces.C.int); + M : in Interfaces.C.unsigned_char); pragma Import (C, fl_widget_set_damage, "fl_widget_set_damage"); pragma Inline (fl_widget_set_damage); procedure fl_widget_set_damage2 - (W : in Storage.Integer_Address; - T : in Interfaces.C.int; + (W : in Storage.Integer_Address; + M : in Interfaces.C.unsigned_char; X, Y, D, H : in Interfaces.C.int); pragma Import (C, fl_widget_set_damage2, "fl_widget_set_damage2"); pragma Inline (fl_widget_set_damage2); + procedure fl_widget_clear_damage + (W : in Storage.Integer_Address; + M : in Interfaces.C.unsigned_char); + pragma Import (C, fl_widget_clear_damage, "fl_widget_clear_damage"); + pragma Inline (fl_widget_clear_damage); + + procedure fl_widget_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw, "fl_widget_draw"); + pragma Inline (fl_widget_draw); + procedure fl_widget_draw_label + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_label, "fl_widget_draw_label"); + pragma Inline (fl_widget_draw_label); + + procedure fl_widget_draw_label2 + (O : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_widget_draw_label2, "fl_widget_draw_label2"); + pragma Inline (fl_widget_draw_label2); + + procedure fl_widget_draw_label3 (W : in Storage.Integer_Address; X, Y, D, H : in Interfaces.C.int; A : in Interfaces.C.unsigned); - pragma Import (C, fl_widget_draw_label, "fl_widget_draw_label"); - pragma Inline (fl_widget_draw_label); + pragma Import (C, fl_widget_draw_label3, "fl_widget_draw_label3"); + pragma Inline (fl_widget_draw_label3); + + procedure fl_widget_draw_backdrop + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_backdrop, "fl_widget_draw_backdrop"); + pragma Inline (fl_widget_draw_backdrop); + + procedure fl_widget_draw_box + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_box, "fl_widget_draw_box"); + pragma Inline (fl_widget_draw_box); + + procedure fl_widget_draw_box2 + (W : in Storage.Integer_Address; + K : in Interfaces.C.int; + H : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_draw_box2, "fl_widget_draw_box2"); + pragma Inline (fl_widget_draw_box2); + + procedure fl_widget_draw_box3 + (O : in Storage.Integer_Address; + K, X, Y, W, H : in Interfaces.C.int; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_draw_box3, "fl_widget_draw_box3"); + pragma Inline (fl_widget_draw_box3); + + procedure fl_widget_draw_focus + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_focus, "fl_widget_draw_focus"); + pragma Inline (fl_widget_draw_focus); + + procedure fl_widget_draw_focus2 + (O : in Storage.Integer_Address; + K, X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_widget_draw_focus2, "fl_widget_draw_focus2"); + pragma Inline (fl_widget_draw_focus2); procedure fl_widget_redraw (W : in Storage.Integer_Address); @@ -457,14 +571,6 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_redraw_label, "fl_widget_redraw_label"); pragma Inline (fl_widget_redraw_label); - - - - procedure fl_widget_draw - (W : in Storage.Integer_Address); - pragma Import (C, fl_widget_draw, "fl_widget_draw"); - pragma Inline (fl_widget_draw); - function fl_widget_handle (W : in Storage.Integer_Address; E : in Interfaces.C.int) @@ -475,6 +581,17 @@ package body FLTK.Widgets is + -- Miscellaneous -- + + function fl_widget_use_accents_menu + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_use_accents_menu, "fl_widget_use_accents_menu"); + pragma Inline (fl_widget_use_accents_menu); + + + + ---------------------- -- Exported Hooks -- ---------------------- @@ -482,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); @@ -492,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; @@ -504,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))); @@ -520,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; @@ -574,11 +694,11 @@ package body FLTK.Widgets is begin return This : Widget do This.Void_Ptr := new_fl_widget - (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; @@ -604,6 +724,8 @@ package body FLTK.Widgets is -- API Subprograms -- ----------------------- + -- Activity -- + procedure Activate (This : in out Widget) is begin @@ -635,6 +757,13 @@ package body FLTK.Widgets is procedure Set_Active + (This : in out Widget) is + begin + fl_widget_set_active (This.Void_Ptr); + end Set_Active; + + + procedure Set_Active (This : in out Widget; To : in Boolean) is begin @@ -646,8 +775,17 @@ package body FLTK.Widgets is end Set_Active; + procedure Clear_Active + (This : in out Widget) is + begin + fl_widget_clear_active (This.Void_Ptr); + end Clear_Active; + + + -- Changed and Output -- + function Has_Changed (This : in Widget) return Boolean is @@ -657,6 +795,13 @@ package body FLTK.Widgets is procedure Set_Changed + (This : in out Widget) is + begin + fl_widget_set_changed (This.Void_Ptr); + end Set_Changed; + + + procedure Set_Changed (This : in out Widget; To : in Boolean) is begin @@ -668,6 +813,13 @@ package body FLTK.Widgets is end Set_Changed; + procedure Clear_Changed + (This : in out Widget) is + begin + fl_widget_clear_changed (This.Void_Ptr); + end Clear_Changed; + + function Is_Output_Only (This : in Widget) return Boolean is @@ -677,6 +829,13 @@ package body FLTK.Widgets is procedure Set_Output_Only + (This : in out Widget) is + begin + fl_widget_set_output (This.Void_Ptr); + end Set_Output_Only; + + + procedure Set_Output_Only (This : in out Widget; To : in Boolean) is begin @@ -688,6 +847,17 @@ package body FLTK.Widgets is end Set_Output_Only; + procedure Clear_Output_Only + (This : in out Widget) is + begin + fl_widget_clear_output (This.Void_Ptr); + end Clear_Output_Only; + + + + + -- Visibility -- + function Is_Visible (This : in Widget) return Boolean is @@ -705,6 +875,13 @@ package body FLTK.Widgets is procedure Set_Visible + (This : in out Widget) is + begin + fl_widget_set_visible (This.Void_Ptr); + end Set_Visible; + + + procedure Set_Visible (This : in out Widget; To : in Boolean) is begin @@ -716,7 +893,30 @@ package body FLTK.Widgets is end Set_Visible; + procedure Clear_Visible + (This : in out Widget) is + begin + fl_widget_clear_visible (This.Void_Ptr); + end Clear_Visible; + + + procedure Show + (This : in out Widget) is + begin + fl_widget_show (This.Void_Ptr); + end Show; + + + procedure Hide + (This : in out Widget) is + begin + fl_widget_hide (This.Void_Ptr); + end Hide; + + + + -- Focus -- function Has_Visible_Focus (This : in Widget) @@ -727,6 +927,13 @@ package body FLTK.Widgets is procedure Set_Visible_Focus + (This : in out Widget) is + begin + fl_widget_set_visible_focus2 (This.Void_Ptr); + end Set_Visible_Focus; + + + procedure Set_Visible_Focus (This : in out Widget; To : in Boolean) is begin @@ -734,6 +941,13 @@ package body FLTK.Widgets is end Set_Visible_Focus; + procedure Clear_Visible_Focus + (This : in out Widget) is + begin + fl_widget_clear_visible_focus (This.Void_Ptr); + end Clear_Visible_Focus; + + function Take_Focus (This : in out Widget) return Boolean is @@ -752,6 +966,8 @@ package body FLTK.Widgets is + -- Colors -- + function Get_Background_Color (This : in Widget) return Color is @@ -784,7 +1000,20 @@ package body FLTK.Widgets is end Set_Selection_Color; + procedure Set_Colors + (This : in out Widget; + Back, Sel : in Color) is + begin + fl_widget_set_colors + (This.Void_Ptr, + Interfaces.C.unsigned (Back), + Interfaces.C.unsigned (Sel)); + end Set_Colors; + + + + -- Relatives -- function Parent (This : in Widget) @@ -795,12 +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; end Parent; @@ -836,7 +1066,8 @@ package body FLTK.Widgets is end if; return Actual_Window; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Widget::window has no user_data reference back to Ada"; end Nearest_Window; @@ -854,13 +1085,14 @@ package body FLTK.Widgets is end if; return Actual_Window; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Widget::top_window has no user_data reference back to Ada"; end Top_Window; function Top_Window_Offset - (This : in Widget; - Offset_X, Offset_Y : out Integer) + (This : in Widget; + Offset_X, Offset_Y : out Integer) return access FLTK.Widgets.Groups.Windows.Window'Class is Window_Ptr : Storage.Integer_Address := fl_widget_top_window_offset @@ -876,12 +1108,15 @@ package body FLTK.Widgets is end if; return Actual_Window; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Widget::top_window_offset has no user_data reference back to Ada"; end Top_Window_Offset; + -- Alignment, Box, Tooltip -- + function Get_Alignment (This : in Widget) return Alignment is @@ -900,9 +1135,15 @@ package body FLTK.Widgets is function Get_Box (This : in Widget) - return Box_Kind is + return Box_Kind + is + Result : constant Interfaces.C.int := fl_widget_get_box (This.Void_Ptr); begin - return Box_Kind'Val (fl_widget_get_box (This.Void_Ptr)); + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Widget::box returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Get_Box; @@ -918,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 ""; @@ -939,11 +1180,13 @@ package body FLTK.Widgets is + -- Labels -- + function Get_Label (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 ""; @@ -961,6 +1204,16 @@ package body FLTK.Widgets is end Set_Label; + procedure Set_Label + (This : in out Widget; + Kind : in Label_Kind; + Text : in String) is + begin + This.Set_Label_Kind (Kind); + This.Set_Label (Text); + end Set_Label; + + function Get_Label_Color (This : in Widget) return Color is @@ -1013,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 @@ -1044,6 +1297,8 @@ package body FLTK.Widgets is + -- Callbacks -- + function Get_Callback (This : in Widget) return Widget_Callback is @@ -1072,11 +1327,30 @@ package body FLTK.Widgets is end Do_Callback; + procedure Do_Callback + (This : in Widget; + Using : in out Widget) is + begin + if This.Callback /= null then + This.Callback.all (Using); + end if; + end Do_Callback; + + + procedure Default_Callback + (This : in out Widget'Class) is + begin + fl_widget_default_callback + (This.Void_Ptr, + fl_widget_get_user_data (This.Void_Ptr)); + end Default_Callback; + + function Get_When (This : in Widget) return Callback_Flag is begin - return Callback_Flag (fl_widget_get_when (This.Void_Ptr)); + return UChar_To_Flag (fl_widget_get_when (This.Void_Ptr)); end Get_When; @@ -1084,12 +1358,14 @@ package body FLTK.Widgets is (This : in out Widget; To : in Callback_Flag) is begin - fl_widget_set_when (This.Void_Ptr, Interfaces.C.unsigned (To)); + fl_widget_set_when (This.Void_Ptr, Flag_To_UChar (To)); end Set_When; + -- Dimensions -- + function Get_X (This : in Widget) return Integer is @@ -1127,9 +1403,22 @@ package body FLTK.Widgets is W, H : in Integer) is begin fl_widget_size - (This.Void_Ptr, - Interfaces.C.int (W), - Interfaces.C.int (H)); + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Resize + (This : in out Widget; + X, Y, W, H : in Integer) is + begin + fl_widget_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); end Resize; @@ -1138,14 +1427,16 @@ package body FLTK.Widgets is X, Y : in Integer) is begin fl_widget_position - (This.Void_Ptr, - Interfaces.C.int (X), - Interfaces.C.int (Y)); + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); end Reposition; + -- Images -- + function Get_Image (This : in Widget) return access FLTK.Images.Image'Class is @@ -1186,6 +1477,8 @@ package body FLTK.Widgets is + -- Damage, Drawing, Events -- + function Is_Damaged (This : in Widget) return Boolean is @@ -1194,27 +1487,43 @@ package body FLTK.Widgets is end Is_Damaged; - procedure Set_Damaged + function Get_Damage + (This : in Widget) + return Damage_Mask is + begin + return UChar_To_Mask (fl_widget_damage (This.Void_Ptr)); + end Get_Damage; + + + procedure Set_Damage (This : in out Widget; - To : in Boolean) is + Mask : in Damage_Mask) is begin - fl_widget_set_damage (This.Void_Ptr, Boolean'Pos (To)); - end Set_Damaged; + fl_widget_set_damage (This.Void_Ptr, Mask_To_UChar (Mask)); + end Set_Damage; - procedure Set_Damaged + procedure Set_Damage (This : in out Widget; - To : in Boolean; + Mask : in Damage_Mask; X, Y, W, H : in Integer) is begin fl_widget_set_damage2 (This.Void_Ptr, - Boolean'Pos (To), + Mask_To_UChar (Mask), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H)); - end Set_Damaged; + end Set_Damage; + + + procedure Clear_Damage + (This : in out Widget; + Mask : in Damage_Mask := Damage_None) is + begin + fl_widget_clear_damage (This.Void_Ptr, Mask_To_UChar (Mask)); + end Clear_Damage; procedure Draw @@ -1230,11 +1539,31 @@ package body FLTK.Widgets is procedure Draw_Label - (This : in Widget; - X, Y, W, H : in Integer; - Align : in Alignment) is + (This : in out Widget) is + begin + fl_widget_draw_label (This.Void_Ptr); + end Draw_Label; + + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer) is + begin + fl_widget_draw_label2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Label; + + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer; + Align : in Alignment) is begin - fl_widget_draw_label + fl_widget_draw_label3 (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y), @@ -1244,6 +1573,71 @@ package body FLTK.Widgets is end Draw_Label; + procedure Draw_Backdrop + (This : in out Widget) is + begin + fl_widget_draw_backdrop (This.Void_Ptr); + end Draw_Backdrop; + + + procedure Draw_Box + (This : in out Widget) is + begin + fl_widget_draw_box (This.Void_Ptr); + end Draw_Box; + + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + Hue : in Color) is + begin + fl_widget_draw_box2 + (This.Void_Ptr, + Box_Kind'Pos (Kind), + Interfaces.C.unsigned (Hue)); + end Draw_Box; + + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Hue : in Color) is + begin + fl_widget_draw_box3 + (This.Void_Ptr, + Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Hue)); + end Draw_Box; + + + procedure Draw_Focus + (This : in out Widget) is + begin + fl_widget_draw_focus (This.Void_Ptr); + end Draw_Focus; + + + procedure Draw_Focus + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer) is + begin + fl_widget_draw_focus2 + (This.Void_Ptr, + Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Focus; + + procedure Redraw (This : in out Widget) is begin @@ -1269,12 +1663,29 @@ package body FLTK.Widgets is return Interfaces.C.int; for my_handle'Address use This.Handle_Ptr; pragma Import (Ada, my_handle); + + Result : constant Interfaces.C.int := my_handle (This.Void_Ptr, Event_Kind'Pos (Event)); begin - return Event_Outcome'Val (my_handle (This.Void_Ptr, Event_Kind'Pos (Event))); + return Event_Outcome'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Dispatched handle function returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Handle; + + + -- Miscellaneous -- + + function Uses_Accents_Menu + (This : in Widget) + return Boolean is + begin + return fl_widget_use_accents_menu (This.Void_Ptr) /= 0; + end Uses_Accents_Menu; + + end FLTK.Widgets; + |