From d5fd3906e62969fce7fec7f2fccdc5a7436cbdbc Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Tue, 18 Feb 2025 12:54:42 +1300 Subject: Filled holes in FLTK, FLTK.Events, FLTK.Screen, tweaked Fl_Shortcut implementation --- body/c_fl.cpp | 72 +- body/c_fl.h | 30 +- body/c_fl_event.cpp | 51 +- body/c_fl_event.h | 15 +- body/c_fl_screen.cpp | 31 + body/c_fl_screen.h | 13 + body/c_fl_static.cpp | 12 + body/c_fl_static.h | 3 + body/fltk-event.adb | 748 ---------------- body/fltk-events.adb | 988 +++++++++++++++++++++ body/fltk-menu_items.adb | 4 +- body/fltk-screen.adb | 81 ++ body/fltk-widgets-buttons.adb | 2 +- ...k-widgets-groups-text_displays-text_editors.adb | 6 +- body/fltk-widgets-groups-text_displays.adb | 4 +- body/fltk-widgets-inputs.adb | 4 +- body/fltk-widgets-menus-menu_bars-systemwide.adb | 10 +- body/fltk-widgets-menus.adb | 10 +- body/fltk-widgets-valuators-value_inputs.adb | 2 +- body/fltk.adb | 125 +-- 20 files changed, 1338 insertions(+), 873 deletions(-) delete mode 100644 body/fltk-event.adb create mode 100644 body/fltk-events.adb (limited to 'body') diff --git a/body/c_fl.cpp b/body/c_fl.cpp index 42d9a45..871b32d 100644 --- a/body/c_fl.cpp +++ b/body/c_fl.cpp @@ -60,6 +60,37 @@ const int fl_enum_num_gray = FL_NUM_GRAY; +const unsigned int fl_enum_button1 = FL_BUTTON1; +const unsigned int fl_enum_button2 = FL_BUTTON2; +const unsigned int fl_enum_button3 = FL_BUTTON3; +#if FL_API_VERSION >= 10310 +const unsigned int fl_enum_button4 = FL_BUTTON4; +const unsigned int fl_enum_button5 = FL_BUTTON5; +#else +// woo, limited backwards compatibility +const unsigned int fl_enum_button4 = 8; +const unsigned int fl_enum_button5 = 16; +#endif +const unsigned int fl_enum_buttons = FL_BUTTONS; + + + + +const int fl_enum_left_mouse = FL_LEFT_MOUSE; +const int fl_enum_middle_mouse = FL_MIDDLE_MOUSE; +const int fl_enum_right_mouse = FL_RIGHT_MOUSE; +#if FL_API_VERSION >= 10310 +const int fl_enum_back_mouse = FL_BACK_MOUSE; +const int fl_enum_forward_mouse = FL_FORWARD_MOUSE; +#else +// woo, limited backwards compatibility +const int fl_enum_back_mouse = 4; +const int fl_enum_forward_mouse = 5; +#endif + + + + unsigned int fl_enum_rgb_color2(unsigned char l) { return static_cast(fl_rgb_color(l)); } @@ -116,6 +147,13 @@ int fl_enum_down(int b) { +const char * fl_clip_image_char_ptr = Fl::clipboard_image; + +const char * fl_clip_plain_text_char_ptr = Fl::clipboard_plain_text; + + + + int fl_abi_check(int v) { return Fl::abi_check(v); } @@ -135,40 +173,6 @@ double fl_version() { -void fl_awake() { - Fl::awake(); -} - -void fl_lock() { - Fl::lock(); -} - -void fl_unlock() { - Fl::unlock(); -} - - - - -int fl_get_damage() { - return Fl::damage(); -} - -void fl_set_damage(int v) { - Fl::damage(v); -} - -void fl_flush() { - Fl::flush(); -} - -void fl_redraw() { - Fl::redraw(); -} - - - - short fl_inside_callback = 0; void fl_delete_widget(void * w) { diff --git a/body/c_fl.h b/body/c_fl.h index f85c36f..88d229d 100644 --- a/body/c_fl.h +++ b/body/c_fl.h @@ -49,6 +49,21 @@ extern "C" const int fl_enum_num_blue; extern "C" const int fl_enum_num_gray; +extern "C" const unsigned int fl_enum_button1; +extern "C" const unsigned int fl_enum_button2; +extern "C" const unsigned int fl_enum_button3; +extern "C" const unsigned int fl_enum_button4; +extern "C" const unsigned int fl_enum_button5; +extern "C" const unsigned int fl_enum_buttons; + + +extern "C" const int fl_enum_left_mouse; +extern "C" const int fl_enum_middle_mouse; +extern "C" const int fl_enum_right_mouse; +extern "C" const int fl_enum_back_mouse; +extern "C" const int fl_enum_forward_mouse; + + extern "C" unsigned int fl_enum_rgb_color2(unsigned char l); extern "C" unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b); extern "C" unsigned int fl_enum_color_cube(int r, int g, int b); @@ -65,23 +80,16 @@ extern "C" int fl_enum_frame(int b); extern "C" int fl_enum_down(int b); +extern "C" const char * fl_clip_image_char_ptr; +extern "C" const char * fl_clip_plain_text_char_ptr; + + extern "C" int fl_abi_check(int v); extern "C" int fl_abi_version(); extern "C" int fl_api_version(); extern "C" double fl_version(); -extern "C" void fl_awake(); -extern "C" void fl_lock(); -extern "C" void fl_unlock(); - - -extern "C" int fl_get_damage(); -extern "C" void fl_set_damage(int v); -extern "C" void fl_flush(); -extern "C" void fl_redraw(); - - extern "C" short fl_inside_callback; extern "C" void fl_delete_widget(void * w); diff --git a/body/c_fl_event.cpp b/body/c_fl_event.cpp index d8760af..d88dfc2 100644 --- a/body/c_fl_event.cpp +++ b/body/c_fl_event.cpp @@ -16,10 +16,14 @@ void fl_event_add_handler(void * f) { Fl::add_handler(reinterpret_cast(f)); } -void fl_event_set_event_dispatch(void * f) { +void fl_event_set_dispatch(void * f) { Fl::event_dispatch(reinterpret_cast(f)); } +int fl_event_handle_dispatch(int e, void * w) { + return Fl::handle(e, static_cast(w)); +} + int fl_event_handle(int e, void * w) { return Fl::handle_(e, static_cast(w)); } @@ -70,6 +74,17 @@ void fl_event_set_visible_focus(int f) { +const char * fl_event_clipboard_text() { + return static_cast(Fl::event_clipboard()); +} + +const char * fl_event_clipboard_type() { + return Fl::event_clipboard_type(); +} + + + + int fl_event_compose(int &d) { return Fl::compose(d); } @@ -86,6 +101,10 @@ int fl_event_length() { return Fl::event_length(); } +int fl_event_test_shortcut(unsigned int s) { + return Fl::test_shortcut(static_cast(s)); +} + @@ -136,7 +155,11 @@ int fl_event_is_click() { return Fl::event_is_click(); } -int fl_event_is_clicks() { +void fl_event_set_click(int c) { + Fl::event_is_click(c); +} + +int fl_event_get_clicks() { return Fl::event_clicks(); } @@ -160,6 +183,30 @@ int fl_event_button3() { return Fl::event_button3(); } +int fl_event_button4() { +#if FL_API_VERSION >= 10310 + return Fl::event_button4(); +#else + return 0; +#endif +} + +int fl_event_button5() { +#if FL_API_VERSION >= 10310 + return Fl::event_button5(); +#else + return 0; +#endif +} + +int fl_event_buttons() { + return Fl::event_buttons(); +} + +int fl_event_inside2(void * c) { + return Fl::event_inside(static_cast(c)); +} + int fl_event_inside(int x, int y, int w, int h) { return Fl::event_inside(x, y, w, h); } diff --git a/body/c_fl_event.h b/body/c_fl_event.h index 34daf2b..0acf999 100644 --- a/body/c_fl_event.h +++ b/body/c_fl_event.h @@ -9,7 +9,8 @@ extern "C" void fl_event_add_handler(void * f); -extern "C" void fl_event_set_event_dispatch(void * f); +extern "C" void fl_event_set_dispatch(void * f); +extern "C" int fl_event_handle_dispatch(int e, void * w); extern "C" int fl_event_handle(int e, void * w); @@ -25,10 +26,15 @@ extern "C" int fl_event_get_visible_focus(); extern "C" void fl_event_set_visible_focus(int f); +extern "C" const char * fl_event_clipboard_text(); +extern "C" const char * fl_event_clipboard_type(); + + extern "C" int fl_event_compose(int &d); extern "C" void fl_event_compose_reset(); extern "C" const char * fl_event_text(); extern "C" int fl_event_length(); +extern "C" int fl_event_test_shortcut(unsigned int s); extern "C" int fl_event_get(); @@ -44,12 +50,17 @@ extern "C" int fl_event_dx(); extern "C" int fl_event_dy(); extern "C" void fl_event_get_mouse(int &x, int &y); extern "C" int fl_event_is_click(); -extern "C" int fl_event_is_clicks(); +extern "C" void fl_event_set_click(int c); +extern "C" int fl_event_get_clicks(); extern "C" void fl_event_set_clicks(int c); extern "C" int fl_event_button(); extern "C" int fl_event_button1(); extern "C" int fl_event_button2(); extern "C" int fl_event_button3(); +extern "C" int fl_event_button4(); +extern "C" int fl_event_button5(); +extern "C" int fl_event_buttons(); +extern "C" int fl_event_inside2(void * c); extern "C" int fl_event_inside(int x, int y, int w, int h); diff --git a/body/c_fl_screen.cpp b/body/c_fl_screen.cpp index d0e8019..7a5fc2f 100644 --- a/body/c_fl_screen.cpp +++ b/body/c_fl_screen.cpp @@ -10,10 +10,22 @@ +const int fl_enum_mode_rgb = FL_RGB; +const int fl_enum_mode_rgb8 = FL_RGB8; +const int fl_enum_mode_double = FL_DOUBLE; +const int fl_enum_mode_index = FL_INDEX; + + + + void fl_screen_display(const char * v) { Fl::display(v); } +int fl_screen_visual(int mode) { + return Fl::visual(mode); +} + @@ -91,3 +103,22 @@ void fl_screen_xywh4(int &x, int &y, int &w, int &h, int px, int py, int pw, int } + + +int fl_screen_get_damage() { + return Fl::damage(); +} + +void fl_screen_set_damage(int v) { + Fl::damage(v); +} + +void fl_screen_flush() { + Fl::flush(); +} + +void fl_screen_redraw() { + Fl::redraw(); +} + + diff --git a/body/c_fl_screen.h b/body/c_fl_screen.h index 8fff58d..c2b0e98 100644 --- a/body/c_fl_screen.h +++ b/body/c_fl_screen.h @@ -8,7 +8,14 @@ #define FL_SCREEN_GUARD +extern "C" const int fl_enum_mode_rgb; +extern "C" const int fl_enum_mode_rgb8; +extern "C" const int fl_enum_mode_double; +extern "C" const int fl_enum_mode_index; + + extern "C" void fl_screen_display(const char * v); +extern "C" int fl_screen_visual(int mode); extern "C" int fl_screen_x(); @@ -36,6 +43,12 @@ extern "C" void fl_screen_xywh3(int &x, int &y, int &w, int &h); extern "C" void fl_screen_xywh4(int &x, int &y, int &w, int &h, int px, int py, int pw, int ph); +extern "C" int fl_screen_get_damage(); +extern "C" void fl_screen_set_damage(int v); +extern "C" void fl_screen_flush(); +extern "C" void fl_screen_redraw(); + + #endif diff --git a/body/c_fl_static.cpp b/body/c_fl_static.cpp index 0b45115..31cb3af 100644 --- a/body/c_fl_static.cpp +++ b/body/c_fl_static.cpp @@ -20,6 +20,18 @@ void fl_static_get_awake_handler(void * &h, void * &f) { Fl::get_awake_handler_(reinterpret_cast(h),f); } +void fl_static_awake() { + Fl::awake(); +} + +void fl_static_lock() { + Fl::lock(); +} + +void fl_static_unlock() { + Fl::unlock(); +} + diff --git a/body/c_fl_static.h b/body/c_fl_static.h index 2622544..c0a6c2f 100644 --- a/body/c_fl_static.h +++ b/body/c_fl_static.h @@ -10,6 +10,9 @@ extern "C" void fl_static_add_awake_handler(void * h, void * f); extern "C" void fl_static_get_awake_handler(void * &h, void * &f); +extern "C" void fl_static_awake(); +extern "C" void fl_static_lock(); +extern "C" void fl_static_unlock(); extern "C" void fl_static_add_check(void * h, void * f); diff --git a/body/fltk-event.adb b/body/fltk-event.adb deleted file mode 100644 index 2c96792..0000000 --- a/body/fltk-event.adb +++ /dev/null @@ -1,748 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Ada.Assertions, - Interfaces.C.Strings; - -use type - - Interfaces.C.int, - Interfaces.C.Strings.chars_ptr; - - -package body FLTK.Event is - - - package Chk renames Ada.Assertions; - - - - - ------------------------ - -- Functions From C -- - ------------------------ - - -- Handlers -- - - procedure fl_event_add_handler - (F : in Storage.Integer_Address); - pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); - pragma Inline (fl_event_add_handler); - - procedure fl_event_set_event_dispatch - (F : in Storage.Integer_Address); - pragma Import (C, fl_event_set_event_dispatch, "fl_event_set_event_dispatch"); - pragma Inline (fl_event_set_event_dispatch); - - -- actually handle_ but can't have an underscore on the end of an identifier - function fl_event_handle - (E : in Interfaces.C.int; - W : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_event_handle, "fl_event_handle"); - pragma Inline (fl_event_handle); - - - - - -- Receiving -- - - function fl_event_get_grab - return Storage.Integer_Address; - pragma Import (C, fl_event_get_grab, "fl_event_get_grab"); - pragma Inline (fl_event_get_grab); - - procedure fl_event_set_grab - (T : in Storage.Integer_Address); - pragma Import (C, fl_event_set_grab, "fl_event_set_grab"); - pragma Inline (fl_event_set_grab); - - function fl_event_get_pushed - return Storage.Integer_Address; - pragma Import (C, fl_event_get_pushed, "fl_event_get_pushed"); - pragma Inline (fl_event_get_pushed); - - procedure fl_event_set_pushed - (T : in Storage.Integer_Address); - pragma Import (C, fl_event_set_pushed, "fl_event_set_pushed"); - pragma Inline (fl_event_set_pushed); - - function fl_event_get_belowmouse - return Storage.Integer_Address; - pragma Import (C, fl_event_get_belowmouse, "fl_event_get_belowmouse"); - pragma Inline (fl_event_get_belowmouse); - - procedure fl_event_set_belowmouse - (T : in Storage.Integer_Address); - pragma Import (C, fl_event_set_belowmouse, "fl_event_set_belowmouse"); - pragma Inline (fl_event_set_belowmouse); - - function fl_event_get_focus - return Storage.Integer_Address; - pragma Import (C, fl_event_get_focus, "fl_event_get_focus"); - pragma Inline (fl_event_get_focus); - - procedure fl_event_set_focus - (To : in Storage.Integer_Address); - pragma Import (C, fl_event_set_focus, "fl_event_set_focus"); - pragma Inline (fl_event_set_focus); - - function fl_event_get_visible_focus - return Interfaces.C.int; - pragma Import (C, fl_event_get_visible_focus, "fl_event_get_visible_focus"); - pragma Inline (fl_event_get_visible_focus); - - procedure fl_event_set_visible_focus - (T : in Interfaces.C.int); - pragma Import (C, fl_event_set_visible_focus, "fl_event_set_visible_focus"); - pragma Inline (fl_event_set_visible_focus); - - - - - -- Multikey -- - - function fl_event_compose - (D : out Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_compose, "fl_event_compose"); - pragma Inline (fl_event_compose); - - function fl_event_text - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_event_text, "fl_event_text"); - pragma Inline (fl_event_text); - - function fl_event_length - return Interfaces.C.int; - pragma Import (C, fl_event_length, "fl_event_length"); - pragma Inline (fl_event_length); - - - - - -- Modifiers -- - - function fl_event_get - return Interfaces.C.int; - pragma Import (C, fl_event_get, "fl_event_get"); - pragma Inline (fl_event_get); - - function fl_event_state - return Interfaces.C.int; - pragma Import (C, fl_event_state, "fl_event_state"); - pragma Inline (fl_event_state); - - function fl_event_check_state - (S : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_check_state, "fl_event_check_state"); - pragma Inline (fl_event_check_state); - - - - - -- Mouse -- - - function fl_event_x - return Interfaces.C.int; - pragma Import (C, fl_event_x, "fl_event_x"); - pragma Inline (fl_event_x); - - function fl_event_x_root - return Interfaces.C.int; - pragma Import (C, fl_event_x_root, "fl_event_x_root"); - pragma Inline (fl_event_x_root); - - function fl_event_y - return Interfaces.C.int; - pragma Import (C, fl_event_y, "fl_event_y"); - pragma Inline (fl_event_y); - - function fl_event_y_root - return Interfaces.C.int; - pragma Import (C, fl_event_y_root, "fl_event_y_root"); - pragma Inline (fl_event_y_root); - - function fl_event_dx - return Interfaces.C.int; - pragma Import (C, fl_event_dx, "fl_event_dx"); - pragma Inline (fl_event_dx); - - function fl_event_dy - return Interfaces.C.int; - pragma Import (C, fl_event_dy, "fl_event_dy"); - pragma Inline (fl_event_dy); - - procedure fl_event_get_mouse - (X, Y : out Interfaces.C.int); - pragma Import (C, fl_event_get_mouse, "fl_event_get_mouse"); - pragma Inline (fl_event_get_mouse); - - function fl_event_is_click - return Interfaces.C.int; - pragma Import (C, fl_event_is_click, "fl_event_is_click"); - pragma Inline (fl_event_is_click); - - function fl_event_is_clicks - return Interfaces.C.int; - pragma Import (C, fl_event_is_clicks, "fl_event_is_clicks"); - pragma Inline (fl_event_is_clicks); - - procedure fl_event_set_clicks - (C : in Interfaces.C.int); - pragma Import (C, fl_event_set_clicks, "fl_event_set_clicks"); - pragma Inline (fl_event_set_clicks); - - function fl_event_button - return Interfaces.C.int; - pragma Import (C, fl_event_button, "fl_event_button"); - pragma Inline (fl_event_button); - - function fl_event_button1 - return Interfaces.C.int; - pragma Import (C, fl_event_button1, "fl_event_button1"); - pragma Inline (fl_event_button1); - - function fl_event_button2 - return Interfaces.C.int; - pragma Import (C, fl_event_button2, "fl_event_button2"); - pragma Inline (fl_event_button2); - - function fl_event_button3 - return Interfaces.C.int; - pragma Import (C, fl_event_button3, "fl_event_button3"); - pragma Inline (fl_event_button3); - - function fl_event_inside - (X, Y, W, H : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_inside, "fl_event_inside"); - pragma Inline (fl_event_inside); - - - - - -- Keyboard -- - - function fl_event_key - return Interfaces.C.int; - pragma Import (C, fl_event_key, "fl_event_key"); - pragma Inline (fl_event_key); - - function fl_event_original_key - return Interfaces.C.int; - pragma Import (C, fl_event_original_key, "fl_event_original_key"); - pragma Inline (fl_event_original_key); - - function fl_event_key_during - (K : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_key_during, "fl_event_key_during"); - pragma Inline (fl_event_key_during); - - function fl_event_get_key - (K : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_get_key, "fl_event_get_key"); - pragma Inline (fl_event_get_key); - - function fl_event_ctrl - return Interfaces.C.int; - pragma Import (C, fl_event_ctrl, "fl_event_ctrl"); - pragma Inline (fl_event_ctrl); - - function fl_event_alt - return Interfaces.C.int; - pragma Import (C, fl_event_alt, "fl_event_alt"); - pragma Inline (fl_event_alt); - - function fl_event_command - return Interfaces.C.int; - pragma Import (C, fl_event_command, "fl_event_command"); - pragma Inline (fl_event_command); - - function fl_event_shift - return Interfaces.C.int; - pragma Import (C, fl_event_shift, "fl_event_shift"); - pragma Inline (fl_event_shift); - - - - - ------------- - -- Hooks -- - ------------- - - function Event_Handler_Hook - (Num : in Interfaces.C.int) - return Interfaces.C.int - is - Ret_Val : Event_Outcome; - begin - for Func of reverse Handlers loop - Ret_Val := Func (Event_Kind'Val (Num)); - if Ret_Val /= Not_Handled then - return Event_Outcome'Pos (Ret_Val); - end if; - end loop; - return Event_Outcome'Pos (Not_Handled); - end Event_Handler_Hook; - - - -- function Dispatch_Hook - -- (Num : in Interfaces.C.int; - -- Ptr : in Storage.Integer_Address) - -- return Interfaces.C.int - -- is - -- Ret_Val : Event_Outcome; - -- Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; - -- begin - -- if Ptr /= Null_Pointer then - -- Actual_Window := Window_Convert.To_Pointer - -- (Storage.To_Address (fl_widget_get_user_data (Ptr))); - -- end if; - -- if Current_Dispatch = null then - -- Ret_Val := Default_Dispatch (Event_Kind'Val (Num), Actual_Window); - -- else - -- Ret_Val := Current_Dispatch (Event_Kind'Val (Num), Actual_Window); - -- end if; - -- return Event_Outcome'Pos (Ret_Val); - -- end Dispatch_Hook; - - - - - ----------------------- - -- API Subprograms -- - ----------------------- - - -- Handlers -- - - procedure Add_Handler - (Func : in Event_Handler) is - begin - Handlers.Append (Func); - end Add_Handler; - - - procedure Remove_Handler - (Func : in Event_Handler) is - begin - for I in reverse Handlers.First_Index .. Handlers.Last_Index loop - if Handlers (I) = Func then - Handlers.Delete (I); - return; - end if; - end loop; - end Remove_Handler; - - - -- function Get_Dispatch - -- return Event_Dispatch is - -- begin - -- if Current_Dispatch = null then - -- return Default_Dispatch'Access; - -- else - -- return Current_Dispatch; - -- end if; - -- end Get_Dispatch; - - - -- procedure Set_Dispatch - -- (Func : in Event_Dispatch) is - -- begin - -- Current_Dispatch := Func; - -- end Set_Dispatch; - - - -- function Default_Dispatch - -- (Event : in Event_Kind; - -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) - -- return Event_Outcome is - -- begin - -- if Win = null then - -- return Event_Outcome'Val (fl_event_handle - -- (Event_Kind'Pos (Event), Null_Pointer)); - -- else - -- return Event_Outcome'Val (fl_event_handle - -- (Event_Kind'Pos (Event), - -- Wrapper (Win.all).Void_Ptr)); - -- end if; - -- end Default_Dispatch; - - - - - -- Receiving -- - - function Get_Grab - return access FLTK.Widgets.Groups.Windows.Window'Class - is - Grab_Ptr : Storage.Integer_Address := fl_event_get_grab; - Actual_Grab : access FLTK.Widgets.Groups.Windows.Window'Class; - begin - if Grab_Ptr /= Null_Pointer then - Grab_Ptr := fl_widget_get_user_data (Grab_Ptr); - pragma Assert (Grab_Ptr /= Null_Pointer); - Actual_Grab := Window_Convert.To_Pointer (Storage.To_Address (Grab_Ptr)); - end if; - return Actual_Grab; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Widget returned by Fl::grab did not have user_data reference back to Ada"; - end Get_Grab; - - - procedure Set_Grab - (To : in FLTK.Widgets.Groups.Windows.Window'Class) is - begin - fl_event_set_grab (Wrapper (To).Void_Ptr); - end Set_Grab; - - - procedure Release_Grab is - begin - fl_event_set_grab (Null_Pointer); - end Release_Grab; - - - function Get_Pushed - return access FLTK.Widgets.Widget'Class - is - Pushed_Ptr : Storage.Integer_Address := fl_event_get_pushed; - Actual_Pushed : access FLTK.Widgets.Widget'Class; - begin - if Pushed_Ptr /= Null_Pointer then - Pushed_Ptr := fl_widget_get_user_data (Pushed_Ptr); - pragma Assert (Pushed_Ptr /= Null_Pointer); - Actual_Pushed := Widget_Convert.To_Pointer (Storage.To_Address (Pushed_Ptr)); - end if; - return Actual_Pushed; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Widget returned by Fl::pushed did not have user_data reference back to Ada"; - end Get_Pushed; - - - procedure Set_Pushed - (To : in FLTK.Widgets.Widget'Class) is - begin - fl_event_set_pushed (Wrapper (To).Void_Ptr); - end Set_Pushed; - - - function Get_Below_Mouse - return access FLTK.Widgets.Widget'Class - is - Below_Ptr : Storage.Integer_Address := fl_event_get_belowmouse; - Actual_Below : access FLTK.Widgets.Widget'Class; - begin - if Below_Ptr /= Null_Pointer then - Below_Ptr := fl_widget_get_user_data (Below_Ptr); - pragma Assert (Below_Ptr /= Null_Pointer); - Actual_Below := Widget_Convert.To_Pointer (Storage.To_Address (Below_Ptr)); - end if; - return Actual_Below; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Widget returned by Fl::belowmouse did not have user_data reference back to Ada"; - end Get_Below_Mouse; - - - procedure Set_Below_Mouse - (To : in FLTK.Widgets.Widget'Class) is - begin - fl_event_set_belowmouse (Wrapper (To).Void_Ptr); - end Set_Below_Mouse; - - - function Get_Focus - return access FLTK.Widgets.Widget'Class - is - Focus_Ptr : Storage.Integer_Address := fl_event_get_focus; - Actual_Focus : access FLTK.Widgets.Widget'Class; - begin - if Focus_Ptr /= Null_Pointer then - Focus_Ptr := fl_widget_get_user_data (Focus_Ptr); - pragma Assert (Focus_Ptr /= Null_Pointer); - Actual_Focus := Widget_Convert.To_Pointer (Storage.To_Address (Focus_Ptr)); - end if; - return Actual_Focus; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Widget returned by Fl::focus did not have user_data reference back to Ada"; - end Get_Focus; - - - procedure Set_Focus - (To : in FLTK.Widgets.Widget'Class) is - begin - fl_event_set_focus (Wrapper (To).Void_Ptr); - end Set_Focus; - - - function Has_Visible_Focus - return Boolean is - begin - return fl_event_get_visible_focus /= 0; - end Has_Visible_Focus; - - - procedure Set_Visible_Focus - (To : in Boolean) is - begin - fl_event_set_visible_focus (Boolean'Pos (To)); - end Set_Visible_Focus; - - - - - -- Multikey -- - - function Compose - (Del : out Natural) - return Boolean is - begin - return fl_event_compose (Interfaces.C.int (Del)) /= 0; - end Compose; - - - function Text - return String - is - Str : Interfaces.C.Strings.chars_ptr := fl_event_text; - begin - if Str = Interfaces.C.Strings.Null_Ptr then - return ""; - else - return Interfaces.C.Strings.Value (Str, Interfaces.C.size_t (fl_event_length)); - end if; - end Text; - - - function Text_Length - return Natural is - begin - return Natural (fl_event_length); - end Text_Length; - - - - - -- Modifiers -- - - function Last - return Event_Kind is - begin - return Event_Kind'Val (fl_event_get); - end Last; - - - function Last_Modifier - return Modifier is - begin - return To_Ada (fl_event_state); - end Last_Modifier; - - - function Last_Modifier - (Had : in Modifier) - return Boolean is - begin - return fl_event_check_state (To_C (Had)) /= 0; - end Last_Modifier; - - - - - -- Mouse -- - - function Mouse_X - return Integer is - begin - return Integer (fl_event_x); - end Mouse_X; - - - function Mouse_X_Root - return Integer is - begin - return Integer (fl_event_x_root); - end Mouse_X_Root; - - - function Mouse_Y - return Integer is - begin - return Integer (fl_event_y); - end Mouse_Y; - - - function Mouse_Y_Root - return Integer is - begin - return Integer (fl_event_y_root); - end Mouse_Y_Root; - - - - function Mouse_DX - return Integer is - begin - return Integer (fl_event_dx); - end Mouse_DX; - - - function Mouse_DY - return Integer is - begin - return Integer (fl_event_dy); - end Mouse_DY; - - - procedure Get_Mouse - (X, Y : out Integer) is - begin - fl_event_get_mouse (Interfaces.C.int (X), Interfaces.C.int (Y)); - end Get_Mouse; - - - function Is_Click - return Boolean is - begin - return fl_event_is_click /= 0; - end Is_Click; - - - function Is_Multi_Click - return Boolean is - begin - return fl_event_is_clicks /= 0; - end Is_Multi_Click; - - - procedure Set_Clicks - (To : in Natural) is - begin - fl_event_set_clicks (Interfaces.C.int (To)); - end Set_Clicks; - - - function Last_Button - return Mouse_Button is - begin - return Mouse_Button'Val (fl_event_button); - end Last_Button; - - - function Mouse_Left - return Boolean is - begin - return fl_event_button1 /= 0; - end Mouse_Left; - - - function Mouse_Middle - return Boolean is - begin - return fl_event_button2 /= 0; - end Mouse_Middle; - - - function Mouse_Right - return Boolean is - begin - return fl_event_button3 /= 0; - end Mouse_Right; - - - function Is_Inside - (X, Y, W, H : in Integer) - return Boolean is - begin - return fl_event_inside - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H)) /= 0; - end Is_Inside; - - - - - -- Keyboard -- - - function Last_Key - return Keypress is - begin - return To_Ada (fl_event_key); - end Last_Key; - - - function Original_Last_Key - return Keypress is - begin - return To_Ada (fl_event_original_key); - end Original_Last_Key; - - - function Pressed_During - (Key : in Keypress) - return Boolean is - begin - return fl_event_key_during (To_C (Key)) /= 0; - end Pressed_During; - - - function Key_Now - (Key : in Keypress) - return Boolean is - begin - return fl_event_get_key (To_C (Key)) /= 0; - end Key_Now; - - - function Key_Ctrl - return Boolean is - begin - return fl_event_ctrl /= 0; - end Key_Ctrl; - - - function Key_Alt - return Boolean is - begin - return fl_event_alt /= 0; - end Key_Alt; - - - function Key_Command - return Boolean is - begin - return fl_event_command /= 0; - end Key_Command; - - - function Key_Shift - return Boolean is - begin - return fl_event_shift /= 0; - end Key_Shift; - - -begin - - - fl_event_add_handler (Storage.To_Integer (Event_Handler_Hook'Address)); - -- fl_event_set_event_dispatch (Storage.To_Integer (Dispatch_Hook'Address)); - - -end FLTK.Event; - - diff --git a/body/fltk-events.adb b/body/fltk-events.adb new file mode 100644 index 0000000..a15c55b --- /dev/null +++ b/body/fltk-events.adb @@ -0,0 +1,988 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Events is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Constants From C -- + ------------------------ + + fl_enum_button1 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button1, "fl_enum_button1"); + + fl_enum_button2 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button2, "fl_enum_button2"); + + fl_enum_button3 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button3, "fl_enum_button3"); + + fl_enum_button4 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button4, "fl_enum_button4"); + + fl_enum_button5 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button5, "fl_enum_button5"); + + fl_enum_left_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_left_mouse, "fl_enum_left_mouse"); + + fl_enum_middle_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_middle_mouse, "fl_enum_middle_mouse"); + + fl_enum_right_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_right_mouse, "fl_enum_right_mouse"); + + fl_enum_back_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_back_mouse, "fl_enum_back_mouse"); + + fl_enum_forward_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_forward_mouse, "fl_enum_forward_mouse"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Handlers -- + + procedure fl_event_add_handler + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); + pragma Inline (fl_event_add_handler); + + procedure fl_event_set_dispatch + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_set_dispatch, "fl_event_set_dispatch"); + pragma Inline (fl_event_set_dispatch); + + function fl_event_handle_dispatch + (E : in Interfaces.C.int; + W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_handle_dispatch, "fl_event_handle_dispatch"); + pragma Inline (fl_event_handle_dispatch); + + function fl_event_handle + (E : in Interfaces.C.int; + W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_handle, "fl_event_handle"); + pragma Inline (fl_event_handle); + + + + + -- Receiving -- + + function fl_event_get_grab + return Storage.Integer_Address; + pragma Import (C, fl_event_get_grab, "fl_event_get_grab"); + pragma Inline (fl_event_get_grab); + + procedure fl_event_set_grab + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_grab, "fl_event_set_grab"); + pragma Inline (fl_event_set_grab); + + function fl_event_get_pushed + return Storage.Integer_Address; + pragma Import (C, fl_event_get_pushed, "fl_event_get_pushed"); + pragma Inline (fl_event_get_pushed); + + procedure fl_event_set_pushed + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_pushed, "fl_event_set_pushed"); + pragma Inline (fl_event_set_pushed); + + function fl_event_get_belowmouse + return Storage.Integer_Address; + pragma Import (C, fl_event_get_belowmouse, "fl_event_get_belowmouse"); + pragma Inline (fl_event_get_belowmouse); + + procedure fl_event_set_belowmouse + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_belowmouse, "fl_event_set_belowmouse"); + pragma Inline (fl_event_set_belowmouse); + + function fl_event_get_focus + return Storage.Integer_Address; + pragma Import (C, fl_event_get_focus, "fl_event_get_focus"); + pragma Inline (fl_event_get_focus); + + procedure fl_event_set_focus + (To : in Storage.Integer_Address); + pragma Import (C, fl_event_set_focus, "fl_event_set_focus"); + pragma Inline (fl_event_set_focus); + + function fl_event_get_visible_focus + return Interfaces.C.int; + pragma Import (C, fl_event_get_visible_focus, "fl_event_get_visible_focus"); + pragma Inline (fl_event_get_visible_focus); + + procedure fl_event_set_visible_focus + (T : in Interfaces.C.int); + pragma Import (C, fl_event_set_visible_focus, "fl_event_set_visible_focus"); + pragma Inline (fl_event_set_visible_focus); + + + + + -- Clipboard -- + + function fl_event_clipboard_text + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_clipboard_text, "fl_event_clipboard_text"); + pragma Inline (fl_event_clipboard_text); + + function fl_event_clipboard_type + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_clipboard_type, "fl_event_clipboard_type"); + pragma Inline (fl_event_clipboard_type); + + + + + -- Multikey -- + + function fl_event_compose + (D : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_compose, "fl_event_compose"); + pragma Inline (fl_event_compose); + + function fl_event_text + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_text, "fl_event_text"); + pragma Inline (fl_event_text); + + function fl_event_length + return Interfaces.C.int; + pragma Import (C, fl_event_length, "fl_event_length"); + pragma Inline (fl_event_length); + + function fl_event_test_shortcut + (S : in Interfaces.C.unsigned) + return Interfaces.C.int; + pragma Import (C, fl_event_test_shortcut, "fl_event_test_shortcut"); + pragma Inline (fl_event_test_shortcut); + + + + + -- Modifiers -- + + function fl_event_get + return Interfaces.C.int; + pragma Import (C, fl_event_get, "fl_event_get"); + pragma Inline (fl_event_get); + + function fl_event_state + return Interfaces.C.int; + pragma Import (C, fl_event_state, "fl_event_state"); + pragma Inline (fl_event_state); + + function fl_event_check_state + (S : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_check_state, "fl_event_check_state"); + pragma Inline (fl_event_check_state); + + + + + -- Mouse -- + + function fl_event_x + return Interfaces.C.int; + pragma Import (C, fl_event_x, "fl_event_x"); + pragma Inline (fl_event_x); + + function fl_event_x_root + return Interfaces.C.int; + pragma Import (C, fl_event_x_root, "fl_event_x_root"); + pragma Inline (fl_event_x_root); + + function fl_event_y + return Interfaces.C.int; + pragma Import (C, fl_event_y, "fl_event_y"); + pragma Inline (fl_event_y); + + function fl_event_y_root + return Interfaces.C.int; + pragma Import (C, fl_event_y_root, "fl_event_y_root"); + pragma Inline (fl_event_y_root); + + function fl_event_dx + return Interfaces.C.int; + pragma Import (C, fl_event_dx, "fl_event_dx"); + pragma Inline (fl_event_dx); + + function fl_event_dy + return Interfaces.C.int; + pragma Import (C, fl_event_dy, "fl_event_dy"); + pragma Inline (fl_event_dy); + + procedure fl_event_get_mouse + (X, Y : out Interfaces.C.int); + pragma Import (C, fl_event_get_mouse, "fl_event_get_mouse"); + pragma Inline (fl_event_get_mouse); + + function fl_event_is_click + return Interfaces.C.int; + pragma Import (C, fl_event_is_click, "fl_event_is_click"); + pragma Inline (fl_event_is_click); + + procedure fl_event_set_click + (C : in Interfaces.C.int); + pragma Import (C, fl_event_set_click, "fl_event_set_click"); + pragma Inline (fl_event_set_click); + + function fl_event_get_clicks + return Interfaces.C.int; + pragma Import (C, fl_event_get_clicks, "fl_event_get_clicks"); + pragma Inline (fl_event_get_clicks); + + procedure fl_event_set_clicks + (C : in Interfaces.C.int); + pragma Import (C, fl_event_set_clicks, "fl_event_set_clicks"); + pragma Inline (fl_event_set_clicks); + + function fl_event_button + return Interfaces.C.int; + pragma Import (C, fl_event_button, "fl_event_button"); + pragma Inline (fl_event_button); + + function fl_event_button1 + return Interfaces.C.int; + pragma Import (C, fl_event_button1, "fl_event_button1"); + pragma Inline (fl_event_button1); + + function fl_event_button2 + return Interfaces.C.int; + pragma Import (C, fl_event_button2, "fl_event_button2"); + pragma Inline (fl_event_button2); + + function fl_event_button3 + return Interfaces.C.int; + pragma Import (C, fl_event_button3, "fl_event_button3"); + pragma Inline (fl_event_button3); + + function fl_event_button4 + return Interfaces.C.int; + pragma Import (C, fl_event_button4, "fl_event_button4"); + pragma Inline (fl_event_button4); + + function fl_event_button5 + return Interfaces.C.int; + pragma Import (C, fl_event_button5, "fl_event_button5"); + pragma Inline (fl_event_button5); + + function fl_event_buttons + return Interfaces.C.int; + pragma Import (C, fl_event_buttons, "fl_event_buttons"); + pragma Inline (fl_event_buttons); + + function fl_event_inside2 + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_inside2, "fl_event_inside2"); + pragma Inline (fl_event_inside2); + + function fl_event_inside + (X, Y, W, H : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_inside, "fl_event_inside"); + pragma Inline (fl_event_inside); + + + + + -- Keyboard -- + + function fl_event_key + return Interfaces.C.int; + pragma Import (C, fl_event_key, "fl_event_key"); + pragma Inline (fl_event_key); + + function fl_event_original_key + return Interfaces.C.int; + pragma Import (C, fl_event_original_key, "fl_event_original_key"); + pragma Inline (fl_event_original_key); + + function fl_event_key_during + (K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_key_during, "fl_event_key_during"); + pragma Inline (fl_event_key_during); + + function fl_event_get_key + (K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_get_key, "fl_event_get_key"); + pragma Inline (fl_event_get_key); + + function fl_event_ctrl + return Interfaces.C.int; + pragma Import (C, fl_event_ctrl, "fl_event_ctrl"); + pragma Inline (fl_event_ctrl); + + function fl_event_alt + return Interfaces.C.int; + pragma Import (C, fl_event_alt, "fl_event_alt"); + pragma Inline (fl_event_alt); + + function fl_event_command + return Interfaces.C.int; + pragma Import (C, fl_event_command, "fl_event_command"); + pragma Inline (fl_event_command); + + function fl_event_shift + return Interfaces.C.int; + pragma Import (C, fl_event_shift, "fl_event_shift"); + pragma Inline (fl_event_shift); + + + + + ------------- + -- Hooks -- + ------------- + + function Event_Handler_Hook + (Num : in Interfaces.C.int) + return Interfaces.C.int + is + Ret_Val : Event_Outcome; + begin + for Func of reverse Handlers loop + Ret_Val := Func (Event_Kind'Val (Num)); + if Ret_Val /= Not_Handled then + return Event_Outcome'Pos (Ret_Val); + end if; + end loop; + return Event_Outcome'Pos (Not_Handled); + end Event_Handler_Hook; + + + function Dispatch_Hook + (Num : in Interfaces.C.int; + Ptr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Ptr : Storage.Integer_Address; + Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Ptr /= Null_Pointer then + Ada_Ptr := fl_widget_get_user_data (Ptr); + pragma Assert (Ada_Ptr /= Null_Pointer); + Actual_Window := Window_Convert.To_Pointer (Storage.To_Address (Ada_Ptr)); + end if; + return Event_Outcome'Pos (Current_Dispatch (Event_Kind'Val (Num), Actual_Window)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Window passed to Event_Dispatch hook did not have user_data pointer back to Ada"; + when Constraint_Error => raise Internal_FLTK_Error with + "Event_Dispatch hook passed unexpected event int value of " & + Interfaces.C.int'Image (Num); + end Dispatch_Hook; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Handlers -- + + procedure Add_Handler + (Func : in Event_Handler) is + begin + Handlers.Append (Func); + end Add_Handler; + + + procedure Remove_Handler + (Func : in Event_Handler) is + begin + for I in reverse Handlers.First_Index .. Handlers.Last_Index loop + if Handlers (I) = Func then + Handlers.Delete (I); + return; + end if; + end loop; + end Remove_Handler; + + + function Get_Dispatch + return Event_Dispatch is + begin + return Current_Dispatch; + end Get_Dispatch; + + + procedure Set_Dispatch + (Func : in Event_Dispatch) is + begin + Current_Dispatch := Func; + if Current_Dispatch /= null then + fl_event_set_dispatch (Storage.To_Integer (Dispatch_Hook'Address)); + else + fl_event_set_dispatch (Null_Pointer); + end if; + end Set_Dispatch; + + + function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome + is + Result : Interfaces.C.int := fl_event_handle_dispatch + (Event_Kind'Pos (Event), + Wrapper (Origin).Void_Ptr); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::handle returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Handle_Dispatch; + + + function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome + is + Result : Interfaces.C.int := fl_event_handle + (Event_Kind'Pos (Event), + Wrapper (Origin).Void_Ptr); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::handle_ returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Handle; + + + + + -- Receiving -- + + function Get_Grab + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Grab_Ptr : Storage.Integer_Address := fl_event_get_grab; + Actual_Grab : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Grab_Ptr /= Null_Pointer then + Grab_Ptr := fl_widget_get_user_data (Grab_Ptr); + pragma Assert (Grab_Ptr /= Null_Pointer); + Actual_Grab := Window_Convert.To_Pointer (Storage.To_Address (Grab_Ptr)); + end if; + return Actual_Grab; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::grab did not have user_data reference back to Ada"; + end Get_Grab; + + + procedure Set_Grab + (To : in FLTK.Widgets.Groups.Windows.Window'Class) is + begin + fl_event_set_grab (Wrapper (To).Void_Ptr); + end Set_Grab; + + + procedure Release_Grab is + begin + fl_event_set_grab (Null_Pointer); + end Release_Grab; + + + function Get_Pushed + return access FLTK.Widgets.Widget'Class + is + Pushed_Ptr : Storage.Integer_Address := fl_event_get_pushed; + Actual_Pushed : access FLTK.Widgets.Widget'Class; + begin + if Pushed_Ptr /= Null_Pointer then + Pushed_Ptr := fl_widget_get_user_data (Pushed_Ptr); + pragma Assert (Pushed_Ptr /= Null_Pointer); + Actual_Pushed := Widget_Convert.To_Pointer (Storage.To_Address (Pushed_Ptr)); + end if; + return Actual_Pushed; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::pushed did not have user_data reference back to Ada"; + end Get_Pushed; + + + procedure Set_Pushed + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_pushed (Wrapper (To).Void_Ptr); + end Set_Pushed; + + + function Get_Below_Mouse + return access FLTK.Widgets.Widget'Class + is + Below_Ptr : Storage.Integer_Address := fl_event_get_belowmouse; + Actual_Below : access FLTK.Widgets.Widget'Class; + begin + if Below_Ptr /= Null_Pointer then + Below_Ptr := fl_widget_get_user_data (Below_Ptr); + pragma Assert (Below_Ptr /= Null_Pointer); + Actual_Below := Widget_Convert.To_Pointer (Storage.To_Address (Below_Ptr)); + end if; + return Actual_Below; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::belowmouse did not have user_data reference back to Ada"; + end Get_Below_Mouse; + + + procedure Set_Below_Mouse + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_belowmouse (Wrapper (To).Void_Ptr); + end Set_Below_Mouse; + + + function Get_Focus + return access FLTK.Widgets.Widget'Class + is + Focus_Ptr : Storage.Integer_Address := fl_event_get_focus; + Actual_Focus : access FLTK.Widgets.Widget'Class; + begin + if Focus_Ptr /= Null_Pointer then + Focus_Ptr := fl_widget_get_user_data (Focus_Ptr); + pragma Assert (Focus_Ptr /= Null_Pointer); + Actual_Focus := Widget_Convert.To_Pointer (Storage.To_Address (Focus_Ptr)); + end if; + return Actual_Focus; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::focus did not have user_data reference back to Ada"; + end Get_Focus; + + + procedure Set_Focus + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_focus (Wrapper (To).Void_Ptr); + end Set_Focus; + + + function Has_Visible_Focus + return Boolean is + begin + return fl_event_get_visible_focus /= 0; + end Has_Visible_Focus; + + + procedure Set_Visible_Focus + (To : in Boolean) is + begin + fl_event_set_visible_focus (Boolean'Pos (To)); + end Set_Visible_Focus; + + + + + -- Clipboard -- + + function Clipboard_Text + return String + is + Text_Ptr : Interfaces.C.Strings.chars_ptr := fl_event_clipboard_text; + begin + if Text_Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text_Ptr); + end if; + end Clipboard_Text; + + + function Clipboard_Kind + return String + is + Text_Ptr : Interfaces.C.Strings.chars_ptr := fl_event_clipboard_type; + begin + if Text_Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text_Ptr); + end if; + end Clipboard_Kind; + + + + + -- Multikey -- + + function Compose + (Del : out Natural) + return Boolean is + begin + return fl_event_compose (Interfaces.C.int (Del)) /= 0; + end Compose; + + + function Text + return String + is + Str : Interfaces.C.Strings.chars_ptr := fl_event_text; + begin + if Str = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Str, Interfaces.C.size_t (fl_event_length)); + end if; + end Text; + + + function Text_Length + return Natural is + begin + return Natural (fl_event_length); + end Text_Length; + + + function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean is + begin + return fl_event_test_shortcut (To_C (Shortcut)) /= 0; + end Test_Shortcut; + + + + + -- Modifiers -- + + function Last + return Event_Kind + is + Value : Interfaces.C.int := fl_event_get; + begin + return Event_Kind'Val (Value); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event returned unexpected int value of " & Interfaces.C.int'Image (Value); + end Last; + + + function Last_Modifier + return Modifier is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_state)); + end Last_Modifier; + + + function Last_Modifier + (Had : in Modifier) + return Boolean is + begin + return fl_event_check_state (Interfaces.C.int (To_C (Had))) /= 0; + end Last_Modifier; + + + + + -- Mouse -- + + function Mouse_X + return Integer is + begin + return Integer (fl_event_x); + end Mouse_X; + + + function Mouse_X_Root + return Integer is + begin + return Integer (fl_event_x_root); + end Mouse_X_Root; + + + function Mouse_Y + return Integer is + begin + return Integer (fl_event_y); + end Mouse_Y; + + + function Mouse_Y_Root + return Integer is + begin + return Integer (fl_event_y_root); + end Mouse_Y_Root; + + + + function Mouse_DX + return Integer is + begin + return Integer (fl_event_dx); + end Mouse_DX; + + + function Mouse_DY + return Integer is + begin + return Integer (fl_event_dy); + end Mouse_DY; + + + procedure Get_Mouse + (X, Y : out Integer) is + begin + fl_event_get_mouse (Interfaces.C.int (X), Interfaces.C.int (Y)); + end Get_Mouse; + + + function Is_Click + return Boolean is + begin + return fl_event_is_click /= 0; + end Is_Click; + + + procedure Clear_Click is + begin + fl_event_set_click (0); + end Clear_Click; + + + function Is_Multi_Click + return Boolean is + begin + return fl_event_get_clicks /= 0; + end Is_Multi_Click; + + + function Get_Clicks + return Natural + is + Raw : Interfaces.C.int := fl_event_get_clicks; + begin + if Is_Click then + return Positive (Raw + 1); + else + return 0; + end if; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event_clicks returned unexpected int value of " & + Interfaces.C.int'Image (Raw); + end Get_Clicks; + + + procedure Set_Clicks + (To : in Natural) is + begin + if To = 0 then + fl_event_set_clicks (0); + Clear_Click; + elsif To = 1 then + fl_event_set_clicks (0); + else + fl_event_set_clicks (Interfaces.C.int (To) - 1); + end if; + end Set_Clicks; + + + function Last_Button + return Mouse_Button + is + Code : Interfaces.C.int := fl_event_button; + begin + pragma Assert (Last = Push or Last = Release); + if Code = fl_enum_left_mouse then + return Left_Button; + elsif Code = fl_enum_middle_mouse then + return Middle_Button; + elsif Code = fl_enum_right_mouse then + return Right_Button; + elsif Code = fl_enum_back_mouse then + return Back_Button; + elsif Code = fl_enum_forward_mouse then + return Forward_Button; + else + raise Internal_FLTK_Error with "Fl::event_button returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::event_button was called when the most recent event was not Push or Release"; + end Last_Button; + + + function Mouse_Left + return Boolean is + begin + return fl_event_button1 /= 0; + end Mouse_Left; + + + function Mouse_Middle + return Boolean is + begin + return fl_event_button2 /= 0; + end Mouse_Middle; + + + function Mouse_Right + return Boolean is + begin + return fl_event_button3 /= 0; + end Mouse_Right; + + + function Mouse_Back + return Boolean is + begin + return fl_event_button4 /= 0; + end Mouse_Back; + + + function Mouse_Forward + return Boolean is + begin + return fl_event_button5 /= 0; + end Mouse_Forward; + + + procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean) + is + type Cint_Mod is mod 2 ** Interfaces.C.int'Size; + Mask : Interfaces.C.int := fl_event_buttons; + begin + Left := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button1)) /= 0; + Middle := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button2)) /= 0; + Right := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button3)) /= 0; + Back := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button4)) /= 0; + Forward := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button5)) /= 0; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event_buttons returned unexpected int value of " & + Interfaces.C.int'Image (Mask); + end Mouse_Buttons; + + + function Is_Inside + (Child : in FLTK.Widgets.Widget'Class) + return Boolean is + begin + return fl_event_inside2 (Wrapper (Child).Void_Ptr) /= 0; + end Is_Inside; + + + function Is_Inside + (X, Y, W, H : in Integer) + return Boolean is + begin + return fl_event_inside + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)) /= 0; + end Is_Inside; + + + + + -- Keyboard -- + + function Last_Key + return Keypress is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_key)); + end Last_Key; + + + function Original_Last_Key + return Keypress is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_original_key)); + end Original_Last_Key; + + + function Pressed_During + (Key : in Keypress) + return Boolean is + begin + return fl_event_key_during (Interfaces.C.int (To_C (Key))) /= 0; + end Pressed_During; + + + function Key_Now + (Key : in Keypress) + return Boolean is + begin + return fl_event_get_key (Interfaces.C.int (To_C (Key))) /= 0; + end Key_Now; + + + function Key_Ctrl + return Boolean is + begin + return fl_event_ctrl /= 0; + end Key_Ctrl; + + + function Key_Alt + return Boolean is + begin + return fl_event_alt /= 0; + end Key_Alt; + + + function Key_Command + return Boolean is + begin + return fl_event_command /= 0; + end Key_Command; + + + function Key_Shift + return Boolean is + begin + return fl_event_shift /= 0; + end Key_Shift; + + +begin + + + fl_event_add_handler (Storage.To_Integer (Event_Handler_Hook'Address)); + + +end FLTK.Events; + + diff --git a/body/fltk-menu_items.adb b/body/fltk-menu_items.adb index 7ee4d61..dfb579a 100644 --- a/body/fltk-menu_items.adb +++ b/body/fltk-menu_items.adb @@ -297,7 +297,7 @@ package body FLTK.Menu_Items is This.Void_Ptr := new_fl_menu_item (Interfaces.C.To_C (Text), Callback_Convert.To_Address (Action), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), MFlag_To_Cint (Flags)); end return; end Create; @@ -536,7 +536,7 @@ package body FLTK.Menu_Items is (This : in Menu_Item) return Key_Combo is begin - return To_Ada (fl_menu_item_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_menu_item_get_shortcut (This.Void_Ptr))); end Get_Shortcut; diff --git a/body/fltk-screen.adb b/body/fltk-screen.adb index 89f7413..6b8118e 100644 --- a/body/fltk-screen.adb +++ b/body/fltk-screen.adb @@ -16,6 +16,25 @@ use type package body FLTK.Screen is + ------------------------ + -- Constants From C -- + ------------------------ + + fl_enum_mode_rgb : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_rgb, "fl_enum_mode_rgb"); + + fl_enum_mode_rgb8 : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_rgb8, "fl_enum_mode_rgb8"); + + fl_enum_mode_double : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_double, "fl_enum_mode_double"); + + fl_enum_mode_index : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_index, "fl_enum_mode_index"); + + + + ------------------------ -- Functions From C -- ------------------------ @@ -27,6 +46,12 @@ package body FLTK.Screen is pragma Import (C, fl_screen_display, "fl_screen_display"); pragma Inline (fl_screen_display); + function fl_screen_visual + (F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_screen_visual, "fl_screen_visual"); + pragma Inline (fl_screen_visual); + @@ -133,6 +158,21 @@ package body FLTK.Screen is + -- Drawing -- + + function fl_screen_get_damage + return Interfaces.C.int; + pragma Import (C, fl_screen_get_damage, "fl_screen_get_damage"); + pragma Inline (fl_screen_get_damage); + + procedure fl_screen_set_damage + (V : in Interfaces.C.int); + pragma Import (C, fl_screen_set_damage, "fl_screen_set_damage"); + pragma Inline (fl_screen_set_damage); + + + + ----------------------- -- API Subprograms -- ----------------------- @@ -146,6 +186,29 @@ package body FLTK.Screen is end Set_Display_String; + procedure Set_Visual_Mode + (Value : in Visual_Mode) + is + Ignore : Boolean := Set_Visual_Mode (Value); + begin + null; + end Set_Visual_Mode; + + + function Set_Visual_Mode + (Value : in Visual_Mode) + return Boolean is + begin + return fl_screen_visual + ((case Value is + when RGB => fl_enum_mode_rgb, + when RGB_24bit => fl_enum_mode_rgb8, + when Double_Buffer => fl_enum_mode_double + fl_enum_mode_index, + when Double_RGB => fl_enum_mode_double + fl_enum_mode_rgb, + when Double_RGB_24bit => fl_enum_mode_double + fl_enum_mode_rgb8)) /= 0; + end Set_Visual_Mode; + + -- Basic Dimensions -- @@ -318,6 +381,24 @@ package body FLTK.Screen is end Bounding_Rect; + + + -- Drawing -- + + function Is_Damaged + return Boolean is + begin + return fl_screen_get_damage /= 0; + end Is_Damaged; + + + procedure Set_Damaged + (To : in Boolean) is + begin + fl_screen_set_damage (Boolean'Pos (To)); + end Set_Damaged; + + end FLTK.Screen; diff --git a/body/fltk-widgets-buttons.adb b/body/fltk-widgets-buttons.adb index d6e587e..bc78d8d 100644 --- a/body/fltk-widgets-buttons.adb +++ b/body/fltk-widgets-buttons.adb @@ -293,7 +293,7 @@ package body FLTK.Widgets.Buttons is (This : in Button) return Key_Combo is begin - return To_Ada (fl_button_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_button_get_shortcut (This.Void_Ptr))); end Get_Shortcut; diff --git a/body/fltk-widgets-groups-text_displays-text_editors.adb b/body/fltk-widgets-groups-text_displays-text_editors.adb index 906edef..680d3be 100644 --- a/body/fltk-widgets-groups-text_displays-text_editors.adb +++ b/body/fltk-widgets-groups-text_displays-text_editors.adb @@ -8,7 +8,7 @@ with Ada.Assertions, Ada.Characters.Latin_1, - FLTK.Event, + FLTK.Events, Interfaces.C; @@ -476,8 +476,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is Editor_Ptr : Storage.Integer_Address := fl_widget_get_user_data (E); Ada_Editor : access Text_Editor'Class; - Extra_Keys : Modifier := FLTK.Event.Last_Modifier; - Actual_Key : Keypress := FLTK.Event.Last_Key; -- fuck you FLTK, give me the real code + Extra_Keys : Modifier := FLTK.Events.Last_Modifier; + Actual_Key : Keypress := FLTK.Events.Last_Key; -- fuck you FLTK, give me the real code Ada_Key : Key_Combo := Extra_Keys + Actual_Key; -- For whatever reason, if a regular key function is used then FLTK will diff --git a/body/fltk-widgets-groups-text_displays.adb b/body/fltk-widgets-groups-text_displays.adb index 7fda2fd..601bde9 100644 --- a/body/fltk-widgets-groups-text_displays.adb +++ b/body/fltk-widgets-groups-text_displays.adb @@ -2172,7 +2172,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in Text_Display) return Key_Combo is begin - return To_Ada (fl_text_display_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_text_display_get_shortcut (This.Void_Ptr))); end Get_Shortcut; @@ -2180,7 +2180,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display; Value : in Key_Combo) is begin - fl_text_display_set_shortcut (This.Void_Ptr, To_C (Value)); + fl_text_display_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (Value))); end Set_Shortcut; diff --git a/body/fltk-widgets-inputs.adb b/body/fltk-widgets-inputs.adb index 888ef68..ef791be 100644 --- a/body/fltk-widgets-inputs.adb +++ b/body/fltk-widgets-inputs.adb @@ -633,7 +633,7 @@ package body FLTK.Widgets.Inputs is (This : in Input) return Key_Combo is begin - return To_Ada (fl_input_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_input_get_shortcut (This.Void_Ptr))); end Get_Shortcut; @@ -641,7 +641,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input; To : in Key_Combo) is begin - fl_input_set_shortcut (This.Void_Ptr, To_C (To)); + fl_input_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (To))); end Set_Shortcut; diff --git a/body/fltk-widgets-menus-menu_bars-systemwide.adb b/body/fltk-widgets-menus-menu_bars-systemwide.adb index c09ef93..47ef6d9 100644 --- a/body/fltk-widgets-menus-menu_bars-systemwide.adb +++ b/body/fltk-widgets-menus-menu_bars-systemwide.adb @@ -338,7 +338,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -357,7 +357,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -416,7 +416,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -437,7 +437,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -584,7 +584,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is fl_sys_menu_bar_shortcut (This.Void_Ptr, Interfaces.C.int (Place) - 1, - To_C (Press)); + Interfaces.C.int (To_C (Press))); end Set_Shortcut; diff --git a/body/fltk-widgets-menus.adb b/body/fltk-widgets-menus.adb index ede63a3..1e690f3 100644 --- a/body/fltk-widgets-menus.adb +++ b/body/fltk-widgets-menus.adb @@ -596,7 +596,7 @@ package body FLTK.Widgets.Menus is Added_Spot : Interfaces.C.int := fl_menu_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -615,7 +615,7 @@ package body FLTK.Widgets.Menus is Added_Spot : Interfaces.C.int := fl_menu_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -674,7 +674,7 @@ package body FLTK.Widgets.Menus is (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -695,7 +695,7 @@ package body FLTK.Widgets.Menus is (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -1177,7 +1177,7 @@ package body FLTK.Widgets.Menus is fl_menu_shortcut (This.Void_Ptr, Interfaces.C.int (Place) - 1, - To_C (Press)); + Interfaces.C.int (To_C (Press))); end Set_Shortcut; diff --git a/body/fltk-widgets-valuators-value_inputs.adb b/body/fltk-widgets-valuators-value_inputs.adb index 929d117..b107e3a 100644 --- a/body/fltk-widgets-valuators-value_inputs.adb +++ b/body/fltk-widgets-valuators-value_inputs.adb @@ -317,7 +317,7 @@ package body FLTK.Widgets.Valuators.Value_Inputs is (This : in Value_Input) return Key_Combo is begin - return To_Ada (fl_value_input_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_value_input_get_shortcut (This.Void_Ptr))); end Get_Shortcut; diff --git a/body/fltk.adb b/body/fltk.adb index 48023f2..c7a8fe4 100644 --- a/body/fltk.adb +++ b/body/fltk.adb @@ -11,6 +11,7 @@ with use type Interfaces.C.int, + Interfaces.C.unsigned, Interfaces.C.unsigned_char, Interfaces.C.unsigned_long; @@ -22,17 +23,42 @@ package body FLTK is -- Constants From C -- ------------------------ + -- Color -- + fl_enum_num_red : constant Interfaces.C.int; - pragma Import (C, fl_enum_num_red); + pragma Import (C, fl_enum_num_red, "fl_enum_num_red"); fl_enum_num_green : constant Interfaces.C.int; - pragma Import (C, fl_enum_num_green); + pragma Import (C, fl_enum_num_green, "fl_enum_num_green"); fl_enum_num_blue : constant Interfaces.C.int; - pragma Import (C, fl_enum_num_blue); + pragma Import (C, fl_enum_num_blue, "fl_enum_num_blue"); fl_enum_num_gray : constant Interfaces.C.int; - pragma Import (C, fl_enum_num_gray); + pragma Import (C, fl_enum_num_gray, "fl_enum_num_gray"); + + + + + -- Keyboard and Mouse Input -- + + fl_enum_button1 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button1, "fl_enum_button1"); + + fl_enum_button2 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button2, "fl_enum_button2"); + + fl_enum_button3 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button3, "fl_enum_button3"); + + fl_enum_button4 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button4, "fl_enum_button4"); + + fl_enum_button5 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button5, "fl_enum_button5"); + + fl_enum_buttons : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_buttons, "fl_enum_buttons"); @@ -154,21 +180,6 @@ package body FLTK is - -- Drawing -- - - function fl_get_damage - return Interfaces.C.int; - pragma Import (C, fl_get_damage, "fl_get_damage"); - pragma Inline (fl_get_damage); - - procedure fl_set_damage - (V : in Interfaces.C.int); - pragma Import (C, fl_set_damage, "fl_set_damage"); - pragma Inline (fl_set_damage); - - - - -- Event Loop -- function fl_check @@ -457,14 +468,14 @@ package body FLTK is function To_C (Key : in Key_Combo) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin return To_C (Key.Modcode) + To_C (Key.Keycode) + To_C (Key.Mousecode); end To_C; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Key_Combo is begin return Result : Key_Combo do @@ -477,14 +488,14 @@ package body FLTK is function To_C (Key : in Keypress) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin - return Interfaces.C.int (Key); + return Interfaces.C.unsigned (Key); end To_C; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Keypress is begin return Keypress (Key mod 65536); @@ -493,14 +504,14 @@ package body FLTK is function To_C (Modi : in Modifier) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin - return Interfaces.C.int (Modi) * 65536; + return Interfaces.C.unsigned (Modi) * 65536; end To_C; function To_Ada - (Modi : in Interfaces.C.int) + (Modi : in Interfaces.C.unsigned) return Modifier is begin return Modifier ((Modi / 65536) mod 256); @@ -509,27 +520,41 @@ package body FLTK is function To_C (Button : in Mouse_Button) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin case Button is - when Left_Button => return 1 * (256 ** 3); - when Middle_Button => return 2 * (256 ** 3); - when Right_Button => return 4 * (256 ** 3); - when others => return 0; + when No_Button => return 0; + when Left_Button => return fl_enum_button1; + when Middle_Button => return fl_enum_button2; + when Right_Button => return fl_enum_button3; + when Back_Button => return fl_enum_button4; + when Forward_Button => return fl_enum_button5; + when Any_Button => return fl_enum_buttons; end case; end To_C; function To_Ada - (Button : in Interfaces.C.int) + (Button : in Interfaces.C.unsigned) return Mouse_Button is begin - case (Button / (256 ** 3)) is - when 1 => return Left_Button; - when 2 => return Middle_Button; - when 4 => return Right_Button; - when others => return No_Button; - end case; + if Button = 0 then + return No_Button; + elsif Button = fl_enum_button1 then + return Left_Button; + elsif Button = fl_enum_button2 then + return Middle_Button; + elsif Button = fl_enum_button3 then + return Right_Button; + elsif Button = fl_enum_button4 then + return Back_Button; + elsif Button = fl_enum_button5 then + return Forward_Button; + elsif Button = fl_enum_buttons then + return Any_Button; + else + raise Constraint_Error; + end if; end To_Ada; @@ -701,25 +726,15 @@ package body FLTK is - -- Drawing -- - - function Is_Damaged - return Boolean is - begin - return fl_get_damage /= 0; - end Is_Damaged; - + -- Event Loop -- - procedure Set_Damaged - (To : in Boolean) is + procedure Check + is + Ignore : Interfaces.C.int := fl_check; begin - fl_set_damage (Boolean'Pos (To)); - end Set_Damaged; - - - + null; + end Check; - -- Event Loop -- function Check return Boolean is -- cgit