diff options
Diffstat (limited to 'src/fltk-static.adb')
| -rw-r--r-- | src/fltk-static.adb | 1055 |
1 files changed, 0 insertions, 1055 deletions
diff --git a/src/fltk-static.adb b/src/fltk-static.adb deleted file mode 100644 index 56b30c0..0000000 --- a/src/fltk-static.adb +++ /dev/null @@ -1,1055 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Ada.Assertions, - Ada.Containers.Vectors, - Interfaces.C.Strings, - System.Address_To_Access_Conversions, - FLTK.Static_Callback_Conversions; - -use type - - Interfaces.C.int, - Interfaces.C.Strings.chars_ptr; - - -package body FLTK.Static is - - - package Chk renames Ada.Assertions; - package Conv renames FLTK.Static_Callback_Conversions; - - - - - procedure fl_static_add_awake_handler - (H, F : in Storage.Integer_Address); - 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); - pragma Import (C, fl_static_get_awake_handler, "fl_static_get_awake_handler"); - pragma Inline (fl_static_get_awake_handler); - - - - - procedure fl_static_add_check - (H, F : in Storage.Integer_Address); - pragma Import (C, fl_static_add_check, "fl_static_add_check"); - pragma Inline (fl_static_add_check); - - function fl_static_has_check - (H, F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_static_has_check, "fl_static_has_check"); - pragma Inline (fl_static_has_check); - - procedure fl_static_remove_check - (H, F : in Storage.Integer_Address); - pragma Import (C, fl_static_remove_check, "fl_static_remove_check"); - pragma Inline (fl_static_remove_check); - - - - - procedure fl_static_add_timeout - (S : in Interfaces.C.double; - H, F : in Storage.Integer_Address); - pragma Import (C, fl_static_add_timeout, "fl_static_add_timeout"); - pragma Inline (fl_static_add_timeout); - - function fl_static_has_timeout - (H, F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_static_has_timeout, "fl_static_has_timeout"); - pragma Inline (fl_static_has_timeout); - - procedure fl_static_remove_timeout - (H, F : in Storage.Integer_Address); - pragma Import (C, fl_static_remove_timeout, "fl_static_remove_timeout"); - pragma Inline (fl_static_remove_timeout); - - procedure fl_static_repeat_timeout - (S : in Interfaces.C.double; - H, F : in Storage.Integer_Address); - pragma Import (C, fl_static_repeat_timeout, "fl_static_repeat_timeout"); - pragma Inline (fl_static_repeat_timeout); - - - - - 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_add_fd - (D : in Interfaces.C.int; - H, F : in Storage.Integer_Address); - pragma Import (C, fl_static_add_fd, "fl_static_add_fd"); - pragma Inline (fl_static_add_fd); - - procedure fl_static_add_fd2 - (D, M : in Interfaces.C.int; - H, F : in Storage.Integer_Address); - pragma Import (C, fl_static_add_fd2, "fl_static_add_fd2"); - pragma Inline (fl_static_add_fd2); - - procedure fl_static_remove_fd - (D : in Interfaces.C.int); - pragma Import (C, fl_static_remove_fd, "fl_static_remove_fd"); - pragma Inline (fl_static_remove_fd); - - procedure fl_static_remove_fd2 - (D, M : in Interfaces.C.int); - pragma Import (C, fl_static_remove_fd2, "fl_static_remove_fd2"); - pragma Inline (fl_static_remove_fd2); - - - - - procedure fl_static_add_idle - (H, F : in Storage.Integer_Address); - pragma Import (C, fl_static_add_idle, "fl_static_add_idle"); - pragma Inline (fl_static_add_idle); - - function fl_static_has_idle - (H, F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_static_has_idle, "fl_static_has_idle"); - pragma Inline (fl_static_has_idle); - - procedure fl_static_remove_idle - (H, F : in Storage.Integer_Address); - pragma Import (C, fl_static_remove_idle, "fl_static_remove_idle"); - pragma Inline (fl_static_remove_idle); - - - - - 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_color - (C : in Interfaces.C.unsigned; - R, G, B : in Interfaces.C.unsigned_char); - pragma Import (C, fl_static_set_color, "fl_static_set_color"); - pragma Inline (fl_static_set_color); - - procedure fl_static_free_color - (C : in Interfaces.C.unsigned; - B : in Interfaces.C.int); - pragma Import (C, fl_static_free_color, "fl_static_free_color"); - pragma Inline (fl_static_free_color); - - procedure fl_static_foreground - (R, G, B : in Interfaces.C.unsigned_char); - pragma Import (C, fl_static_foreground, "fl_static_foreground"); - pragma Inline (fl_static_foreground); - - procedure fl_static_background - (R, G, B : in Interfaces.C.unsigned_char); - pragma Import (C, fl_static_background, "fl_static_background"); - pragma Inline (fl_static_background); - - procedure fl_static_background2 - (R, G, B : in Interfaces.C.unsigned_char); - pragma Import (C, fl_static_background2, "fl_static_background2"); - pragma Inline (fl_static_background2); - - - - - function fl_static_get_font - (K : in Interfaces.C.int) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_static_get_font, "fl_static_get_font"); - pragma Inline (fl_static_get_font); - - function fl_static_get_font_name - (K : in Interfaces.C.int) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_static_get_font_name, "fl_static_get_font_name"); - pragma Inline (fl_static_get_font_name); - - procedure fl_static_set_font - (T, F : in Interfaces.C.int); - pragma Import (C, fl_static_set_font, "fl_static_set_font"); - pragma Inline (fl_static_set_font); - - function fl_static_get_font_sizes - (F : in Interfaces.C.int; - A : out Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_static_get_font_sizes, "fl_static_get_font_sizes"); - pragma Inline (fl_static_get_font_sizes); - - function fl_static_font_size_array_get - (A : in Storage.Integer_Address; - I : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_static_font_size_array_get, "fl_static_font_size_array_get"); - pragma Inline (fl_static_font_size_array_get); - - function fl_static_set_fonts - return Interfaces.C.int; - pragma Import (C, fl_static_set_fonts, "fl_static_set_fonts"); - pragma Inline (fl_static_set_fonts); - - - - - function fl_static_box_dh - (B : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_static_box_dh, "fl_static_box_dh"); - pragma Inline (fl_static_box_dh); - - function fl_static_box_dw - (B : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_static_box_dw, "fl_static_box_dw"); - pragma Inline (fl_static_box_dw); - - function fl_static_box_dx - (B : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_static_box_dx, "fl_static_box_dx"); - pragma Inline (fl_static_box_dx); - - function fl_static_box_dy - (B : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_static_box_dy, "fl_static_box_dy"); - pragma Inline (fl_static_box_dy); - - 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); - - function fl_static_draw_box_active - return Interfaces.C.int; - pragma Import (C, fl_static_draw_box_active, "fl_static_draw_box_active"); - pragma Inline (fl_static_draw_box_active); - - - - - procedure fl_static_copy - (T : in Interfaces.C.char_array; - L, K : in Interfaces.C.int); - pragma Import (C, fl_static_copy, "fl_static_copy"); - pragma Inline (fl_static_copy); - - procedure fl_static_paste - (R : in Storage.Integer_Address; - S : in Interfaces.C.int); - pragma Import (C, fl_static_paste, "fl_static_paste"); - pragma Inline (fl_static_paste); - - procedure fl_static_selection - (O : in Storage.Integer_Address; - T : in Interfaces.C.char_array; - L : in Interfaces.C.int); - pragma Import (C, fl_static_selection, "fl_static_selection"); - pragma Inline (fl_static_selection); - - - - - function fl_static_get_dnd_text_ops - return Interfaces.C.int; - pragma Import (C, fl_static_get_dnd_text_ops, "fl_static_get_dnd_text_ops"); - pragma Inline (fl_static_get_dnd_text_ops); - - procedure fl_static_set_dnd_text_ops - (T : in Interfaces.C.int); - pragma Import (C, fl_static_set_dnd_text_ops, "fl_static_set_dnd_text_ops"); - pragma Inline (fl_static_set_dnd_text_ops); - - - - - 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); - - - - - procedure fl_static_default_atclose - (W : in Storage.Integer_Address); - pragma Import (C, fl_static_default_atclose, "fl_static_default_atclose"); - pragma Inline (fl_static_default_atclose); - - function fl_static_get_first_window - return Storage.Integer_Address; - pragma Import (C, fl_static_get_first_window, "fl_static_get_first_window"); - pragma Inline (fl_static_get_first_window); - - procedure fl_static_set_first_window - (T : in Storage.Integer_Address); - pragma Import (C, fl_static_set_first_window, "fl_static_set_first_window"); - pragma Inline (fl_static_set_first_window); - - function fl_static_next_window - (W : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_static_next_window, "fl_static_next_window"); - pragma Inline (fl_static_next_window); - - function fl_static_modal - return Storage.Integer_Address; - pragma Import (C, fl_static_modal, "fl_static_modal"); - pragma Inline (fl_static_modal); - - - - - function fl_static_readqueue - return Storage.Integer_Address; - pragma Import (C, fl_static_readqueue, "fl_static_readqueue"); - pragma Inline (fl_static_readqueue); - - - - - function fl_static_get_scheme - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_static_get_scheme, "fl_static_get_scheme"); - pragma Inline (fl_static_get_scheme); - - procedure fl_static_set_scheme - (S : in Interfaces.C.char_array); - pragma Import (C, fl_static_set_scheme, "fl_static_set_scheme"); - pragma Inline (fl_static_set_scheme); - - function fl_static_is_scheme - (S : in Interfaces.C.char_array) - return Interfaces.C.int; - pragma Import (C, fl_static_is_scheme, "fl_static_is_scheme"); - pragma Inline (fl_static_is_scheme); - - - - - function fl_static_get_option - (O : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_static_get_option, "fl_static_get_option"); - pragma Inline (fl_static_get_option); - - procedure fl_static_set_option - (O, T : in Interfaces.C.int); - pragma Import (C, fl_static_set_option, "fl_static_set_option"); - pragma Inline (fl_static_set_option); - - - - - function fl_static_get_scrollbar_size - return Interfaces.C.int; - pragma Import (C, fl_static_get_scrollbar_size, "fl_static_get_scrollbar_size"); - pragma Inline (fl_static_get_scrollbar_size); - - procedure fl_static_set_scrollbar_size - (S : in Interfaces.C.int); - pragma Import (C, fl_static_set_scrollbar_size, "fl_static_set_scrollbar_size"); - pragma Inline (fl_static_set_scrollbar_size); - - - - - package Widget_Convert is new System.Address_To_Access_Conversions - (FLTK.Widgets.Widget'Class); - package Window_Convert is new System.Address_To_Access_Conversions - (FLTK.Widgets.Groups.Windows.Window'Class); - - function fl_widget_get_user_data - (W : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); - - - - - procedure Awake_Hook - (U : in Storage.Integer_Address); - pragma Convention (C, Awake_Hook); - - procedure Awake_Hook - (U : in Storage.Integer_Address) is - begin - Conv.To_Awake_Access (U).all; - end Awake_Hook; - - - procedure Add_Awake_Handler - (Func : in Awake_Handler) is - begin - fl_static_add_awake_handler - (Storage.To_Integer (Awake_Hook'Address), Conv.To_Address (Func)); - end Add_Awake_Handler; - - - function Get_Awake_Handler - return Awake_Handler - is - Hook, Func : Storage.Integer_Address; - begin - fl_static_get_awake_handler (Hook, Func); - return Conv.To_Awake_Access (Func); - end Get_Awake_Handler; - - - - - 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; - - - procedure Add_Check - (Func : in Timeout_Handler) is - begin - fl_static_add_check - (Storage.To_Integer (Timeout_Hook'Address), Conv.To_Address (Func)); - end Add_Check; - - - function Has_Check - (Func : in Timeout_Handler) - return Boolean is - begin - return fl_static_has_check - (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)) /= 0; - end Has_Check; - - - procedure Remove_Check - (Func : in Timeout_Handler) is - begin - fl_static_remove_check - (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); - end Remove_Check; - - - - - procedure Add_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler) is - begin - fl_static_add_timeout - (Interfaces.C.double (Seconds), - Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); - end Add_Timeout; - - - function Has_Timeout - (Func : in Timeout_Handler) - return Boolean is - begin - return fl_static_has_timeout - (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)) /= 0; - end Has_Timeout; - - - procedure Remove_Timeout - (Func : in Timeout_Handler) is - begin - fl_static_remove_timeout - (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); - end Remove_Timeout; - - - procedure Repeat_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler) is - begin - fl_static_repeat_timeout - (Interfaces.C.double (Seconds), - Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (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; - - - procedure Add_Clipboard_Notify - (Func : in Clipboard_Notify_Handler) is - begin - Current_Clip_Notes.Append (Func); - end Add_Clipboard_Notify; - - - procedure Remove_Clipboard_Notify - (Func : in Clipboard_Notify_Handler) is - begin - for Index in Current_Clip_Notes.First_Index .. Current_Clip_Notes.Last_Index loop - if Current_Clip_Notes (Index) = Func then - Current_Clip_Notes.Delete (Index); - return; - end if; - end loop; - end Remove_Clipboard_Notify; - - - - - 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 Add_File_Descriptor - (FD : in File_Descriptor; - Func : in File_Handler) is - begin - fl_static_add_fd - (Interfaces.C.int (FD), - Storage.To_Integer (FD_Hook'Address), - Conv.To_Address (Func)); - end Add_File_Descriptor; - - - procedure Add_File_Descriptor - (FD : in File_Descriptor; - Mode : in File_Mode; - Func : in File_Handler) is - begin - fl_static_add_fd2 - (Interfaces.C.int (FD), - File_Mode_Codes (Mode), - Storage.To_Integer (FD_Hook'Address), - Conv.To_Address (Func)); - end Add_File_Descriptor; - - - procedure Remove_File_Descriptor - (FD : in File_Descriptor) is - begin - fl_static_remove_fd (Interfaces.C.int (FD)); - end Remove_File_Descriptor; - - - procedure Remove_File_Descriptor - (FD : in File_Descriptor; - Mode : in File_Mode) is - begin - fl_static_remove_fd2 (Interfaces.C.int (FD), File_Mode_Codes (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; - - - procedure Add_Idle - (Func : in Idle_Handler) is - begin - fl_static_add_idle - (Storage.To_Integer (Idle_Hook'Address), - Conv.To_Address (Func)); - end Add_Idle; - - - function Has_Idle - (Func : in Idle_Handler) - return Boolean is - begin - return fl_static_has_idle - (Storage.To_Integer (Idle_Hook'Address), - Conv.To_Address (Func)) /= 0; - end Has_Idle; - - - procedure Remove_Idle - (Func : in Idle_Handler) is - begin - fl_static_remove_idle - (Storage.To_Integer (Idle_Hook'Address), - Conv.To_Address (Func)); - end Remove_Idle; - - - - - procedure Get_Color - (From : in Color; - R, G, B : out Color_Component) is - begin - fl_static_get_color - (Interfaces.C.unsigned (From), - Interfaces.C.unsigned_char (R), - Interfaces.C.unsigned_char (G), - Interfaces.C.unsigned_char (B)); - end Get_Color; - - - procedure Set_Color - (To : in Color; - R, G, B : in Color_Component) is - begin - fl_static_set_color - (Interfaces.C.unsigned (To), - Interfaces.C.unsigned_char (R), - Interfaces.C.unsigned_char (G), - Interfaces.C.unsigned_char (B)); - end Set_Color; - - - procedure Free_Color - (Value : in Color; - Overlay : in Boolean := False) is - begin - fl_static_free_color - (Interfaces.C.unsigned (Value), - Boolean'Pos (Overlay)); - end Free_Color; - - - procedure Set_Foreground - (R, G, B : in Color_Component) is - begin - fl_static_foreground - (Interfaces.C.unsigned_char (R), - Interfaces.C.unsigned_char (G), - Interfaces.C.unsigned_char (B)); - end Set_Foreground; - - - procedure Set_Background - (R, G, B : in Color_Component) is - begin - fl_static_background - (Interfaces.C.unsigned_char (R), - Interfaces.C.unsigned_char (G), - Interfaces.C.unsigned_char (B)); - end Set_Background; - - - procedure Set_Alt_Background - (R, G, B : in Color_Component) is - begin - fl_static_background2 - (Interfaces.C.unsigned_char (R), - Interfaces.C.unsigned_char (G), - Interfaces.C.unsigned_char (B)); - end Set_Alt_Background; - - - - - function Font_Image - (Kind : in Font_Kind) - return String is - begin - -- should never get a null string in return since it's from an enum - return Interfaces.C.Strings.Value (fl_static_get_font (Font_Kind'Pos (Kind))); - end Font_Image; - - - function Font_Family_Image - (Kind : in Font_Kind) - return String is - begin - -- should never get a null string in return since it's from an enum - return Interfaces.C.Strings.Value (fl_static_get_font_name (Font_Kind'Pos (Kind))); - end Font_Family_Image; - - - procedure Set_Font_Kind - (To, From : in Font_Kind) is - begin - fl_static_set_font (Font_Kind'Pos (To), Font_Kind'Pos (From)); - end Set_Font_Kind; - - - function Font_Sizes - (Kind : in Font_Kind) - return Font_Size_Array - is - Ptr : Storage.Integer_Address; - Arr : Font_Size_Array - (1 .. Integer (fl_static_get_font_sizes (Font_Kind'Pos (Kind), Ptr))); - begin - -- This array copying avoids any worry that the static buffer will be overwritten. - for I in 1 .. Arr'Length loop - Arr (I) := Font_Size (fl_static_font_size_array_get (Ptr, Interfaces.C.int (I))); - end loop; - return Arr; - end Font_Sizes; - - - procedure Setup_Fonts - (How_Many_Set_Up : out Natural) is - begin - How_Many_Set_Up := Natural (fl_static_set_fonts); - end Setup_Fonts; - - - - - function Get_Box_Height_Offset - (Kind : in Box_Kind) - return Integer is - begin - return Integer (fl_static_box_dh (Box_Kind'Pos (Kind))); - end Get_Box_Height_Offset; - - - function Get_Box_Width_Offset - (Kind : in Box_Kind) - return Integer is - begin - return Integer (fl_static_box_dw (Box_Kind'Pos (Kind))); - end Get_Box_Width_Offset; - - - function Get_Box_X_Offset - (Kind : in Box_Kind) - return Integer is - begin - return Integer (fl_static_box_dx (Box_Kind'Pos (Kind))); - end Get_Box_X_Offset; - - - function Get_Box_Y_Offset - (Kind : in Box_Kind) - return Integer is - begin - return Integer (fl_static_box_dy (Box_Kind'Pos (Kind))); - end Get_Box_Y_Offset; - - - procedure Set_Box_Kind - (To, From : in Box_Kind) is - begin - fl_static_set_boxtype (Box_Kind'Pos (To), Box_Kind'Pos (From)); - end Set_Box_Kind; - - - function Draw_Box_Active - return Boolean is - begin - return fl_static_draw_box_active /= 0; - 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; - - - -- 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 Copy - (Text : in String; - Dest : in Buffer_Kind) is - begin - fl_static_copy - (Interfaces.C.To_C (Text), - Text'Length, - Buffer_Kind'Pos (Dest)); - end Copy; - - - procedure Paste - (Receiver : in FLTK.Widgets.Widget'Class; - Source : in Buffer_Kind) is - begin - fl_static_paste - (Wrapper (Receiver).Void_Ptr, - Buffer_Kind'Pos (Source)); - end Paste; - - - procedure Selection - (Owner : in FLTK.Widgets.Widget'Class; - Text : in String) is - begin - fl_static_selection - (Wrapper (Owner).Void_Ptr, - Interfaces.C.To_C (Text), - Text'Length); - end Selection; - - - - - function Get_Drag_Drop_Text_Support - return Boolean is - begin - return fl_static_get_dnd_text_ops /= 0; - end Get_Drag_Drop_Text_Support; - - - procedure Set_Drag_Drop_Text_Support - (To : in Boolean) is - begin - fl_static_set_dnd_text_ops (Boolean'Pos (To)); - end Set_Drag_Drop_Text_Support; - - - - - 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; - - - - - procedure Default_Window_Close - (Item : in out FLTK.Widgets.Widget'Class) is - begin - fl_static_default_atclose (Wrapper (Item).Void_Ptr); - end Default_Window_Close; - - - function Get_First_Window - return access FLTK.Widgets.Groups.Windows.Window'Class - is - First_Ptr : Storage.Integer_Address := fl_static_get_first_window; - Actual_First : access FLTK.Widgets.Groups.Windows.Window'Class; - begin - if First_Ptr /= Null_Pointer then - First_Ptr := fl_widget_get_user_data (First_Ptr); - pragma Assert (First_Ptr /= Null_Pointer); - Actual_First := Window_Convert.To_Pointer (Storage.To_Address (First_Ptr)); - end if; - return Actual_First; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end Get_First_Window; - - - procedure Set_First_Window - (To : in FLTK.Widgets.Groups.Windows.Window'Class) is - begin - fl_static_set_first_window (Wrapper (To).Void_Ptr); - end Set_First_Window; - - - function Get_Next_Window - (From : in FLTK.Widgets.Groups.Windows.Window'Class) - return access FLTK.Widgets.Groups.Windows.Window'Class - is - Next_Ptr : Storage.Integer_Address := fl_static_next_window (Wrapper (From).Void_Ptr); - Actual_Next : access FLTK.Widgets.Groups.Windows.Window'Class; - begin - if Next_Ptr /= Null_Pointer then - Next_Ptr := fl_widget_get_user_data (Next_Ptr); - pragma Assert (Next_Ptr /= Null_Pointer); - Actual_Next := Window_Convert.To_Pointer (Storage.To_Address (Next_Ptr)); - end if; - return Actual_Next; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end Get_Next_Window; - - - function Get_Top_Modal - return access FLTK.Widgets.Groups.Windows.Window'Class - is - Modal_Ptr : Storage.Integer_Address := fl_static_modal; - Actual_Modal : access FLTK.Widgets.Groups.Windows.Window'Class; - begin - if Modal_Ptr /= Null_Pointer then - Modal_Ptr := fl_widget_get_user_data (Modal_Ptr); - pragma Assert (Modal_Ptr /= Null_Pointer); - Actual_Modal := Window_Convert.To_Pointer (Storage.To_Address (Modal_Ptr)); - end if; - return Actual_Modal; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end Get_Top_Modal; - - - - - function Read_Queue - return access FLTK.Widgets.Widget'Class - is - Queue_Ptr : Storage.Integer_Address := fl_static_readqueue; - Actual_Queue : access FLTK.Widgets.Widget'Class; - begin - if Queue_Ptr /= Null_Pointer then - Queue_Ptr := fl_widget_get_user_data (Queue_Ptr); - pragma Assert (Queue_Ptr /= Null_Pointer); - Actual_Queue := Widget_Convert.To_Pointer (Storage.To_Address (Queue_Ptr)); - end if; - return Actual_Queue; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end Read_Queue; - - - - - function Get_Scheme - return String - is - Ptr : Interfaces.C.Strings.chars_ptr := fl_static_get_scheme; - begin - if Ptr = Interfaces.C.Strings.Null_Ptr then - return ""; - else - return Interfaces.C.Strings.Value (Ptr); - end if; - end Get_Scheme; - - - procedure Set_Scheme - (To : in String) is - begin - fl_static_set_scheme (Interfaces.C.To_C (To)); - end Set_Scheme; - - - function Is_Scheme - (Scheme : in String) - return Boolean is - begin - return fl_static_is_scheme (Interfaces.C.To_C (Scheme)) /= 0; - end Is_Scheme; - - - - - function Get_Option - (Opt : in Option) - return Boolean is - begin - return fl_static_get_option (Option'Pos (Opt)) /= 0; - end Get_Option; - - - procedure Set_Option - (Opt : in Option; - To : in Boolean) is - begin - fl_static_set_option (Option'Pos (Opt), Boolean'Pos (To)); - end Set_Option; - - - - - function Get_Default_Scrollbar_Size - return Natural is - begin - return Natural (fl_static_get_scrollbar_size); - end Get_Default_Scrollbar_Size; - - - procedure Set_Default_Scrollbar_Size - (To : in Natural) is - begin - fl_static_set_scrollbar_size (Interfaces.C.int (To)); - end Set_Default_Scrollbar_Size; - - -begin - - - fl_static_add_clipboard_notify - (Storage.To_Integer (Clipboard_Notify_Hook'Address), Null_Pointer); - - -end FLTK.Static; - |