diff options
Diffstat (limited to 'body/fltk-static.adb')
| -rw-r--r-- | body/fltk-static.adb | 774 |
1 files changed, 622 insertions, 152 deletions
diff --git a/body/fltk-static.adb b/body/fltk-static.adb index 56b30c0..663a7c7 100644 --- a/body/fltk-static.adb +++ b/body/fltk-static.adb @@ -10,6 +10,8 @@ with Ada.Containers.Vectors, Interfaces.C.Strings, System.Address_To_Access_Conversions, + FLTK.Box_Draw_Marshal, + FLTK.Label_Draw_Marshal, FLTK.Static_Callback_Conversions; use type @@ -27,19 +29,99 @@ package body FLTK.Static is - procedure fl_static_add_awake_handler - (H, F : in Storage.Integer_Address); + ----------------- + -- Operators -- + ----------------- + + type File_Mode_Bitmask is mod 2 ** Interfaces.C.int'Size; + + function FMode_To_Bits is new + Ada.Unchecked_Conversion (File_Mode, File_Mode_Bitmask); + + function Bits_To_FMode is new + Ada.Unchecked_Conversion (File_Mode_Bitmask, File_Mode); + + + function "+" + (Left, Right : in File_Mode) + return File_Mode is + begin + return Bits_To_FMode (FMode_To_Bits (Left) or FMode_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in File_Mode) + return File_Mode is + begin + return Bits_To_FMode (FMode_To_Bits (Left) and not FMode_To_Bits (Right)); + end "-"; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Command Line Arguments -- + + function fl_static_arg + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_static_arg, "fl_static_arg"); + pragma Inline (fl_static_arg); + + procedure fl_static_args + (C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_static_args, "fl_static_args"); + pragma Inline (fl_static_args); + + function fl_static_args2 + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int; + H : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_args2, "fl_static_args2"); + pragma Inline (fl_static_args2); + + + + + -- Thread Notify -- + + function fl_static_add_awake_handler + (H, F : in Storage.Integer_Address) + return Interfaces.C.int; pragma Import (C, fl_static_add_awake_handler, "fl_static_add_awake_handler"); pragma Inline (fl_static_add_awake_handler); - procedure fl_static_get_awake_handler - (H, F : out Storage.Integer_Address); + function fl_static_get_awake_handler + (H, F : out Storage.Integer_Address) + return Interfaces.C.int; pragma Import (C, fl_static_get_awake_handler, "fl_static_get_awake_handler"); pragma Inline (fl_static_get_awake_handler); + function fl_static_awake2 + (H, F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_awake2, "fl_static_awake2"); + pragma Inline (fl_static_awake2); + + procedure fl_static_awake + (M : in Storage.Integer_Address); + pragma Import (C, fl_static_awake, "fl_static_awake"); + pragma Inline (fl_static_awake); + + -- Pre-Eventloop Callbacks -- + procedure fl_static_add_check (H, F : in Storage.Integer_Address); pragma Import (C, fl_static_add_check, "fl_static_add_check"); @@ -59,6 +141,8 @@ package body FLTK.Static is + -- Timer Callbacks -- + procedure fl_static_add_timeout (S : in Interfaces.C.double; H, F : in Storage.Integer_Address); @@ -85,13 +169,22 @@ package body FLTK.Static is + -- Clipboard Callbacks -- + procedure fl_static_add_clipboard_notify (H, F : in Storage.Integer_Address); pragma Import (C, fl_static_add_clipboard_notify, "fl_static_add_clipboard_notify"); pragma Inline (fl_static_add_clipboard_notify); + procedure fl_static_remove_clipboard_notify + (H : in Storage.Integer_Address); + pragma Import (C, fl_static_remove_clipboard_notify, "fl_static_remove_clipboard_notify"); + pragma Inline (fl_static_remove_clipboard_notify); + + + -- File Descriptor Waiting Callbacks -- procedure fl_static_add_fd (D : in Interfaces.C.int; @@ -118,6 +211,8 @@ package body FLTK.Static is + -- Idle Callbacks -- + procedure fl_static_add_idle (H, F : in Storage.Integer_Address); pragma Import (C, fl_static_add_idle, "fl_static_add_idle"); @@ -137,12 +232,25 @@ package body FLTK.Static is + -- Custom Colors -- + + function fl_static_get_color2 + (C : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_static_get_color2, "fl_static_get_color2"); + pragma Inline (fl_static_get_color2); + procedure fl_static_get_color (C : in Interfaces.C.unsigned; R, G, B : out Interfaces.C.unsigned_char); pragma Import (C, fl_static_get_color, "fl_static_get_color"); pragma Inline (fl_static_get_color); + procedure fl_static_set_color2 + (T, F : in Interfaces.C.unsigned); + pragma Import (C, fl_static_set_color2, "fl_static_set_color2"); + pragma Inline (fl_static_set_color2); + procedure fl_static_set_color (C : in Interfaces.C.unsigned; R, G, B : in Interfaces.C.unsigned_char); @@ -155,6 +263,17 @@ package body FLTK.Static is pragma Import (C, fl_static_free_color, "fl_static_free_color"); pragma Inline (fl_static_free_color); + function fl_static_get_box_color + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_static_get_box_color, "fl_static_get_box_color"); + pragma Inline (fl_static_get_box_color); + + procedure fl_static_set_box_color + (T : in Interfaces.C.unsigned); + pragma Import (C, fl_static_set_box_color, "fl_static_set_box_color"); + pragma Inline (fl_static_set_box_color); + procedure fl_static_foreground (R, G, B : in Interfaces.C.unsigned_char); pragma Import (C, fl_static_foreground, "fl_static_foreground"); @@ -173,6 +292,8 @@ package body FLTK.Static is + -- Custom Fonts -- + function fl_static_get_font (K : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr; @@ -190,6 +311,12 @@ package body FLTK.Static is pragma Import (C, fl_static_set_font, "fl_static_set_font"); pragma Inline (fl_static_set_font); + procedure fl_static_set_font2 + (T : in Interfaces.C.int; + S : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_static_set_font2, "fl_static_set_font2"); + pragma Inline (fl_static_set_font2); + function fl_static_get_font_sizes (F : in Interfaces.C.int; A : out Storage.Integer_Address) @@ -212,6 +339,8 @@ package body FLTK.Static is + -- Box_Kind Attributes -- + function fl_static_box_dh (B : in Interfaces.C.int) return Interfaces.C.int; @@ -236,11 +365,24 @@ package body FLTK.Static is pragma Import (C, fl_static_box_dy, "fl_static_box_dy"); pragma Inline (fl_static_box_dy); + function fl_static_get_boxtype + (T : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_static_get_boxtype, "fl_static_get_boxtype"); + pragma Inline (fl_static_get_boxtype); + procedure fl_static_set_boxtype (T, F : in Interfaces.C.int); pragma Import (C, fl_static_set_boxtype, "fl_static_set_boxtype"); pragma Inline (fl_static_set_boxtype); + procedure fl_static_set_boxtype2 + (T : in Interfaces.C.int; + F : in Storage.Integer_Address; + DX, DY, DW, DH : in Interfaces.C.unsigned_char); + pragma Import (C, fl_static_set_boxtype2, "fl_static_set_boxtype2"); + pragma Inline (fl_static_set_boxtype2); + function fl_static_draw_box_active return Interfaces.C.int; pragma Import (C, fl_static_draw_box_active, "fl_static_draw_box_active"); @@ -249,6 +391,19 @@ package body FLTK.Static is + -- Label_Kind Attributes -- + + procedure fl_static_set_labeltype + (K : in Interfaces.C.int; + D, M : in Storage.Integer_Address); + pragma Import (C, fl_static_set_labeltype, "fl_static_set_labeltype"); + pragma Inline (fl_static_set_labeltype); + + + + + -- Clipboard / Selection -- + procedure fl_static_copy (T : in Interfaces.C.char_array; L, K : in Interfaces.C.int); @@ -268,8 +423,21 @@ package body FLTK.Static is pragma Import (C, fl_static_selection, "fl_static_selection"); pragma Inline (fl_static_selection); + function fl_static_clipboard_contains + (K : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_static_clipboard_contains, "fl_static_clipboard_contains"); + pragma Inline (fl_static_clipboard_contains); + + + -- Dragon Drop -- + + function fl_static_dnd + return Interfaces.C.int; + pragma Import (C, fl_static_dnd, "fl_static_dnd"); + pragma Inline (fl_static_dnd); function fl_static_get_dnd_text_ops return Interfaces.C.int; @@ -284,21 +452,10 @@ package body FLTK.Static is - function fl_static_get_visible_focus - return Interfaces.C.int; - pragma Import (C, fl_static_get_visible_focus, "fl_static_get_visible_focus"); - pragma Inline (fl_static_get_visible_focus); - - procedure fl_static_set_visible_focus - (T : in Interfaces.C.int); - pragma Import (C, fl_static_set_visible_focus, "fl_static_set_visible_focus"); - pragma Inline (fl_static_set_visible_focus); - - - + -- Windows -- procedure fl_static_default_atclose - (W : in Storage.Integer_Address); + (W, U : in Storage.Integer_Address); pragma Import (C, fl_static_default_atclose, "fl_static_default_atclose"); pragma Inline (fl_static_default_atclose); @@ -326,6 +483,8 @@ package body FLTK.Static is + -- Queue -- + function fl_static_readqueue return Storage.Integer_Address; pragma Import (C, fl_static_readqueue, "fl_static_readqueue"); @@ -334,6 +493,8 @@ package body FLTK.Static is + -- Schemes -- + function fl_static_get_scheme return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_static_get_scheme, "fl_static_get_scheme"); @@ -353,6 +514,8 @@ package body FLTK.Static is + -- Library Options -- + function fl_static_get_option (O : in Interfaces.C.int) return Interfaces.C.int; @@ -367,6 +530,8 @@ package body FLTK.Static is + -- Scrollbars -- + function fl_static_get_scrollbar_size return Interfaces.C.int; pragma Import (C, fl_static_get_scrollbar_size, "fl_static_get_scrollbar_size"); @@ -380,6 +545,8 @@ package body FLTK.Static is + -- User Data -- + package Widget_Convert is new System.Address_To_Access_Conversions (FLTK.Widgets.Widget'Class); package Window_Convert is new System.Address_To_Access_Conversions @@ -393,6 +560,41 @@ package body FLTK.Static is + ---------------------- + -- Callback Hooks -- + ---------------------- + + Current_Args_Handler : Args_Handler; + + function Args_Hook + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int; + pragma Convention (C, Args_Hook); + + function Args_Hook + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int + is + Result : Natural; + begin + pragma Assert (I < C and V /= Null_Pointer); + Result := Current_Args_Handler (Positive (I)); + I := I + Interfaces.C.int (Result); + return Interfaces.C.int (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Args_Handler callback was supplied unexpected int i value of " & + Interfaces.C.int'Image (I); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Args_Handler callback was supplied irregular argc and argv values of " & + Interfaces.C.int'Image (C) & " and " & Storage.Integer_Address'Image (V); + end Args_Hook; + + procedure Awake_Hook (U : in Storage.Integer_Address); pragma Convention (C, Awake_Hook); @@ -400,15 +602,173 @@ package body FLTK.Static is procedure Awake_Hook (U : in Storage.Integer_Address) is begin - Conv.To_Awake_Access (U).all; + if U /= Null_Pointer then + Conv.To_Awake_Access (U).all; + end if; end Awake_Hook; + procedure Timeout_Hook + (U : in Storage.Integer_Address); + pragma Convention (C, Timeout_Hook); + + procedure Timeout_Hook + (U : in Storage.Integer_Address) is + begin + Conv.To_Timeout_Access (U).all; + end Timeout_Hook; + + + -- This is handled on the Ada side because otherwise there would be + -- no way to specify which callback to remove in FLTK once one was + -- added. This is because Fl::remove_clipboard_notify does not pay + -- attention to the void * data. This hook is passed during package init. + package Clipboard_Notify_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Clipboard_Notify_Handler); + + Current_Clip_Notes : Clipboard_Notify_Vectors.Vector; + + procedure Clipboard_Notify_Hook + (S : in Interfaces.C.int; + U : in Storage.Integer_Address); + pragma Convention (C, Clipboard_Notify_Hook); + + procedure Clipboard_Notify_Hook + (S : in Interfaces.C.int; + U : in Storage.Integer_Address) is + begin + pragma Assert (S in + Buffer_Kind'Pos (Buffer_Kind'First) .. Buffer_Kind'Pos (Buffer_Kind'Last)); + for Call of Current_Clip_Notes loop + Call.all (Buffer_Kind'Val (S)); + end loop; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Clipboard_Notify_Hook was passed unexpected Buffer_Kind int value of " & + Interfaces.C.int'Image (S); + end Clipboard_Notify_Hook; + + + procedure FD_Hook + (FD : in Interfaces.C.int; + U : in Storage.Integer_Address); + pragma Convention (C, FD_Hook); + + procedure FD_Hook + (FD : in Interfaces.C.int; + U : in Storage.Integer_Address) is + begin + Conv.To_File_Access (U).all (File_Descriptor (FD)); + end FD_Hook; + + + procedure Idle_Hook + (U : in Storage.Integer_Address); + pragma Convention (C, Idle_Hook); + + procedure Idle_Hook + (U : in Storage.Integer_Address) is + begin + Conv.To_Idle_Access (U).all; + end Idle_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out FLTK_Static_Final_Controller) is + begin + FLTK.Args_Marshal.Free_Argv (The_Argv); + for Override of Font_Overrides loop + Interfaces.C.Strings.Free (Override); + end loop; + fl_static_remove_clipboard_notify (Storage.To_Integer (Clipboard_Notify_Hook'Address)); + end Finalize; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Command Line Arguments -- + + function Parse_Arg + (Index : in Positive) + return Natural + is + Count : Interfaces.C.int := Interfaces.C.int (Index); + begin + return Natural (fl_static_arg + (The_Argv'Length, + Storage.To_Integer (The_Argv (The_Argv'First)'Address), + Count)); + end Parse_Arg; + + + procedure Parse_Args is + begin + fl_static_args (The_Argv'Length, Storage.To_Integer (The_Argv (The_Argv'First)'Address)); + end Parse_Args; + + + procedure Parse_Args + (Count : out Natural; + Func : in Args_Handler := null) + is + My_Count : Interfaces.C.int := 1; + Result : Interfaces.C.int; + begin + Current_Args_Handler := Func; + Result := fl_static_args2 + (The_Argv'Length, + Storage.To_Integer (The_Argv (The_Argv'First)'Address), + My_Count, + (if Func = null then Null_Pointer else Storage.To_Integer (Args_Hook'Address))); + Count := Integer (My_Count) - 1; + if Result = 0 then + raise Argument_Error with + "Fl::args could not recognise switch at argument number " & + Interfaces.C.int'Image (My_Count); + else + pragma Assert (Result > 0); + end if; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::args produced unexpected i parameter of " & Interfaces.C.int'Image (My_Count); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::args returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Parse_Args; + + + + + -- Thread Notify -- + procedure Add_Awake_Handler - (Func : in Awake_Handler) is + (Func : in Awake_Handler) + is + Result : constant Interfaces.C.int := fl_static_add_awake_handler + (Storage.To_Integer (Awake_Hook'Address), + Conv.To_Address (Func)); begin - fl_static_add_awake_handler - (Storage.To_Integer (Awake_Hook'Address), Conv.To_Address (Func)); + pragma Assert (Result = 0); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with + "Fl::add_awake_handler_ failed to register Awake_Handler callback"; + else + raise Internal_FLTK_Error with + "Fl::add_awake_handler_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; end Add_Awake_Handler; @@ -416,132 +776,140 @@ package body FLTK.Static is return Awake_Handler is Hook, Func : Storage.Integer_Address; + Result : constant Interfaces.C.int := fl_static_get_awake_handler (Hook, Func); begin - fl_static_get_awake_handler (Hook, Func); + pragma Assert (Result = 0); return Conv.To_Awake_Access (Func); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with + "Fl::get_awake_handler_ invoked without prior awake setup"; + else + raise Internal_FLTK_Error with + "Fl::get_awake_handler_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; end Get_Awake_Handler; + procedure Awake + (Func : in Awake_Handler) + is + Result : constant Interfaces.C.int := fl_static_awake2 + (Storage.To_Integer (Awake_Hook'Address), + Conv.To_Address (Func)); + begin + pragma Assert (Result = 0); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with "Fl::awake failed to register Awake_Handler callback"; + else + raise Internal_FLTK_Error with "Fl::awake returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; + end Awake; - procedure Timeout_Hook - (U : in Storage.Integer_Address); - pragma Convention (C, Timeout_Hook); - - procedure Timeout_Hook - (U : in Storage.Integer_Address) is + procedure Awake is begin - Conv.To_Timeout_Access (U).all; - end Timeout_Hook; + fl_static_awake (Null_Pointer); + end Awake; + + + + -- Pre-Eventloop Callbacks -- procedure Add_Check - (Func : in Timeout_Handler) is + (Func : in not null Timeout_Handler) is begin fl_static_add_check - (Storage.To_Integer (Timeout_Hook'Address), Conv.To_Address (Func)); + (Storage.To_Integer (Timeout_Hook'Address), + Conv.To_Address (Timeout_Handler'(Func))); end Add_Check; function Has_Check - (Func : in Timeout_Handler) + (Func : in not null Timeout_Handler) return Boolean is begin return fl_static_has_check (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)) /= 0; + Conv.To_Address (Timeout_Handler'(Func))) /= 0; end Has_Check; procedure Remove_Check - (Func : in Timeout_Handler) is + (Func : in not null Timeout_Handler) is begin fl_static_remove_check (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Timeout_Handler'(Func))); end Remove_Check; + -- Timer Callbacks -- + procedure Add_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler) is + (Seconds : in Long_Float; + Func : in not null Timeout_Handler) is begin fl_static_add_timeout (Interfaces.C.double (Seconds), Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Timeout_Handler'(Func))); end Add_Timeout; function Has_Timeout - (Func : in Timeout_Handler) + (Func : in not null Timeout_Handler) return Boolean is begin return fl_static_has_timeout (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)) /= 0; + Conv.To_Address (Timeout_Handler'(Func))) /= 0; end Has_Timeout; procedure Remove_Timeout - (Func : in Timeout_Handler) is + (Func : in not null Timeout_Handler) is begin fl_static_remove_timeout (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Timeout_Handler'(Func))); end Remove_Timeout; procedure Repeat_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler) is + (Seconds : in Long_Float; + Func : in not null Timeout_Handler) is begin fl_static_repeat_timeout (Interfaces.C.double (Seconds), Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Timeout_Handler'(Func))); end Repeat_Timeout; - -- This is handled on the Ada side because otherwise there would be - -- no way to specify which callback to remove in FLTK once one was - -- added. The hook is passed during package init. - package Clipboard_Notify_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, - Element_Type => Clipboard_Notify_Handler); - - Current_Clip_Notes : Clipboard_Notify_Vectors.Vector; - - procedure Clipboard_Notify_Hook - (S : in Interfaces.C.int; - U : in Storage.Integer_Address); - pragma Convention (C, Clipboard_Notify_Hook); - - procedure Clipboard_Notify_Hook - (S : in Interfaces.C.int; - U : in Storage.Integer_Address) is - begin - for Call of Current_Clip_Notes loop - Call.all (Buffer_Kind'Val (S)); - end loop; - end Clipboard_Notify_Hook; - + -- Clipboard Callbacks -- procedure Add_Clipboard_Notify - (Func : in Clipboard_Notify_Handler) is + (Func : in not null Clipboard_Notify_Handler) is begin Current_Clip_Notes.Append (Func); end Add_Clipboard_Notify; procedure Remove_Clipboard_Notify - (Func : in Clipboard_Notify_Handler) is + (Func : in not null Clipboard_Notify_Handler) is begin - for Index in Current_Clip_Notes.First_Index .. Current_Clip_Notes.Last_Index loop + for Index in reverse Current_Clip_Notes.First_Index .. Current_Clip_Notes.Last_Index loop if Current_Clip_Notes (Index) = Func then Current_Clip_Notes.Delete (Index); return; @@ -552,22 +920,11 @@ package body FLTK.Static is - procedure FD_Hook - (FD : in Interfaces.C.int; - U : in Storage.Integer_Address); - pragma Convention (C, FD_Hook); - - procedure FD_Hook - (FD : in Interfaces.C.int; - U : in Storage.Integer_Address) is - begin - Conv.To_File_Access (U).all (File_Descriptor (FD)); - end FD_Hook; - + -- File Descriptor Waiting Callbacks -- procedure Add_File_Descriptor - (FD : in File_Descriptor; - Func : in File_Handler) is + (FD : in File_Descriptor; + Func : in not null File_Handler) is begin fl_static_add_fd (Interfaces.C.int (FD), @@ -577,13 +934,13 @@ package body FLTK.Static is procedure Add_File_Descriptor - (FD : in File_Descriptor; - Mode : in File_Mode; - Func : in File_Handler) is + (FD : in File_Descriptor; + Mode : in File_Mode; + Func : in not null File_Handler) is begin fl_static_add_fd2 (Interfaces.C.int (FD), - File_Mode_Codes (Mode), + FMode_To_Cint (Mode), Storage.To_Integer (FD_Hook'Address), Conv.To_Address (Func)); end Add_File_Descriptor; @@ -600,53 +957,54 @@ package body FLTK.Static is (FD : in File_Descriptor; Mode : in File_Mode) is begin - fl_static_remove_fd2 (Interfaces.C.int (FD), File_Mode_Codes (Mode)); + fl_static_remove_fd2 (Interfaces.C.int (FD), FMode_To_Cint (Mode)); end Remove_File_Descriptor; - procedure Idle_Hook - (U : in Storage.Integer_Address); - pragma Convention (C, Idle_Hook); - - procedure Idle_Hook - (U : in Storage.Integer_Address) is - begin - Conv.To_Idle_Access (U).all; - end Idle_Hook; - + -- Idle Callbacks -- procedure Add_Idle - (Func : in Idle_Handler) is + (Func : in not null Idle_Handler) is begin fl_static_add_idle (Storage.To_Integer (Idle_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Idle_Handler'(Func))); end Add_Idle; function Has_Idle - (Func : in Idle_Handler) + (Func : in not null Idle_Handler) return Boolean is begin return fl_static_has_idle (Storage.To_Integer (Idle_Hook'Address), - Conv.To_Address (Func)) /= 0; + Conv.To_Address (Idle_Handler'(Func))) /= 0; end Has_Idle; procedure Remove_Idle - (Func : in Idle_Handler) is + (Func : in not null Idle_Handler) is begin fl_static_remove_idle (Storage.To_Integer (Idle_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Idle_Handler'(Func))); end Remove_Idle; + -- Custom Colors -- + + function Get_Color + (From : in Color) + return Color is + begin + return Color (fl_static_get_color2 (Interfaces.C.unsigned (From))); + end Get_Color; + + procedure Get_Color (From : in Color; R, G, B : out Color_Component) is @@ -660,11 +1018,20 @@ package body FLTK.Static is procedure Set_Color - (To : in Color; + (Target, Source : in Color) is + begin + fl_static_set_color2 + (Interfaces.C.unsigned (Target), + Interfaces.C.unsigned (Source)); + end Set_Color; + + + procedure Set_Color + (Target : in Color; R, G, B : in Color_Component) is begin fl_static_set_color - (Interfaces.C.unsigned (To), + (Interfaces.C.unsigned (Target), Interfaces.C.unsigned_char (R), Interfaces.C.unsigned_char (G), Interfaces.C.unsigned_char (B)); @@ -681,6 +1048,21 @@ package body FLTK.Static is end Free_Color; + function Get_Box_Color + (Tone : in Color) + return Color is + begin + return Color (fl_static_get_box_color (Interfaces.C.unsigned (Tone))); + end Get_Box_Color; + + + procedure Set_Box_Color + (Tone : in Color) is + begin + fl_static_set_box_color (Interfaces.C.unsigned (Tone)); + end Set_Box_Color; + + procedure Set_Foreground (R, G, B : in Color_Component) is begin @@ -713,6 +1095,8 @@ package body FLTK.Static is + -- Custom Fonts -- + function Font_Image (Kind : in Font_Kind) return String is @@ -732,9 +1116,19 @@ package body FLTK.Static is procedure Set_Font_Kind - (To, From : in Font_Kind) is + (Target, Source : in Font_Kind) is begin - fl_static_set_font (Font_Kind'Pos (To), Font_Kind'Pos (From)); + fl_static_set_font (Font_Kind'Pos (Target), Font_Kind'Pos (Source)); + end Set_Font_Kind; + + + procedure Set_Font_Kind + (Target : in Font_Kind; + Source : in String) is + begin + Interfaces.C.Strings.Free (Font_Overrides (Target)); + Font_Overrides (Target) := Interfaces.C.Strings.New_String (Source); + fl_static_set_font2 (Font_Kind'Pos (Target), Font_Overrides (Target)); end Set_Font_Kind; @@ -755,14 +1149,22 @@ package body FLTK.Static is procedure Setup_Fonts - (How_Many_Set_Up : out Natural) is + (How_Many_Set_Up : out Natural) + is + Result : constant Interfaces.C.int := fl_static_set_fonts; begin - How_Many_Set_Up := Natural (fl_static_set_fonts); + How_Many_Set_Up := Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::set_fonts returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Setup_Fonts; + -- Box_Kind Attributes -- + function Get_Box_Height_Offset (Kind : in Box_Kind) return Integer is @@ -809,26 +1211,59 @@ package body FLTK.Static is end Draw_Box_Active; - -- function Get_Box_Draw_Function - -- (Kind : in Box_Kind) - -- return Box_Draw_Function is - -- begin - -- return null; - -- end Get_Box_Draw_Function; + function Get_Box_Draw_Function + (Kind : in Box_Kind) + return Box_Draw_Function is + begin + return FLTK.Box_Draw_Marshal.To_Ada (Kind, fl_static_get_boxtype (Box_Kind'Pos (Kind))); + end Get_Box_Draw_Function; - -- procedure Set_Box_Draw_Function - -- (Kind : in Box_Kind; - -- Func : in Box_Draw_Function; - -- Offset_X, Offset_Y : in Integer := 0; - -- Offset_W, Offset_H : in Integer := 0) is - -- begin - -- null; - -- end Set_Box_Draw_Function; + procedure Set_Box_Draw_Function + (Kind : in Box_Kind; + Func : in Box_Draw_Function; + Offset_X, Offset_Y : in Byte_Integer := 0; + Offset_W, Offset_H : in Byte_Integer := 0) is + begin + fl_static_set_boxtype2 + (Box_Kind'Pos (Kind), + FLTK.Box_Draw_Marshal.To_C (Kind, Func), + Interfaces.C.unsigned_char (Offset_X), + Interfaces.C.unsigned_char (Offset_Y), + Interfaces.C.unsigned_char (Offset_W), + Interfaces.C.unsigned_char (Offset_H)); + end Set_Box_Draw_Function; + -- Label_Kind Attributes -- + + procedure Set_Label_Kind + (Target, Source : in Label_Kind) is + begin + -- As of FLTK 1.3.11 there is no definition given for this function + -- so this is null to avoid linker errors. + null; + end Set_Label_Kind; + + + procedure Set_Label_Draw_Function + (Kind : in Label_Kind; + Draw_Func : in Label_Draw_Function; + Measure_Func : in Label_Measure_Function) is + begin + fl_static_set_labeltype + (Label_Kind'Pos (Kind), + FLTK.Label_Draw_Marshal.To_C (Kind, Draw_Func), + FLTK.Label_Draw_Marshal.To_C (Kind, Measure_Func)); + end Set_Label_Draw_Function; + + + + + -- Clipboard / Selection -- + procedure Copy (Text : in String; Dest : in Buffer_Kind) is @@ -861,6 +1296,23 @@ package body FLTK.Static is end Selection; + function Clipboard_Contains + (Kind : in String) + return Boolean is + begin + return fl_static_clipboard_contains (Interfaces.C.To_C (Kind)) /= 0; + end Clipboard_Contains; + + + + + -- Dragon Drop -- + + procedure Drag_Drop_Start is + Ignore : Interfaces.C.int := fl_static_dnd; + begin + null; + end Drag_Drop_Start; function Get_Drag_Drop_Text_Support @@ -879,26 +1331,18 @@ package body FLTK.Static is - function Has_Visible_Focus - return Boolean is - begin - return fl_static_get_visible_focus /= 0; - end Has_Visible_Focus; - - - procedure Set_Visible_Focus - (To : in Boolean) is - begin - fl_static_set_visible_focus (Boolean'Pos (To)); - end Set_Visible_Focus; - - - + -- Windows -- procedure Default_Window_Close (Item : in out FLTK.Widgets.Widget'Class) is begin - fl_static_default_atclose (Wrapper (Item).Void_Ptr); + pragma Assert (Wrapper (Item).Void_Ptr /= Null_Pointer); + fl_static_default_atclose + (Wrapper (Item).Void_Ptr, + fl_widget_get_user_data (Wrapper (Item).Void_Ptr)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::default_atclose received uninitialised widget"; end Default_Window_Close; @@ -915,7 +1359,8 @@ package body FLTK.Static is end if; return Actual_First; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::first_window did not have user_data reference back to Ada"; end Get_First_Window; @@ -940,7 +1385,8 @@ package body FLTK.Static is end if; return Actual_Next; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::next_window did not have user_data reference back to Ada"; end Get_Next_Window; @@ -957,12 +1403,15 @@ package body FLTK.Static is end if; return Actual_Modal; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::modal did not have user_data reference back to Ada"; end Get_Top_Modal; + -- Queue -- + function Read_Queue return access FLTK.Widgets.Widget'Class is @@ -976,16 +1425,19 @@ package body FLTK.Static is end if; return Actual_Queue; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::readqueue did not have user_data reference back to Ada"; end Read_Queue; + -- Schemes -- + function Get_Scheme return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_static_get_scheme; + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_static_get_scheme; begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -998,20 +1450,29 @@ package body FLTK.Static is procedure Set_Scheme (To : in String) is begin + -- A copy of the Scheme string is stored in FLTK fl_static_set_scheme (Interfaces.C.To_C (To)); end Set_Scheme; function Is_Scheme (Scheme : in String) - return Boolean is + return Boolean + is + Result : constant Interfaces.C.int := fl_static_is_scheme (Interfaces.C.To_C (Scheme)); begin - return fl_static_is_scheme (Interfaces.C.To_C (Scheme)) /= 0; + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::is_scheme returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Is_Scheme; + -- Library Options -- + function Get_Option (Opt : in Option) return Boolean is @@ -1030,10 +1491,18 @@ package body FLTK.Static is + -- Scrollbars -- + function Get_Default_Scrollbar_Size - return Natural is + return Natural + is + Result : constant Interfaces.C.int := fl_static_get_scrollbar_size; begin - return Natural (fl_static_get_scrollbar_size); + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::scrollbar_size returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Get_Default_Scrollbar_Size; @@ -1053,3 +1522,4 @@ begin end FLTK.Static; + |