diff options
Diffstat (limited to 'body/fltk-static.adb')
| -rw-r--r-- | body/fltk-static.adb | 195 |
1 files changed, 140 insertions, 55 deletions
diff --git a/body/fltk-static.adb b/body/fltk-static.adb index 5912a3f..59a3aa2 100644 --- a/body/fltk-static.adb +++ b/body/fltk-static.adb @@ -27,6 +27,12 @@ package body FLTK.Static is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Interthread Notify -- + 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"); @@ -40,6 +46,8 @@ package body FLTK.Static is + -- 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 +67,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,6 +95,8 @@ 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"); @@ -93,6 +105,8 @@ package body FLTK.Static is + -- File Descriptor Waiting Callbacks -- + procedure fl_static_add_fd (D : in Interfaces.C.int; H, F : in Storage.Integer_Address); @@ -118,6 +132,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,6 +153,8 @@ package body FLTK.Static is + -- Custom Colors -- + procedure fl_static_get_color (C : in Interfaces.C.unsigned; R, G, B : out Interfaces.C.unsigned_char); @@ -173,6 +191,8 @@ package body FLTK.Static is + -- Custom Fonts -- + function fl_static_get_font (K : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr; @@ -212,6 +232,8 @@ package body FLTK.Static is + -- Box_Kind Attributes -- + function fl_static_box_dh (B : in Interfaces.C.int) return Interfaces.C.int; @@ -249,6 +271,8 @@ package body FLTK.Static is + -- Clipboard / Selection -- + procedure fl_static_copy (T : in Interfaces.C.char_array; L, K : in Interfaces.C.int); @@ -271,6 +295,8 @@ package body FLTK.Static is + -- Dragon Drop -- + 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"); @@ -284,6 +310,8 @@ package body FLTK.Static is + -- Input Focus -- + function fl_static_get_visible_focus return Interfaces.C.int; pragma Import (C, fl_static_get_visible_focus, "fl_static_get_visible_focus"); @@ -297,6 +325,8 @@ package body FLTK.Static is + -- Windows -- + procedure fl_static_default_atclose (W : in Storage.Integer_Address); pragma Import (C, fl_static_default_atclose, "fl_static_default_atclose"); @@ -326,6 +356,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 +366,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 +387,8 @@ package body FLTK.Static is + -- Library Options -- + function fl_static_get_option (O : in Interfaces.C.int) return Interfaces.C.int; @@ -367,6 +403,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 +418,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 +433,10 @@ package body FLTK.Static is + ---------------------- + -- Callback Hooks -- + ---------------------- + procedure Awake_Hook (U : in Storage.Integer_Address); pragma Convention (C, Awake_Hook); @@ -404,6 +448,73 @@ package body FLTK.Static is 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. 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 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; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Interthread Notify -- + procedure Add_Awake_Handler (Func : in Awake_Handler) is begin @@ -424,16 +535,7 @@ package body FLTK.Static is - 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; - + -- Pre-Eventloop Callbacks -- procedure Add_Check (Func : in Timeout_Handler) is @@ -464,6 +566,8 @@ package body FLTK.Static is + -- Timer Callbacks -- + procedure Add_Timeout (Seconds : in Long_Float; Func : in Timeout_Handler) is @@ -507,29 +611,7 @@ package body FLTK.Static is - -- 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 @@ -552,18 +634,7 @@ 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; @@ -606,16 +677,7 @@ package body FLTK.Static is - 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 @@ -647,6 +709,8 @@ package body FLTK.Static is + -- Custom Colors -- + procedure Get_Color (From : in Color; R, G, B : out Color_Component) is @@ -713,6 +777,8 @@ package body FLTK.Static is + -- Custom Fonts -- + function Font_Image (Kind : in Font_Kind) return String is @@ -763,6 +829,8 @@ package body FLTK.Static is + -- Box_Kind Attributes -- + function Get_Box_Height_Offset (Kind : in Box_Kind) return Integer is @@ -829,6 +897,8 @@ package body FLTK.Static is + -- Clipboard / Selection -- + procedure Copy (Text : in String; Dest : in Buffer_Kind) is @@ -863,6 +933,8 @@ package body FLTK.Static is + -- Dragon Drop -- + function Get_Drag_Drop_Text_Support return Boolean is begin @@ -879,6 +951,8 @@ package body FLTK.Static is + -- Input Focus -- + function Has_Visible_Focus return Boolean is begin @@ -895,6 +969,8 @@ package body FLTK.Static is + -- Windows -- + procedure Default_Window_Close (Item : in out FLTK.Widgets.Widget'Class) is begin @@ -966,6 +1042,8 @@ package body FLTK.Static is + -- Queue -- + function Read_Queue return access FLTK.Widgets.Widget'Class is @@ -986,6 +1064,8 @@ package body FLTK.Static is + -- Schemes -- + function Get_Scheme return String is @@ -1016,6 +1096,8 @@ package body FLTK.Static is + -- Library Options -- + function Get_Option (Opt : in Option) return Boolean is @@ -1034,6 +1116,8 @@ package body FLTK.Static is + -- Scrollbars -- + function Get_Default_Scrollbar_Size return Natural is begin @@ -1057,3 +1141,4 @@ begin end FLTK.Static; + |