From f2352c6df585d817b3613145ec81446f917dcc21 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Sun, 2 Mar 2025 16:06:45 +1300 Subject: Filled holes in FLTK.Static API --- body/c_fl.cpp | 4 +- body/c_fl.h | 4 +- body/c_fl_event.cpp | 15 + body/c_fl_event.h | 5 + body/c_fl_label.cpp | 4 + body/c_fl_label.h | 1 + body/c_fl_static.cpp | 154 ++++- body/c_fl_static.h | 37 +- body/fltk-args_marshal.adb | 56 ++ body/fltk-args_marshal.ads | 46 ++ body/fltk-box_draw_marshal.adb | 693 +++++++++++++++++++++ body/fltk-box_draw_marshal.ads | 28 + body/fltk-events.adb | 122 +++- body/fltk-help_dialogs.adb | 4 +- body/fltk-label_draw_marshal.adb | 113 ++++ body/fltk-label_draw_marshal.ads | 28 + body/fltk-labels.adb | 25 +- body/fltk-registry.ads | 32 + body/fltk-show_argv.adb | 50 -- body/fltk-show_argv.ads | 37 -- body/fltk-static.adb | 561 ++++++++++++++--- .../fltk-widgets-groups-windows-double-overlay.adb | 4 +- body/fltk-widgets-groups-windows-double.adb | 4 +- body/fltk-widgets-groups-windows-opengl.adb | 4 +- body/fltk-widgets-groups-windows-single.adb | 4 +- body/fltk-widgets-groups-windows.adb | 4 +- 26 files changed, 1814 insertions(+), 225 deletions(-) create mode 100644 body/fltk-args_marshal.adb create mode 100644 body/fltk-args_marshal.ads create mode 100644 body/fltk-box_draw_marshal.adb create mode 100644 body/fltk-box_draw_marshal.ads create mode 100644 body/fltk-label_draw_marshal.adb create mode 100644 body/fltk-label_draw_marshal.ads create mode 100644 body/fltk-registry.ads delete mode 100644 body/fltk-show_argv.adb delete mode 100644 body/fltk-show_argv.ads (limited to 'body') diff --git a/body/c_fl.cpp b/body/c_fl.cpp index 871b32d..7bfc444 100644 --- a/body/c_fl.cpp +++ b/body/c_fl.cpp @@ -147,9 +147,9 @@ int fl_enum_down(int b) { -const char * fl_clip_image_char_ptr = Fl::clipboard_image; +const char * const fl_clip_image_char_ptr = Fl::clipboard_image; -const char * fl_clip_plain_text_char_ptr = Fl::clipboard_plain_text; +const char * const fl_clip_plain_text_char_ptr = Fl::clipboard_plain_text; diff --git a/body/c_fl.h b/body/c_fl.h index 88d229d..2149640 100644 --- a/body/c_fl.h +++ b/body/c_fl.h @@ -80,8 +80,8 @@ 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" const char * const fl_clip_image_char_ptr; +extern "C" const char * const fl_clip_plain_text_char_ptr; extern "C" int fl_abi_check(int v); diff --git a/body/c_fl_event.cpp b/body/c_fl_event.cpp index d88dfc2..7bfb466 100644 --- a/body/c_fl_event.cpp +++ b/body/c_fl_event.cpp @@ -16,6 +16,21 @@ void fl_event_add_handler(void * f) { Fl::add_handler(reinterpret_cast(f)); } +void fl_event_remove_handler(void * f) { + Fl::remove_handler(reinterpret_cast(f)); +} + +void fl_event_add_system_handler(void * h, void * f) { + Fl::add_system_handler(reinterpret_cast(h), f); +} + +void fl_event_remove_system_handler(void * h) { + Fl::remove_system_handler(reinterpret_cast(h)); +} + + + + void fl_event_set_dispatch(void * f) { Fl::event_dispatch(reinterpret_cast(f)); } diff --git a/body/c_fl_event.h b/body/c_fl_event.h index 0acf999..4cb87cb 100644 --- a/body/c_fl_event.h +++ b/body/c_fl_event.h @@ -9,6 +9,11 @@ extern "C" void fl_event_add_handler(void * f); +extern "C" void fl_event_remove_handler(void * f); +extern "C" void fl_event_add_system_handler(void * h, void * f); +extern "C" void fl_event_remove_system_handler(void * h); + + 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); diff --git a/body/c_fl_label.cpp b/body/c_fl_label.cpp index 2200c51..b80d3d3 100644 --- a/body/c_fl_label.cpp +++ b/body/c_fl_label.cpp @@ -29,6 +29,10 @@ void free_fl_label(LABEL l) { +const char * fl_label_get_value(LABEL l) { + return static_cast(l)->value; +} + void fl_label_set_value(LABEL l, const char * v) { static_cast(l)->value = v; } diff --git a/body/c_fl_label.h b/body/c_fl_label.h index 806aa72..6da3aca 100644 --- a/body/c_fl_label.h +++ b/body/c_fl_label.h @@ -15,6 +15,7 @@ extern "C" LABEL new_fl_label(const char * v, int f, int s, unsigned int h, int extern "C" void free_fl_label(LABEL l); +extern "C" const char * fl_label_get_value(LABEL l); extern "C" void fl_label_set_value(LABEL l, const char * v); extern "C" int fl_label_get_font(LABEL l); extern "C" void fl_label_set_font(LABEL l, int f); diff --git a/body/c_fl_static.cpp b/body/c_fl_static.cpp index 31cb3af..5dd90e2 100644 --- a/body/c_fl_static.cpp +++ b/body/c_fl_static.cpp @@ -12,16 +12,47 @@ -void fl_static_add_awake_handler(void * h, void * f) { - Fl::add_awake_handler_(reinterpret_cast(h),f); +void fl_static_box_draw_marshal(void * f, int x, int y, int w, int h, unsigned int t) { + reinterpret_cast(f)(x, y, w, h, static_cast(t)); } -void fl_static_get_awake_handler(void * &h, void * &f) { - Fl::get_awake_handler_(reinterpret_cast(h),f); + + + +const char * const fl_help_usage_string_ptr = Fl::help; + + + + +int fl_static_arg(int c, void * v, int &i) { + return Fl::arg(c, static_cast(v), i); +} + +void fl_static_args(int c, void * v) { + Fl::args(c, static_cast(v)); +} + +int fl_static_args2(int c, void * v, int &i, void * h) { + return Fl::args(c, static_cast(v), i, reinterpret_cast(h)); +} + + + + +int fl_static_add_awake_handler(void * h, void * f) { + return Fl::add_awake_handler_(reinterpret_cast(h), f); +} + +int fl_static_get_awake_handler(void * &h, void * &f) { + return Fl::get_awake_handler_(reinterpret_cast(h), f); } -void fl_static_awake() { - Fl::awake(); +int fl_static_awake2(void * h, void * f) { + return Fl::awake(reinterpret_cast(h), f); +} + +void fl_static_awake(void * msg) { + Fl::awake(msg); } void fl_static_lock() { @@ -36,52 +67,56 @@ void fl_static_unlock() { void fl_static_add_check(void * h, void * f) { - Fl::add_check(reinterpret_cast(h),f); + Fl::add_check(reinterpret_cast(h), f); } int fl_static_has_check(void * h, void * f) { - return Fl::has_check(reinterpret_cast(h),f); + return Fl::has_check(reinterpret_cast(h), f); } void fl_static_remove_check(void * h, void * f) { - Fl::remove_check(reinterpret_cast(h),f); + Fl::remove_check(reinterpret_cast(h), f); } void fl_static_add_timeout(double s, void * h, void * f) { - Fl::add_timeout(s,reinterpret_cast(h),f); + Fl::add_timeout(s, reinterpret_cast(h), f); } int fl_static_has_timeout(void * h, void * f) { - return Fl::has_timeout(reinterpret_cast(h),f); + return Fl::has_timeout(reinterpret_cast(h), f); } void fl_static_remove_timeout(void * h, void * f) { - Fl::remove_timeout(reinterpret_cast(h),f); + Fl::remove_timeout(reinterpret_cast(h), f); } void fl_static_repeat_timeout(double s, void * h, void * f) { - Fl::repeat_timeout(s,reinterpret_cast(h),f); + Fl::repeat_timeout(s, reinterpret_cast(h), f); } void fl_static_add_clipboard_notify(void * h, void * f) { - Fl::add_clipboard_notify(reinterpret_cast(h),f); + Fl::add_clipboard_notify(reinterpret_cast(h), f); +} + +void fl_static_remove_clipboard_notify(void * h) { + Fl::remove_clipboard_notify(reinterpret_cast(h)); } void fl_static_add_fd(int d, void * h, void * f) { - Fl::add_fd(d,reinterpret_cast(h),f); + Fl::add_fd(d,reinterpret_cast(h), f); } void fl_static_add_fd2(int d, int m, void * h, void * f) { - Fl::add_fd(d,m,reinterpret_cast(h),f); + Fl::add_fd(d,m,reinterpret_cast(h), f); } void fl_static_remove_fd(int d) { @@ -89,49 +124,73 @@ void fl_static_remove_fd(int d) { } void fl_static_remove_fd2(int d, int m) { - Fl::remove_fd(d,m); + Fl::remove_fd(d, m); } void fl_static_add_idle(void * h, void * f) { - Fl::add_idle(reinterpret_cast(h),f); + Fl::add_idle(reinterpret_cast(h), f); } int fl_static_has_idle(void * h, void * f) { - return Fl::has_idle(reinterpret_cast(h),f); + return Fl::has_idle(reinterpret_cast(h), f); } void fl_static_remove_idle(void * h, void * f) { - Fl::remove_idle(reinterpret_cast(h),f); + Fl::remove_idle(reinterpret_cast(h), f); } +unsigned int fl_static_get_color2(unsigned int c) { + return Fl::get_color(c); +} + void fl_static_get_color(unsigned int c, unsigned char &r, unsigned char &g, unsigned char &b) { - Fl::get_color(c,r,g,b); + Fl::get_color(c, r, g, b); +} + +void fl_static_set_color2(unsigned int t, unsigned int f) { + Fl::set_color(t, f); } void fl_static_set_color(unsigned int c, unsigned char r, unsigned char g, unsigned char b) { - Fl::set_color(c,r,g,b); + Fl::set_color(c, r, g, b); } void fl_static_free_color(unsigned int c, int b) { - Fl::free_color(c,b); + Fl::free_color(c, b); +} + +unsigned int fl_static_get_box_color(unsigned int t) { + return Fl::box_color(static_cast(t)); +} + +void fl_static_set_box_color(unsigned int t) { + Fl::set_box_color(static_cast(t)); +} + +void fl_static_own_colormap() { + Fl::own_colormap(); } void fl_static_foreground(unsigned int r, unsigned int g, unsigned int b) { - Fl::foreground(r,g,b); + Fl::foreground(r, g, b); } void fl_static_background(unsigned int r, unsigned int g, unsigned int b) { - Fl::background(r,g,b); + Fl::background(r, g, b); } void fl_static_background2(unsigned int r, unsigned int g, unsigned int b) { - Fl::background2(r,g,b); + Fl::background2(r, g, b); +} + +void fl_static_get_system_colors() { + Fl::get_system_colors(); } @@ -146,7 +205,11 @@ const char * fl_static_get_font_name(int f) { } void fl_static_set_font(int t, int f) { - Fl::set_font(t,f); + Fl::set_font(static_cast(t), static_cast(f)); +} + +void fl_static_set_font2(int t, char * s) { + Fl::set_font(static_cast(t), s); } int fl_static_get_font_sizes(int f, int * &a) { @@ -180,10 +243,20 @@ int fl_static_box_dy(int b) { return Fl::box_dy(static_cast(b)); } +void * fl_static_get_boxtype(int t) { + return reinterpret_cast(Fl::get_boxtype(static_cast(t))); +} + void fl_static_set_boxtype(int t, int f) { Fl::set_boxtype(static_cast(t),static_cast(f)); } +void fl_static_set_boxtype2(int t, void * f, + unsigned char dx, unsigned char dy, unsigned char dw, unsigned char dh) +{ + Fl::set_boxtype(static_cast(t), reinterpret_cast(f), dx, dy, dw, dh); +} + int fl_static_draw_box_active() { return Fl::draw_box_active(); } @@ -191,8 +264,16 @@ int fl_static_draw_box_active() { +void fl_static_set_labeltype(int k, void * d, void * m) { + Fl::set_labeltype(static_cast(k), + reinterpret_cast(d), reinterpret_cast(m)); +} + + + + void fl_static_copy(const char * t, int l, int k) { - Fl::copy(t,l,k); + Fl::copy(t, l, k); } void fl_static_paste(void * r, int s) { @@ -205,11 +286,15 @@ void fl_static_selection(void * o, char * t, int l) { Fl::selection(ref, t, l); } +int fl_static_clipboard_contains(const char * k) { + return Fl::clipboard_contains(k); +} + -void fl_static_dnd() { - Fl::dnd(); +int fl_static_dnd() { + return Fl::dnd(); } int fl_static_get_dnd_text_ops() { @@ -234,8 +319,8 @@ void fl_static_disable_im() { -void fl_static_default_atclose(void * w) { - Fl::default_atclose(static_cast(w), 0); +void fl_static_default_atclose(void * w, void * u) { + Fl::default_atclose(static_cast(w), u); } void * fl_static_get_first_window() { @@ -277,6 +362,7 @@ int fl_static_is_scheme(const char *n) { } void fl_static_reload_scheme() { + // this always returns 1 for some reason so we can ignore the return value Fl::reload_scheme(); } @@ -284,11 +370,11 @@ void fl_static_reload_scheme() { int fl_static_get_option(int o) { - return Fl::option(static_cast(o)); + return Fl::option(static_cast(o)) ? 1 : 0; } void fl_static_set_option(int o, int t) { - Fl::option(static_cast(o),t); + Fl::option(static_cast(o), t!=0); } diff --git a/body/c_fl_static.h b/body/c_fl_static.h index c0a6c2f..f39e557 100644 --- a/body/c_fl_static.h +++ b/body/c_fl_static.h @@ -8,9 +8,21 @@ #define FL_STATIC_GUARD -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_box_draw_marshal(void * f, int x, int y, int w, int h, unsigned int t); + + +extern "C" const char * const fl_help_usage_string_ptr; + + +extern "C" int fl_static_arg(int c, void * v, int &i); +extern "C" void fl_static_args(int c, void * v); +extern "C" int fl_static_args2(int c, void * v, int &i, void * h); + + +extern "C" int fl_static_add_awake_handler(void * h, void * f); +extern "C" int fl_static_get_awake_handler(void * &h, void * &f); +extern "C" int fl_static_awake2(void * h, void * f); +extern "C" void fl_static_awake(void * msg); extern "C" void fl_static_lock(); extern "C" void fl_static_unlock(); @@ -27,6 +39,7 @@ extern "C" void fl_static_repeat_timeout(double s, void * h, void * f); extern "C" void fl_static_add_clipboard_notify(void * h, void * f); +extern "C" void fl_static_remove_clipboard_notify(void * h); extern "C" void fl_static_add_fd(int d, void * h, void * f); @@ -40,19 +53,26 @@ extern "C" int fl_static_has_idle(void * h, void * f); extern "C" void fl_static_remove_idle(void * h, void * f); +extern "C" unsigned int fl_static_get_color2(unsigned int c); extern "C" void fl_static_get_color(unsigned int c, unsigned char &r, unsigned char &g, unsigned char &b); +extern "C" void fl_static_set_color2(unsigned int t, unsigned int f); extern "C" void fl_static_set_color(unsigned int c, unsigned char r, unsigned char g, unsigned char b); extern "C" void fl_static_free_color(unsigned int c, int b); +extern "C" unsigned int fl_static_get_box_color(unsigned int t); +extern "C" void fl_static_set_box_color(unsigned int t); +extern "C" void fl_static_own_colormap(); extern "C" void fl_static_foreground(unsigned int r, unsigned int g, unsigned int b); extern "C" void fl_static_background(unsigned int r, unsigned int g, unsigned int b); extern "C" void fl_static_background2(unsigned int r, unsigned int g, unsigned int b); +extern "C" void fl_static_get_system_colors(); extern "C" const char * fl_static_get_font(int f); extern "C" const char * fl_static_get_font_name(int f); extern "C" void fl_static_set_font(int t, int f); +extern "C" void fl_static_set_font2(int t, char * s); extern "C" int fl_static_get_font_sizes(int f, int * &a); extern "C" int fl_static_font_size_array_get(int * a, int i); extern "C" int fl_static_set_fonts(); @@ -62,16 +82,23 @@ extern "C" int fl_static_box_dh(int b); extern "C" int fl_static_box_dw(int b); extern "C" int fl_static_box_dx(int b); extern "C" int fl_static_box_dy(int b); +extern "C" void * fl_static_get_boxtype(int t); extern "C" void fl_static_set_boxtype(int t, int f); +extern "C" void fl_static_set_boxtype2(int t, void * f, + unsigned char dx, unsigned char dy, unsigned char dw, unsigned char dh); extern "C" int fl_static_draw_box_active(); +extern "C" void fl_static_set_labeltype(int k, void * d, void * m); + + extern "C" void fl_static_copy(const char * t, int l, int k); extern "C" void fl_static_paste(void * r, int s); extern "C" void fl_static_selection(void * o, char * t, int l); +extern "C" int fl_static_clipboard_contains(const char * k); -extern "C" void fl_static_dnd(); +extern "C" int fl_static_dnd(); extern "C" int fl_static_get_dnd_text_ops(); extern "C" void fl_static_set_dnd_text_ops(int t); @@ -80,7 +107,7 @@ extern "C" void fl_static_enable_im(); extern "C" void fl_static_disable_im(); -extern "C" void fl_static_default_atclose(void * w); +extern "C" void fl_static_default_atclose(void * w, void * u); extern "C" void * fl_static_get_first_window(); extern "C" void fl_static_set_first_window(void * w); extern "C" void * fl_static_next_window(void * w); diff --git a/body/fltk-args_marshal.adb b/body/fltk-args_marshal.adb new file mode 100644 index 0000000..f9a5aaa --- /dev/null +++ b/body/fltk-args_marshal.adb @@ -0,0 +1,56 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Command_Line, + Interfaces.C.Strings; + + +package body FLTK.Args_Marshal is + + + package ACom renames Ada.Command_Line; + package IntC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + + + function Create_Argv + return ICS.chars_ptr_array + is + Result : ICS.chars_ptr_array (0 .. IntC.size_t (ACom.Argument_Count)); + begin + Result (0) := ICS.New_String (ACom.Command_Name); + for Index in Integer range 1 .. ACom.Argument_Count loop + Result (IntC.size_t (Index)) := ICS.New_String (ACom.Argument (Index)); + end loop; + return Result; + end Create_Argv; + + + procedure Free_Argv + (Argv : in out Interfaces.C.Strings.chars_ptr_array) is + begin + for Ptr of Argv loop + ICS.Free (Ptr); + end loop; + end Free_Argv; + + + procedure Dispatch + (Func : in Show_With_Args_Func; + CObj : in Storage.Integer_Address) + is + Argv : ICS.chars_ptr_array := Create_Argv; + begin + Func (CObj, Argv'Length, Storage.To_Integer (Argv (Argv'First)'Address)); + Free_Argv (Argv); + end Dispatch; + + +end FLTK.Args_Marshal; + + diff --git a/body/fltk-args_marshal.ads b/body/fltk-args_marshal.ads new file mode 100644 index 0000000..b19c182 --- /dev/null +++ b/body/fltk-args_marshal.ads @@ -0,0 +1,46 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + + +private package FLTK.Args_Marshal is + + + function Create_Argv + return Interfaces.C.Strings.chars_ptr_array; + + procedure Free_Argv + (Argv : in out Interfaces.C.Strings.chars_ptr_array); + + + + + -- Used for implementing show(argc,argv) + + -- Dispatch marshalls the data, calls the function, then does cleanup + + type Show_With_Args_Func is access procedure + (CObj : in Storage.Integer_Address; + Argc : in Interfaces.C.int; + Argv : in Storage.Integer_Address); + + procedure Dispatch + (Func : in Show_With_Args_Func; + CObj : in Storage.Integer_Address); + + +private + + + pragma Convention (C, Show_With_Args_Func); + + +end FLTK.Args_Marshal; + + diff --git a/body/fltk-box_draw_marshal.adb b/body/fltk-box_draw_marshal.adb new file mode 100644 index 0000000..95a33ba --- /dev/null +++ b/body/fltk-box_draw_marshal.adb @@ -0,0 +1,693 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + FLTK.Static, + Interfaces.C; + +use type + + FLTK.Static.Box_Draw_Function; + + +package body FLTK.Box_Draw_Marshal is + + + package Chk renames Ada.Assertions; + + + + + C_Ptr_Array : array (Box_Kind) of Storage.Integer_Address; + Ada_Access_Array : array (Box_Kind) of FLTK.Static.Box_Draw_Function; + + + + + procedure fl_static_box_draw_marshal + (F : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_static_box_draw_marshal, "fl_static_box_draw_marshal"); + pragma Inline (fl_static_box_draw_marshal); + + + + + generic + Kind : Box_Kind; + procedure Generic_Box_Draw + (X, Y, W, H : in Integer; + Tone : in Color) + with Inline; + + procedure Generic_Box_Draw + (X, Y, W, H : in Integer; + Tone : in Color) is + begin + fl_static_box_draw_marshal + (C_Ptr_Array (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Tone)); + end Generic_Box_Draw; + + procedure No_Box_Draw is new Generic_Box_Draw (No_Box); + procedure Flat_Box_Draw is new Generic_Box_Draw (Flat_Box); + procedure Up_Box_Draw is new Generic_Box_Draw (Up_Box); + procedure Down_Box_Draw is new Generic_Box_Draw (Down_Box); + procedure Up_Frame_Draw is new Generic_Box_Draw (Up_Frame); + procedure Down_Frame_Draw is new Generic_Box_Draw (Down_Frame); + procedure Thin_Up_Box_Draw is new Generic_Box_Draw (Thin_Up_Box); + procedure Thin_Down_Box_Draw is new Generic_Box_Draw (Thin_Down_Box); + procedure Thin_Up_Frame_Draw is new Generic_Box_Draw (Thin_Up_Frame); + procedure Thin_Down_Frame_Draw is new Generic_Box_Draw (Thin_Down_Frame); + procedure Engraved_Box_Draw is new Generic_Box_Draw (Engraved_Box); + procedure Embossed_Box_Draw is new Generic_Box_Draw (Embossed_Box); + procedure Engraved_Frame_Draw is new Generic_Box_Draw (Engraved_Frame); + procedure Embossed_Frame_Draw is new Generic_Box_Draw (Embossed_Frame); + procedure Border_Box_Draw is new Generic_Box_Draw (Border_Box); + procedure Shadow_Box_Draw is new Generic_Box_Draw (Shadow_Box); + procedure Border_Frame_Draw is new Generic_Box_Draw (Border_Frame); + procedure Shadow_Frame_Draw is new Generic_Box_Draw (Shadow_Frame); + procedure Rounded_Box_Draw is new Generic_Box_Draw (Rounded_Box); + procedure RShadow_Box_Draw is new Generic_Box_Draw (RShadow_Box); + procedure Rounded_Frame_Draw is new Generic_Box_Draw (Rounded_Frame); + procedure RFlat_Box_Draw is new Generic_Box_Draw (RFlat_Box); + procedure Round_Up_Box_Draw is new Generic_Box_Draw (Round_Up_Box); + procedure Round_Down_Box_Draw is new Generic_Box_Draw (Round_Down_Box); + procedure Diamond_Up_Box_Draw is new Generic_Box_Draw (Diamond_Up_Box); + procedure Diamond_Down_Box_Draw is new Generic_Box_Draw (Diamond_Down_Box); + procedure Oval_Box_Draw is new Generic_Box_Draw (Oval_Box); + procedure OShadow_Box_Draw is new Generic_Box_Draw (OShadow_Box); + procedure Oval_Frame_Draw is new Generic_Box_Draw (Oval_Frame); + procedure OFlat_Box_Draw is new Generic_Box_Draw (OFlat_Box); + procedure Plastic_Up_Box_Draw is new Generic_Box_Draw (Plastic_Up_Box); + procedure Plastic_Down_Box_Draw is new Generic_Box_Draw (Plastic_Down_Box); + procedure Plastic_Up_Frame_Draw is new Generic_Box_Draw (Plastic_Up_Frame); + procedure Plastic_Down_Frame_Draw is new Generic_Box_Draw (Plastic_Down_Frame); + procedure Plastic_Thin_Up_Box_Draw is new Generic_Box_Draw (Plastic_Thin_Up_Box); + procedure Plastic_Thin_Down_Box_Draw is new Generic_Box_Draw (Plastic_Thin_Down_Box); + procedure Plastic_Round_Up_Box_Draw is new Generic_Box_Draw (Plastic_Round_Up_Box); + procedure Plastic_Round_Down_Box_Draw is new Generic_Box_Draw (Plastic_Round_Down_Box); + procedure Gtk_Up_Box_Draw is new Generic_Box_Draw (Gtk_Up_Box); + procedure Gtk_Down_Box_Draw is new Generic_Box_Draw (Gtk_Down_Box); + procedure Gtk_Up_Frame_Draw is new Generic_Box_Draw (Gtk_Up_Frame); + procedure Gtk_Down_Frame_Draw is new Generic_Box_Draw (Gtk_Down_Frame); + procedure Gtk_Thin_Up_Box_Draw is new Generic_Box_Draw (Gtk_Thin_Up_Box); + procedure Gtk_Thin_Down_Box_Draw is new Generic_Box_Draw (Gtk_Thin_Down_Box); + procedure Gtk_Thin_Up_Frame_Draw is new Generic_Box_Draw (Gtk_Thin_Up_Frame); + procedure Gtk_Thin_Down_Frame_Draw is new Generic_Box_Draw (Gtk_Thin_Down_Frame); + procedure Gtk_Round_Up_Box_Draw is new Generic_Box_Draw (Gtk_Round_Up_Box); + procedure Gtk_Round_Down_Box_Draw is new Generic_Box_Draw (Gtk_Round_Down_Box); + procedure Gleam_Up_Box_Draw is new Generic_Box_Draw (Gleam_Up_Box); + procedure Gleam_Down_Box_Draw is new Generic_Box_Draw (Gleam_Down_Box); + procedure Gleam_Up_Frame_Draw is new Generic_Box_Draw (Gleam_Up_Frame); + procedure Gleam_Down_Frame_Draw is new Generic_Box_Draw (Gleam_Down_Frame); + procedure Gleam_Thin_Up_Box_Draw is new Generic_Box_Draw (Gleam_Thin_Up_Box); + procedure Gleam_Thin_Down_Box_Draw is new Generic_Box_Draw (Gleam_Thin_Down_Box); + procedure Gleam_Round_Up_Box_Draw is new Generic_Box_Draw (Gleam_Round_Up_Box); + procedure Gleam_Round_Down_Box_Draw is new Generic_Box_Draw (Gleam_Round_Down_Box); + procedure Free_Box_Draw is new Generic_Box_Draw (Free_Box); + + + + + generic + Kind : Box_Kind; + procedure Generic_Box_Draw_Hook + (X, Y, W, H : in Interfaces.C.int; + Tone : in Interfaces.C.unsigned) + with Inline, Convention => C; + + procedure Generic_Box_Draw_Hook + (X, Y, W, H : in Interfaces.C.int; + Tone : in Interfaces.C.unsigned) is + begin + pragma Assert (Ada_Access_Array (Kind) /= null); + Ada_Access_Array (Kind) + (Integer (X), Integer (Y), + Integer (W), Integer (H), + Color (Tone)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Box_Draw_Function hook tried to get a null subprogram access"; + end Generic_Box_Draw_Hook; + + procedure No_Box_Hook is new Generic_Box_Draw_Hook (No_Box); + procedure Flat_Box_Hook is new Generic_Box_Draw_Hook (Flat_Box); + procedure Up_Box_Hook is new Generic_Box_Draw_Hook (Up_Box); + procedure Down_Box_Hook is new Generic_Box_Draw_Hook (Down_Box); + procedure Up_Frame_Hook is new Generic_Box_Draw_Hook (Up_Frame); + procedure Down_Frame_Hook is new Generic_Box_Draw_Hook (Down_Frame); + procedure Thin_Up_Box_Hook is new Generic_Box_Draw_Hook (Thin_Up_Box); + procedure Thin_Down_Box_Hook is new Generic_Box_Draw_Hook (Thin_Down_Box); + procedure Thin_Up_Frame_Hook is new Generic_Box_Draw_Hook (Thin_Up_Frame); + procedure Thin_Down_Frame_Hook is new Generic_Box_Draw_Hook (Thin_Down_Frame); + procedure Engraved_Box_Hook is new Generic_Box_Draw_Hook (Engraved_Box); + procedure Embossed_Box_Hook is new Generic_Box_Draw_Hook (Embossed_Box); + procedure Engraved_Frame_Hook is new Generic_Box_Draw_Hook (Engraved_Frame); + procedure Embossed_Frame_Hook is new Generic_Box_Draw_Hook (Embossed_Frame); + procedure Border_Box_Hook is new Generic_Box_Draw_Hook (Border_Box); + procedure Shadow_Box_Hook is new Generic_Box_Draw_Hook (Shadow_Box); + procedure Border_Frame_Hook is new Generic_Box_Draw_Hook (Border_Frame); + procedure Shadow_Frame_Hook is new Generic_Box_Draw_Hook (Shadow_Frame); + procedure Rounded_Box_Hook is new Generic_Box_Draw_Hook (Rounded_Box); + procedure RShadow_Box_Hook is new Generic_Box_Draw_Hook (RShadow_Box); + procedure Rounded_Frame_Hook is new Generic_Box_Draw_Hook (Rounded_Frame); + procedure RFlat_Box_Hook is new Generic_Box_Draw_Hook (RFlat_Box); + procedure Round_Up_Box_Hook is new Generic_Box_Draw_Hook (Round_Up_Box); + procedure Round_Down_Box_Hook is new Generic_Box_Draw_Hook (Round_Down_Box); + procedure Diamond_Up_Box_Hook is new Generic_Box_Draw_Hook (Diamond_Up_Box); + procedure Diamond_Down_Box_Hook is new Generic_Box_Draw_Hook (Diamond_Down_Box); + procedure Oval_Box_Hook is new Generic_Box_Draw_Hook (Oval_Box); + procedure OShadow_Box_Hook is new Generic_Box_Draw_Hook (OShadow_Box); + procedure Oval_Frame_Hook is new Generic_Box_Draw_Hook (Oval_Frame); + procedure OFlat_Box_Hook is new Generic_Box_Draw_Hook (OFlat_Box); + procedure Plastic_Up_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Up_Box); + procedure Plastic_Down_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Down_Box); + procedure Plastic_Up_Frame_Hook is new Generic_Box_Draw_Hook (Plastic_Up_Frame); + procedure Plastic_Down_Frame_Hook is new Generic_Box_Draw_Hook (Plastic_Down_Frame); + procedure Plastic_Thin_Up_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Thin_Up_Box); + procedure Plastic_Thin_Down_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Thin_Down_Box); + procedure Plastic_Round_Up_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Round_Up_Box); + procedure Plastic_Round_Down_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Round_Down_Box); + procedure Gtk_Up_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Up_Box); + procedure Gtk_Down_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Down_Box); + procedure Gtk_Up_Frame_Hook is new Generic_Box_Draw_Hook (Gtk_Up_Frame); + procedure Gtk_Down_Frame_Hook is new Generic_Box_Draw_Hook (Gtk_Down_Frame); + procedure Gtk_Thin_Up_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Thin_Up_Box); + procedure Gtk_Thin_Down_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Thin_Down_Box); + procedure Gtk_Thin_Up_Frame_Hook is new Generic_Box_Draw_Hook (Gtk_Thin_Up_Frame); + procedure Gtk_Thin_Down_Frame_Hook is new Generic_Box_Draw_Hook (Gtk_Thin_Down_Frame); + procedure Gtk_Round_Up_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Round_Up_Box); + procedure Gtk_Round_Down_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Round_Down_Box); + procedure Gleam_Up_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Up_Box); + procedure Gleam_Down_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Down_Box); + procedure Gleam_Up_Frame_Hook is new Generic_Box_Draw_Hook (Gleam_Up_Frame); + procedure Gleam_Down_Frame_Hook is new Generic_Box_Draw_Hook (Gleam_Down_Frame); + procedure Gleam_Thin_Up_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Thin_Up_Box); + procedure Gleam_Thin_Down_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Thin_Down_Box); + procedure Gleam_Round_Up_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Round_Up_Box); + procedure Gleam_Round_Down_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Round_Down_Box); + procedure Free_Box_Hook is new Generic_Box_Draw_Hook (Free_Box); + + + + + function To_Ada + (Kind : in Box_Kind; + Ptr : in Storage.Integer_Address) + return FLTK.Static.Box_Draw_Function is + begin + if Ptr = Null_Pointer then + return null; + end if; + C_Ptr_Array (Kind) := Ptr; + case Kind is + when No_Box => return + (if Ptr = Storage.To_Integer (No_Box_Hook'Address) + then Ada_Access_Array (Kind) + else No_Box_Draw'Access); + when Flat_Box => return + (if Ptr = Storage.To_Integer (Flat_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Flat_Box_Draw'Access); + when Up_Box => return + (if Ptr = Storage.To_Integer (Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Up_Box_Draw'Access); + when Down_Box => return + (if Ptr = Storage.To_Integer (Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Down_Box_Draw'Access); + when Up_Frame => return + (if Ptr = Storage.To_Integer (Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Up_Frame_Draw'Access); + when Down_Frame => return + (if Ptr = Storage.To_Integer (Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Down_Frame_Draw'Access); + when Thin_Up_Box => return + (if Ptr = Storage.To_Integer (Thin_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Thin_Up_Box_Draw'Access); + when Thin_Down_Box => return + (if Ptr = Storage.To_Integer (Thin_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Thin_Down_Box_Draw'Access); + when Thin_Up_Frame => return + (if Ptr = Storage.To_Integer (Thin_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Thin_Up_Frame_Draw'Access); + when Thin_Down_Frame => return + (if Ptr = Storage.To_Integer (Thin_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Thin_Down_Frame_Draw'Access); + when Engraved_Box => return + (if Ptr = Storage.To_Integer (Engraved_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Engraved_Box_Draw'Access); + when Embossed_Box => return + (if Ptr = Storage.To_Integer (Embossed_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Embossed_Box_Draw'Access); + when Engraved_Frame => return + (if Ptr = Storage.To_Integer (Engraved_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Engraved_Frame_Draw'Access); + when Embossed_Frame => return + (if Ptr = Storage.To_Integer (Embossed_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Embossed_Frame_Draw'Access); + when Border_Box => return + (if Ptr = Storage.To_Integer (Border_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Border_Box_Draw'Access); + when Shadow_Box => return + (if Ptr = Storage.To_Integer (Shadow_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Shadow_Box_Draw'Access); + when Border_Frame => return + (if Ptr = Storage.To_Integer (Border_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Border_Frame_Draw'Access); + when Shadow_Frame => return + (if Ptr = Storage.To_Integer (Shadow_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Shadow_Frame_Draw'Access); + when Rounded_Box => return + (if Ptr = Storage.To_Integer (Rounded_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Rounded_Box_Draw'Access); + when RShadow_Box => return + (if Ptr = Storage.To_Integer (RShadow_Box_Hook'Address) + then Ada_Access_Array (Kind) + else RShadow_Box_Draw'Access); + when Rounded_Frame => return + (if Ptr = Storage.To_Integer (Rounded_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Rounded_Frame_Draw'Access); + when RFlat_Box => return + (if Ptr = Storage.To_Integer (RFlat_Box_Hook'Address) + then Ada_Access_Array (Kind) + else RFlat_Box_Draw'Access); + when Round_Up_Box => return + (if Ptr = Storage.To_Integer (Round_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Round_Up_Box_Draw'Access); + when Round_Down_Box => return + (if Ptr = Storage.To_Integer (Round_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Round_Down_Box_Draw'Access); + when Diamond_Up_Box => return + (if Ptr = Storage.To_Integer (Diamond_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Diamond_Up_Box_Draw'Access); + when Diamond_Down_Box => return + (if Ptr = Storage.To_Integer (Diamond_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Diamond_Down_Box_Draw'Access); + when Oval_Box => return + (if Ptr = Storage.To_Integer (Oval_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Oval_Box_Draw'Access); + when OShadow_Box => return + (if Ptr = Storage.To_Integer (OShadow_Box_Hook'Address) + then Ada_Access_Array (Kind) + else OShadow_Box_Draw'Access); + when Oval_Frame => return + (if Ptr = Storage.To_Integer (Oval_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Oval_Frame_Draw'Access); + when OFlat_Box => return + (if Ptr = Storage.To_Integer (OFlat_Box_Hook'Address) + then Ada_Access_Array (Kind) + else OFlat_Box_Draw'Access); + when Plastic_Up_Box => return + (if Ptr = Storage.To_Integer (Plastic_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Up_Box_Draw'Access); + when Plastic_Down_Box => return + (if Ptr = Storage.To_Integer (Plastic_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Down_Box_Draw'Access); + when Plastic_Up_Frame => return + (if Ptr = Storage.To_Integer (Plastic_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Up_Frame_Draw'Access); + when Plastic_Down_Frame => return + (if Ptr = Storage.To_Integer (Plastic_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Down_Frame_Draw'Access); + when Plastic_Thin_Up_Box => return + (if Ptr = Storage.To_Integer (Plastic_Thin_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Thin_Up_Box_Draw'Access); + when Plastic_Thin_Down_Box => return + (if Ptr = Storage.To_Integer (Plastic_Thin_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Thin_Down_Box_Draw'Access); + when Plastic_Round_Up_Box => return + (if Ptr = Storage.To_Integer (Plastic_Round_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Round_Up_Box_Draw'Access); + when Plastic_Round_Down_Box => return + (if Ptr = Storage.To_Integer (Plastic_Round_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Round_Down_Box_Draw'Access); + when Gtk_Up_Box => return + (if Ptr = Storage.To_Integer (Gtk_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Up_Box_Draw'Access); + when Gtk_Down_Box => return + (if Ptr = Storage.To_Integer (Gtk_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Down_Box_Draw'Access); + when Gtk_Up_Frame => return + (if Ptr = Storage.To_Integer (Gtk_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Up_Frame_Draw'Access); + when Gtk_Down_Frame => return + (if Ptr = Storage.To_Integer (Gtk_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Down_Frame_Draw'Access); + when Gtk_Thin_Up_Box => return + (if Ptr = Storage.To_Integer (Gtk_Thin_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Thin_Up_Box_Draw'Access); + when Gtk_Thin_Down_Box => return + (if Ptr = Storage.To_Integer (Gtk_Thin_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Thin_Down_Box_Draw'Access); + when Gtk_Thin_Up_Frame => return + (if Ptr = Storage.To_Integer (Gtk_Thin_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Thin_Up_Frame_Draw'Access); + when Gtk_Thin_Down_Frame => return + (if Ptr = Storage.To_Integer (Gtk_Thin_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Thin_Down_Frame_Draw'Access); + when Gtk_Round_Up_Box => return + (if Ptr = Storage.To_Integer (Gtk_Round_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Round_Up_Box_Draw'Access); + when Gtk_Round_Down_Box => return + (if Ptr = Storage.To_Integer (Gtk_Round_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Round_Down_Box_Draw'Access); + when Gleam_Up_Box => return + (if Ptr = Storage.To_Integer (Gleam_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Up_Box_Draw'Access); + when Gleam_Down_Box => return + (if Ptr = Storage.To_Integer (Gleam_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Down_Box_Draw'Access); + when Gleam_Up_Frame => return + (if Ptr = Storage.To_Integer (Gleam_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Up_Frame_Draw'Access); + when Gleam_Down_Frame => return + (if Ptr = Storage.To_Integer (Gleam_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Down_Frame_Draw'Access); + when Gleam_Thin_Up_Box => return + (if Ptr = Storage.To_Integer (Gleam_Thin_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Thin_Up_Box_Draw'Access); + when Gleam_Thin_Down_Box => return + (if Ptr = Storage.To_Integer (Gleam_Thin_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Thin_Down_Box_Draw'Access); + when Gleam_Round_Up_Box => return + (if Ptr = Storage.To_Integer (Gleam_Round_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Round_Up_Box_Draw'Access); + when Gleam_Round_Down_Box => return + (if Ptr = Storage.To_Integer (Gleam_Round_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Round_Down_Box_Draw'Access); + when Free_Box => return + (if Ptr = Storage.To_Integer (Free_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Free_Box_Draw'Access); + end case; + end To_Ada; + + + + + function To_C + (Kind : in Box_Kind; + Func : in FLTK.Static.Box_Draw_Function) + return Storage.Integer_Address is + begin + if Func = null then + return Null_Pointer; + end if; + Ada_Access_Array (Kind) := Func; + case Kind is + when No_Box => return + (if Func = No_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (No_Box_Hook'Address)); + when Flat_Box => return + (if Func = Flat_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Flat_Box_Hook'Address)); + when Up_Box => return + (if Func = Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Up_Box_Hook'Address)); + when Down_Box => return + (if Func = Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Down_Box_Hook'Address)); + when Up_Frame => return + (if Func = Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Up_Frame_Hook'Address)); + when Down_Frame => return + (if Func = Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Down_Frame_Hook'Address)); + when Thin_Up_Box => return + (if Func = Thin_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Thin_Up_Box_Hook'Address)); + when Thin_Down_Box => return + (if Func = Thin_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Thin_Down_Box_Hook'Address)); + when Thin_Up_Frame => return + (if Func = Thin_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Thin_Up_Frame_Hook'Address)); + when Thin_Down_Frame => return + (if Func = Thin_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Thin_Down_Frame_Hook'Address)); + when Engraved_Box => return + (if Func = Engraved_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Engraved_Box_Hook'Address)); + when Embossed_Box => return + (if Func = Embossed_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Embossed_Box_Hook'Address)); + when Engraved_Frame => return + (if Func = Engraved_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Engraved_Frame_Hook'Address)); + when Embossed_Frame => return + (if Func = Embossed_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Embossed_Frame_Hook'Address)); + when Border_Box => return + (if Func = Border_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Border_Box_Hook'Address)); + when Shadow_Box => return + (if Func = Shadow_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Shadow_Box_Hook'Address)); + when Border_Frame => return + (if Func = Border_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Border_Frame_Hook'Address)); + when Shadow_Frame => return + (if Func = Shadow_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Shadow_Frame_Hook'Address)); + when Rounded_Box => return + (if Func = Rounded_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Rounded_Box_Hook'Address)); + when RShadow_Box => return + (if Func = RShadow_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (RShadow_Box_Hook'Address)); + when Rounded_Frame => return + (if Func = Rounded_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Rounded_Frame_Hook'Address)); + when RFlat_Box => return + (if Func = RFlat_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (RFlat_Box_Hook'Address)); + when Round_Up_Box => return + (if Func = Round_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Round_Up_Box_Hook'Address)); + when Round_Down_Box => return + (if Func = Round_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Round_Down_Box_Hook'Address)); + when Diamond_Up_Box => return + (if Func = Diamond_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Diamond_Up_Box_Hook'Address)); + when Diamond_Down_Box => return + (if Func = Diamond_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Diamond_Down_Box_Hook'Address)); + when Oval_Box => return + (if Func = Oval_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Oval_Box_Hook'Address)); + when OShadow_Box => return + (if Func = OShadow_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (OShadow_Box_Hook'Address)); + when Oval_Frame => return + (if Func = Oval_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Oval_Frame_Hook'Address)); + when OFlat_Box => return + (if Func = OFlat_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (OFlat_Box_Hook'Address)); + when Plastic_Up_Box => return + (if Func = Plastic_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Up_Box_Hook'Address)); + when Plastic_Down_Box => return + (if Func = Plastic_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Down_Box_Hook'Address)); + when Plastic_Up_Frame => return + (if Func = Plastic_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Up_Frame_Hook'Address)); + when Plastic_Down_Frame => return + (if Func = Plastic_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Down_Frame_Hook'Address)); + when Plastic_Thin_Up_Box => return + (if Func = Plastic_Thin_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Thin_Up_Box_Hook'Address)); + when Plastic_Thin_Down_Box => return + (if Func = Plastic_Thin_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Thin_Down_Box_Hook'Address)); + when Plastic_Round_Up_Box => return + (if Func = Plastic_Round_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Round_Up_Box_Hook'Address)); + when Plastic_Round_Down_Box => return + (if Func = Plastic_Round_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Round_Down_Box_Hook'Address)); + when Gtk_Up_Box => return + (if Func = Gtk_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Up_Box_Hook'Address)); + when Gtk_Down_Box => return + (if Func = Gtk_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Down_Box_Hook'Address)); + when Gtk_Up_Frame => return + (if Func = Gtk_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Up_Frame_Hook'Address)); + when Gtk_Down_Frame => return + (if Func = Gtk_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Down_Frame_Hook'Address)); + when Gtk_Thin_Up_Box => return + (if Func = Gtk_Thin_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Thin_Up_Box_Hook'Address)); + when Gtk_Thin_Down_Box => return + (if Func = Gtk_Thin_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Thin_Down_Box_Hook'Address)); + when Gtk_Thin_Up_Frame => return + (if Func = Gtk_Thin_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Thin_Up_Frame_Hook'Address)); + when Gtk_Thin_Down_Frame => return + (if Func = Gtk_Thin_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Thin_Down_Frame_Hook'Address)); + when Gtk_Round_Up_Box => return + (if Func = Gtk_Round_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Round_Up_Box_Hook'Address)); + when Gtk_Round_Down_Box => return + (if Func = Gtk_Round_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Round_Down_Box_Hook'Address)); + when Gleam_Up_Box => return + (if Func = Gleam_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Up_Box_Hook'Address)); + when Gleam_Down_Box => return + (if Func = Gleam_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Down_Box_Hook'Address)); + when Gleam_Up_Frame => return + (if Func = Gleam_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Up_Frame_Hook'Address)); + when Gleam_Down_Frame => return + (if Func = Gleam_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Down_Frame_Hook'Address)); + when Gleam_Thin_Up_Box => return + (if Func = Gleam_Thin_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Thin_Up_Box_Hook'Address)); + when Gleam_Thin_Down_Box => return + (if Func = Gleam_Thin_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Thin_Down_Box_Hook'Address)); + when Gleam_Round_Up_Box => return + (if Func = Gleam_Round_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Round_Up_Box_Hook'Address)); + when Gleam_Round_Down_Box => return + (if Func = Gleam_Round_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Round_Down_Box_Hook'Address)); + when Free_Box => return + (if Func = Free_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Free_Box_Hook'Address)); + end case; + end To_C; + + +end FLTK.Box_Draw_Marshal; + + diff --git a/body/fltk-box_draw_marshal.ads b/body/fltk-box_draw_marshal.ads new file mode 100644 index 0000000..373a3a8 --- /dev/null +++ b/body/fltk-box_draw_marshal.ads @@ -0,0 +1,28 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Static; + + +private package FLTK.Box_Draw_Marshal is + + + function To_Ada + (Kind : in Box_Kind; + Ptr : in Storage.Integer_Address) + return FLTK.Static.Box_Draw_Function; + + function To_C + (Kind : in Box_Kind; + Func : in FLTK.Static.Box_Draw_Function) + return Storage.Integer_Address; + + +end FLTK.Box_Draw_Marshal; + + diff --git a/body/fltk-events.adb b/body/fltk-events.adb index a15c55b..8488785 100644 --- a/body/fltk-events.adb +++ b/body/fltk-events.adb @@ -7,6 +7,7 @@ with Ada.Assertions, + Ada.Containers.Vectors, Interfaces.C.Strings; use type @@ -71,6 +72,26 @@ package body FLTK.Events is pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); pragma Inline (fl_event_add_handler); + procedure fl_event_remove_handler + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_remove_handler, "fl_event_remove_handler"); + pragma Inline (fl_event_remove_handler); + + procedure fl_event_add_system_handler + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_event_add_system_handler, "fl_event_add_system_handler"); + pragma Inline (fl_event_add_system_handler); + + procedure fl_event_remove_system_handler + (H : in Storage.Integer_Address); + pragma Import (C, fl_event_remove_system_handler, "fl_event_remove_system_handler"); + pragma Inline (fl_event_remove_system_handler); + + + + + -- Dispatch -- + procedure fl_event_set_dispatch (F : in Storage.Integer_Address); pragma Import (C, fl_event_set_dispatch, "fl_event_set_dispatch"); @@ -369,22 +390,65 @@ package body FLTK.Events is -- Hooks -- ------------- + -- This is handled on the Ada side since otherwise marshalling the + -- types from C++ to Ada would be extremely difficult. This hook is + -- passed during package init. + package Handler_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Event_Handler); + + Handlers : Handler_Vectors.Vector; + function Event_Handler_Hook (Num : in Interfaces.C.int) - return Interfaces.C.int - is - Ret_Val : Event_Outcome; + return Interfaces.C.int; + pragma Convention (C, Event_Handler_Hook); + + function Event_Handler_Hook + (Num : in Interfaces.C.int) + return Interfaces.C.int is 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); + for Call of reverse Handlers loop + if Call (Event_Kind'Val (Num)) /= Not_Handled then + return Event_Outcome'Pos (Handled); end if; end loop; return Event_Outcome'Pos (Not_Handled); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Event_Handler hook received unexpected event int value of " & + Interfaces.C.int'Image (Num); end Event_Handler_Hook; + -- This is handled on the Ada side because otherwise there would be + -- no way to specify which callback to remove in FLTK once one was + -- added. This is because Fl::remove_system_handler does not pay + -- attention to the void * data. This hook is passed during package init. + package System_Handler_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => System_Handler); + + System_Handlers : System_Handler_Vectors.Vector; + + function System_Handler_Hook + (E, U : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Convention (C, System_Handler_Hook); + + function System_Handler_Hook + (E, U : in Storage.Integer_Address) + return Interfaces.C.int is + begin + for Call of reverse System_Handlers loop + if Call (System_Event (Storage.To_Address (E))) = Handled then + return Event_Outcome'Pos (Handled); + end if; + end loop; + return Event_Outcome'Pos (Not_Handled); + end System_Handler_Hook; + + function Dispatch_Hook (Num : in Interfaces.C.int; Ptr : in Storage.Integer_Address) @@ -403,13 +467,27 @@ package body FLTK.Events is 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 " & + "Event_Dispatch hook received unexpected event int value of " & Interfaces.C.int'Image (Num); end Dispatch_Hook; + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out FLTK_Events_Final_Controller) is + begin + fl_event_remove_handler (Storage.To_Integer (Event_Handler_Hook'Address)); + fl_event_remove_system_handler (Storage.To_Integer (System_Handler_Hook'Address)); + end Finalize; + + + + ----------------------- -- API Subprograms -- ----------------------- @@ -417,14 +495,14 @@ package body FLTK.Events is -- Handlers -- procedure Add_Handler - (Func : in Event_Handler) is + (Func : in not null Event_Handler) is begin Handlers.Append (Func); end Add_Handler; procedure Remove_Handler - (Func : in Event_Handler) is + (Func : in not null Event_Handler) is begin for I in reverse Handlers.First_Index .. Handlers.Last_Index loop if Handlers (I) = Func then @@ -435,6 +513,29 @@ package body FLTK.Events is end Remove_Handler; + procedure Add_System_Handler + (Func : in not null System_Handler) is + begin + System_Handlers.Append (Func); + end Add_System_Handler; + + + procedure Remove_System_Handler + (Func : in not null System_Handler) is + begin + for I in reverse System_Handlers.First_Index .. System_Handlers.Last_Index loop + if System_Handlers (I) = Func then + System_Handlers.Delete (I); + return; + end if; + end loop; + end Remove_System_Handler; + + + + + -- Dispatch -- + function Get_Dispatch return Event_Dispatch is begin @@ -981,6 +1082,7 @@ begin fl_event_add_handler (Storage.To_Integer (Event_Handler_Hook'Address)); + fl_event_add_system_handler (Storage.To_Integer (System_Handler_Hook'Address), Null_Pointer); end FLTK.Events; diff --git a/body/fltk-help_dialogs.adb b/body/fltk-help_dialogs.adb index 48cdf18..6348527 100644 --- a/body/fltk-help_dialogs.adb +++ b/body/fltk-help_dialogs.adb @@ -6,7 +6,7 @@ with - FLTK.Show_Argv, + FLTK.Args_Marshal, Interfaces.C.Strings; use type @@ -227,7 +227,7 @@ package body FLTK.Help_Dialogs is procedure Show_With_Args (This : in out Help_Dialog) is begin - FLTK.Show_Argv.Dispatch (fl_help_dialog_show2'Access, This.Void_Ptr); + FLTK.Args_Marshal.Dispatch (fl_help_dialog_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/body/fltk-label_draw_marshal.adb b/body/fltk-label_draw_marshal.adb new file mode 100644 index 0000000..c5a2031 --- /dev/null +++ b/body/fltk-label_draw_marshal.adb @@ -0,0 +1,113 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + FLTK.Labels, + FLTK.Registry, + FLTK.Static, + Interfaces.C; + +use type + + FLTK.Static.Label_Draw_Function, + FLTK.Static.Label_Measure_Function; + + +package body FLTK.Label_Draw_Marshal is + + + package Chk renames Ada.Assertions; + + + + + Draw_Array : array (Label_Kind) of FLTK.Static.Label_Draw_Function; + Measure_Array : array (Label_Kind) of FLTK.Static.Label_Measure_Function; + + + + + procedure Label_Draw_Hook + (L : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + A : in Interfaces.Unsigned_16) + with Convention => C; + + procedure Label_Draw_Hook + (L : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + A : in Interfaces.Unsigned_16) + is + My_Label : access FLTK.Labels.Label'Class; + begin + pragma Assert (FLTK.Registry.Label_Store.Contains (L)); + My_Label := FLTK.Registry.Label_Store.Element (L); + Draw_Array (My_Label.Get_Kind) + (My_Label.all, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Alignment (A)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Label_Draw_Hook was handed Label with no back reference to Ada in registry"; + end Label_Draw_Hook; + + + procedure Label_Measure_Hook + (L : in Storage.Integer_Address; + W, H : out Interfaces.C.int) + with Convention => C; + + procedure Label_Measure_Hook + (L : in Storage.Integer_Address; + W, H : out Interfaces.C.int) + is + My_Label : access FLTK.Labels.Label'Class; + begin + pragma Assert (FLTK.Registry.Label_Store.Contains (L)); + My_Label := FLTK.Registry.Label_Store.Element (L); + Measure_Array (My_Label.Get_Kind) + (My_Label.all, + Integer (W), Integer (H)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Label_Measure_Hook was handed Label with no back reference to Ada in registry"; + end Label_Measure_Hook; + + + + + function To_C + (Kind : in Label_Kind; + Func : in FLTK.Static.Label_Draw_Function) + return Storage.Integer_Address is + begin + if Func = null then + return Null_Pointer; + end if; + Draw_Array (Kind) := Func; + return Storage.To_Integer (Label_Draw_Hook'Address); + end To_C; + + + function To_C + (Kind : in Label_Kind; + Func : in FLTK.Static.Label_Measure_Function) + return Storage.Integer_Address is + begin + if Func = null then + return Null_Pointer; + end if; + Measure_Array (Kind) := Func; + return Storage.To_Integer (Label_Measure_Hook'Address); + end To_C; + + +end FLTK.Label_Draw_Marshal; + + diff --git a/body/fltk-label_draw_marshal.ads b/body/fltk-label_draw_marshal.ads new file mode 100644 index 0000000..77d3885 --- /dev/null +++ b/body/fltk-label_draw_marshal.ads @@ -0,0 +1,28 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Static; + + +private package FLTK.Label_Draw_Marshal is + + + function To_C + (Kind : in Label_Kind; + Func : in FLTK.Static.Label_Draw_Function) + return Storage.Integer_Address; + + function To_C + (Kind : in Label_Kind; + Func : in FLTK.Static.Label_Measure_Function) + return Storage.Integer_Address; + + +end FLTK.Label_Draw_Marshal; + + diff --git a/body/fltk-labels.adb b/body/fltk-labels.adb index e03e5c5..b105675 100644 --- a/body/fltk-labels.adb +++ b/body/fltk-labels.adb @@ -6,8 +6,13 @@ with + FLTK.Registry, Interfaces.C.Strings; +use type + + Interfaces.C.Strings.chars_ptr; + package body FLTK.Labels is @@ -39,6 +44,12 @@ package body FLTK.Labels is -- Attributes -- + function fl_label_get_value + (L : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_label_get_value, "fl_label_get_value"); + pragma Inline (fl_label_get_value); + procedure fl_label_set_value (L : in Storage.Integer_Address; V : in Interfaces.C.Strings.chars_ptr); @@ -144,10 +155,11 @@ package body FLTK.Labels is (This : in out Label) is begin if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + FLTK.Registry.Label_Store.Delete (This.Void_Ptr); free_fl_label (This.Void_Ptr); This.Void_Ptr := Null_Pointer; - Interfaces.C.Strings.Free (This.My_Text); end if; + Interfaces.C.Strings.Free (This.My_Text); end Finalize; @@ -181,6 +193,7 @@ package body FLTK.Labels is Interfaces.C.unsigned (Place)); This.Set_Active (Active); This.Set_Inactive (Inactive); + FLTK.Registry.Label_Store.Insert (This.Void_Ptr, This'Unchecked_Access); end return; end Create; @@ -197,9 +210,15 @@ package body FLTK.Labels is function Get_Value (This : in Label) - return String is + return String + is + Text : Interfaces.C.Strings.chars_ptr := fl_label_get_value (This.Void_Ptr); begin - return Interfaces.C.Strings.Value (This.My_Text); + if Text = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text); + end if; end Get_Value; diff --git a/body/fltk-registry.ads b/body/fltk-registry.ads new file mode 100644 index 0000000..9911925 --- /dev/null +++ b/body/fltk-registry.ads @@ -0,0 +1,32 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Containers.Ordered_Maps, + FLTK.Labels; + + +private package FLTK.Registry is + + + -- It finally became untenable to keep only ad hoc back-references to Ada + -- when some crucial structs and objects don't have handy built-in space + -- for user data already available. + + + type Label_Access is access all FLTK.Labels.Label'Class; + + package Label_Backref_Maps is new Ada.Containers.Ordered_Maps + (Key_Type => Storage.Integer_Address, + Element_Type => Label_Access); + + Label_Store : Label_Backref_Maps.Map; + + +end FLTK.Registry; + + diff --git a/body/fltk-show_argv.adb b/body/fltk-show_argv.adb deleted file mode 100644 index 52e22e2..0000000 --- a/body/fltk-show_argv.adb +++ /dev/null @@ -1,50 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Ada.Command_Line, - Interfaces.C.Strings; - - -package body FLTK.Show_Argv is - - - package ACom renames Ada.Command_Line; - package IntC renames Interfaces.C; - package ICS renames Interfaces.C.Strings; - - - function Create_Argv - return ICS.chars_ptr_array - is - Result : ICS.chars_ptr_array (0 .. IntC.size_t (ACom.Argument_Count)); - begin - Result (0) := ICS.New_String (ACom.Command_Name); - for Index in Integer range 1 .. ACom.Argument_Count loop - Result (IntC.size_t (Index)) := ICS.New_String (ACom.Argument (Index)); - end loop; - return Result; - end Create_Argv; - - - procedure Dispatch - (Func : in Show_With_Args_Func; - CObj : in Storage.Integer_Address) - is - Argv : ICS.chars_ptr_array := Create_Argv; - begin - Func (CObj, IntC.int (ACom.Argument_Count + 1), - Storage.To_Integer (Argv (Argv'First)'Address)); - for Ptr of Argv loop - ICS.Free (Ptr); - end loop; - end Dispatch; - - -end FLTK.Show_Argv; - - diff --git a/body/fltk-show_argv.ads b/body/fltk-show_argv.ads deleted file mode 100644 index faa93a4..0000000 --- a/body/fltk-show_argv.ads +++ /dev/null @@ -1,37 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Interfaces.C; - - -private package FLTK.Show_Argv is - - - -- Used for implementing show(argc,argv) - - -- Dispatch marshalls the data, calls the function, then does cleanup - - type Show_With_Args_Func is access procedure - (CObj : in Storage.Integer_Address; - Argc : in Interfaces.C.int; - Argv : in Storage.Integer_Address); - - procedure Dispatch - (Func : in Show_With_Args_Func; - CObj : in Storage.Integer_Address); - - -private - - - pragma Convention (C, Show_With_Args_Func); - - -end FLTK.Show_Argv; - - diff --git a/body/fltk-static.adb b/body/fltk-static.adb index bd64a9e..5c2269f 100644 --- a/body/fltk-static.adb +++ b/body/fltk-static.adb @@ -8,8 +8,11 @@ with Ada.Assertions, Ada.Containers.Vectors, + Ada.Unchecked_Conversion, Interfaces.C.Strings, System.Address_To_Access_Conversions, + FLTK.Box_Draw_Marshal, + FLTK.Label_Draw_Marshal, FLTK.Static_Callback_Conversions; use type @@ -27,22 +30,94 @@ package body FLTK.Static is + ----------------- + -- Operators -- + ----------------- + + type File_Mode_Bitmask is mod 2 ** Interfaces.C.int'Size; + + function FMode_To_Bits is new + Ada.Unchecked_Conversion (File_Mode, File_Mode_Bitmask); + + function Bits_To_FMode is new + Ada.Unchecked_Conversion (File_Mode_Bitmask, File_Mode); + + + function "+" + (Left, Right : in File_Mode) + return File_Mode is + begin + return Bits_To_FMode (FMode_To_Bits (Left) or FMode_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in File_Mode) + return File_Mode is + begin + return Bits_To_FMode (FMode_To_Bits (Left) and not FMode_To_Bits (Right)); + end "-"; + + + + ------------------------ -- Functions From C -- ------------------------ - -- Interthread Notify -- + -- Command Line Arguments -- - procedure fl_static_add_awake_handler - (H, F : in Storage.Integer_Address); + function fl_static_arg + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_static_arg, "fl_static_arg"); + pragma Inline (fl_static_arg); + + procedure fl_static_args + (C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_static_args, "fl_static_args"); + pragma Inline (fl_static_args); + + function fl_static_args2 + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int; + H : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_args2, "fl_static_args2"); + pragma Inline (fl_static_args2); + + + + + -- Thread Notify -- + + function fl_static_add_awake_handler + (H, F : in Storage.Integer_Address) + return Interfaces.C.int; pragma Import (C, fl_static_add_awake_handler, "fl_static_add_awake_handler"); pragma Inline (fl_static_add_awake_handler); - procedure fl_static_get_awake_handler - (H, F : out Storage.Integer_Address); + function fl_static_get_awake_handler + (H, F : out Storage.Integer_Address) + return Interfaces.C.int; pragma Import (C, fl_static_get_awake_handler, "fl_static_get_awake_handler"); pragma Inline (fl_static_get_awake_handler); + function fl_static_awake2 + (H, F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_awake2, "fl_static_awake2"); + pragma Inline (fl_static_awake2); + + procedure fl_static_awake + (M : in Storage.Integer_Address); + pragma Import (C, fl_static_awake, "fl_static_awake"); + pragma Inline (fl_static_awake); + @@ -102,6 +177,11 @@ package body FLTK.Static is pragma Import (C, fl_static_add_clipboard_notify, "fl_static_add_clipboard_notify"); pragma Inline (fl_static_add_clipboard_notify); + procedure fl_static_remove_clipboard_notify + (H : in Storage.Integer_Address); + pragma Import (C, fl_static_remove_clipboard_notify, "fl_static_remove_clipboard_notify"); + pragma Inline (fl_static_remove_clipboard_notify); + @@ -153,14 +233,35 @@ package body FLTK.Static is + -- System Events -- + + procedure fl_static_add_system_handler + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_add_system_handler, "fl_static_add_system_handler"); + pragma Inline (fl_static_add_system_handler); + + + + -- Custom Colors -- + function fl_static_get_color2 + (C : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_static_get_color2, "fl_static_get_color2"); + pragma Inline (fl_static_get_color2); + procedure fl_static_get_color (C : in Interfaces.C.unsigned; R, G, B : out Interfaces.C.unsigned_char); pragma Import (C, fl_static_get_color, "fl_static_get_color"); pragma Inline (fl_static_get_color); + procedure fl_static_set_color2 + (T, F : in Interfaces.C.unsigned); + pragma Import (C, fl_static_set_color2, "fl_static_set_color2"); + pragma Inline (fl_static_set_color2); + procedure fl_static_set_color (C : in Interfaces.C.unsigned; R, G, B : in Interfaces.C.unsigned_char); @@ -173,6 +274,17 @@ package body FLTK.Static is pragma Import (C, fl_static_free_color, "fl_static_free_color"); pragma Inline (fl_static_free_color); + function fl_static_get_box_color + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_static_get_box_color, "fl_static_get_box_color"); + pragma Inline (fl_static_get_box_color); + + procedure fl_static_set_box_color + (T : in Interfaces.C.unsigned); + pragma Import (C, fl_static_set_box_color, "fl_static_set_box_color"); + pragma Inline (fl_static_set_box_color); + procedure fl_static_foreground (R, G, B : in Interfaces.C.unsigned_char); pragma Import (C, fl_static_foreground, "fl_static_foreground"); @@ -210,6 +322,12 @@ package body FLTK.Static is pragma Import (C, fl_static_set_font, "fl_static_set_font"); pragma Inline (fl_static_set_font); + procedure fl_static_set_font2 + (T : in Interfaces.C.int; + S : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_static_set_font2, "fl_static_set_font2"); + pragma Inline (fl_static_set_font2); + function fl_static_get_font_sizes (F : in Interfaces.C.int; A : out Storage.Integer_Address) @@ -258,11 +376,24 @@ package body FLTK.Static is pragma Import (C, fl_static_box_dy, "fl_static_box_dy"); pragma Inline (fl_static_box_dy); + function fl_static_get_boxtype + (T : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_static_get_boxtype, "fl_static_get_boxtype"); + pragma Inline (fl_static_get_boxtype); + procedure fl_static_set_boxtype (T, F : in Interfaces.C.int); pragma Import (C, fl_static_set_boxtype, "fl_static_set_boxtype"); pragma Inline (fl_static_set_boxtype); + procedure fl_static_set_boxtype2 + (T : in Interfaces.C.int; + F : in Storage.Integer_Address; + DX, DY, DW, DH : in Interfaces.C.unsigned_char); + pragma Import (C, fl_static_set_boxtype2, "fl_static_set_boxtype2"); + pragma Inline (fl_static_set_boxtype2); + function fl_static_draw_box_active return Interfaces.C.int; pragma Import (C, fl_static_draw_box_active, "fl_static_draw_box_active"); @@ -271,6 +402,17 @@ package body FLTK.Static is + -- Label_Kind Attributes -- + + procedure fl_static_set_labeltype + (K : in Interfaces.C.int; + D, M : in Storage.Integer_Address); + pragma Import (C, fl_static_set_labeltype, "fl_static_set_labeltype"); + pragma Inline (fl_static_set_labeltype); + + + + -- Clipboard / Selection -- procedure fl_static_copy @@ -292,11 +434,22 @@ package body FLTK.Static is pragma Import (C, fl_static_selection, "fl_static_selection"); pragma Inline (fl_static_selection); + function fl_static_clipboard_contains + (K : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_static_clipboard_contains, "fl_static_clipboard_contains"); + pragma Inline (fl_static_clipboard_contains); + -- Dragon Drop -- + function fl_static_dnd + return Interfaces.C.int; + pragma Import (C, fl_static_dnd, "fl_static_dnd"); + pragma Inline (fl_static_dnd); + function fl_static_get_dnd_text_ops return Interfaces.C.int; pragma Import (C, fl_static_get_dnd_text_ops, "fl_static_get_dnd_text_ops"); @@ -313,7 +466,7 @@ package body FLTK.Static is -- Windows -- procedure fl_static_default_atclose - (W : in Storage.Integer_Address); + (W, U : in Storage.Integer_Address); pragma Import (C, fl_static_default_atclose, "fl_static_default_atclose"); pragma Inline (fl_static_default_atclose); @@ -422,6 +575,33 @@ package body FLTK.Static is -- Callback Hooks -- ---------------------- + Current_Args_Handler : Args_Handler; + + function Args_Hook + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int; + pragma Convention (C, Args_Hook); + + function Args_Hook + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int + is + Result : Natural; + begin + Result := Current_Args_Handler (Positive (I)); + I := I + Interfaces.C.int (Result); + return Interfaces.C.int (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Args_Handler callback was supplied unexpected int i value of " & + Interfaces.C.int'Image (I); + end Args_Hook; + + procedure Awake_Hook (U : in Storage.Integer_Address); pragma Convention (C, Awake_Hook); @@ -429,7 +609,9 @@ package body FLTK.Static is procedure Awake_Hook (U : in Storage.Integer_Address) is begin - Conv.To_Awake_Access (U).all; + if U /= Null_Pointer then + Conv.To_Awake_Access (U).all; + end if; end Awake_Hook; @@ -446,7 +628,8 @@ 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. + -- added. This is because Fl::remove_clipboard_notify does not pay + -- attention to the void * data. This hook is passed during package init. package Clipboard_Notify_Vectors is new Ada.Containers.Vectors (Index_Type => Positive, Element_Type => Clipboard_Notify_Handler); @@ -462,9 +645,15 @@ package body FLTK.Static is (S : in Interfaces.C.int; U : in Storage.Integer_Address) is begin + pragma Assert (S in + Buffer_Kind'Pos (Buffer_Kind'First) .. Buffer_Kind'Pos (Buffer_Kind'Last)); for Call of Current_Clip_Notes loop Call.all (Buffer_Kind'Val (S)); end loop; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Clipboard_Notify_Hook was passed unexpected Buffer_Kind int value of " & + Interfaces.C.int'Image (S); end Clipboard_Notify_Hook; @@ -494,17 +683,99 @@ package body FLTK.Static is + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out FLTK_Static_Final_Controller) is + begin + FLTK.Args_Marshal.Free_Argv (The_Argv); + for Override of Font_Overrides loop + Interfaces.C.Strings.Free (Override); + end loop; + fl_static_remove_clipboard_notify (Storage.To_Integer (Clipboard_Notify_Hook'Address)); + end Finalize; + + + + ----------------------- -- API Subprograms -- ----------------------- - -- Interthread Notify -- + -- Command Line Arguments -- + + function Parse_Arg + (Index : in Positive) + return Natural + is + Count : Interfaces.C.int := Interfaces.C.int (Index); + begin + return Natural (fl_static_arg + (The_Argv'Length, + Storage.To_Integer (The_Argv (The_Argv'First)'Address), + Count)); + end Parse_Arg; + + + procedure Parse_Args is + begin + fl_static_args (The_Argv'Length, Storage.To_Integer (The_Argv (The_Argv'First)'Address)); + end Parse_Args; + + + procedure Parse_Args + (Count : out Natural; + Func : in Args_Handler := null) + is + My_Count : Interfaces.C.int := 1; + Result : Interfaces.C.int; + begin + Current_Args_Handler := Func; + Result := fl_static_args2 + (The_Argv'Length, + Storage.To_Integer (The_Argv (The_Argv'First)'Address), + My_Count, + (if Func = null then Null_Pointer else Storage.To_Integer (Args_Hook'Address))); + Count := Integer (My_Count) - 1; + if Result = 0 then + raise Argument_Error with + "Fl::args could not recognise switch at argument number " & + Interfaces.C.int'Image (My_Count); + else + pragma Assert (Result > 0); + end if; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::args produced unexpected i parameter of " & Interfaces.C.int'Image (My_Count); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::args returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Parse_Args; + + + + + -- Thread Notify -- procedure Add_Awake_Handler - (Func : in Awake_Handler) is + (Func : in Awake_Handler) + is + Result : Interfaces.C.int := fl_static_add_awake_handler + (Storage.To_Integer (Awake_Hook'Address), + Conv.To_Address (Func)); begin - fl_static_add_awake_handler - (Storage.To_Integer (Awake_Hook'Address), Conv.To_Address (Func)); + pragma Assert (Result = 0); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with + "Fl::add_awake_handler_ failed to register Awake_Handler callback"; + else + raise Internal_FLTK_Error with + "Fl::add_awake_handler_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; end Add_Awake_Handler; @@ -512,40 +783,77 @@ package body FLTK.Static is return Awake_Handler is Hook, Func : Storage.Integer_Address; + Result : Interfaces.C.int := fl_static_get_awake_handler (Hook, Func); begin - fl_static_get_awake_handler (Hook, Func); + pragma Assert (Result = 0); return Conv.To_Awake_Access (Func); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with + "Fl::get_awake_handler_ invoked without prior awake setup"; + else + raise Internal_FLTK_Error with + "Fl::get_awake_handler_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; end Get_Awake_Handler; + procedure Awake + (Func : in Awake_Handler) + is + Result : Interfaces.C.int := fl_static_awake2 + (Storage.To_Integer (Awake_Hook'Address), + Conv.To_Address (Func)); + begin + pragma Assert (Result = 0); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with "Fl::awake failed to register Awake_Handler callback"; + else + raise Internal_FLTK_Error with "Fl::awake returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; + end Awake; + + + procedure Awake is + begin + fl_static_awake (Null_Pointer); + end Awake; + + -- Pre-Eventloop Callbacks -- procedure Add_Check - (Func : in Timeout_Handler) is + (Func : in not null Timeout_Handler) is begin fl_static_add_check - (Storage.To_Integer (Timeout_Hook'Address), Conv.To_Address (Func)); + (Storage.To_Integer (Timeout_Hook'Address), + Conv.To_Address (Timeout_Handler'(Func))); end Add_Check; function Has_Check - (Func : in Timeout_Handler) + (Func : in not null Timeout_Handler) return Boolean is begin return fl_static_has_check (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)) /= 0; + Conv.To_Address (Timeout_Handler'(Func))) /= 0; end Has_Check; procedure Remove_Check - (Func : in Timeout_Handler) is + (Func : in not null Timeout_Handler) is begin fl_static_remove_check (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Timeout_Handler'(Func))); end Remove_Check; @@ -554,43 +862,43 @@ package body FLTK.Static is -- Timer Callbacks -- procedure Add_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler) is + (Seconds : in Long_Float; + Func : in not null Timeout_Handler) is begin fl_static_add_timeout (Interfaces.C.double (Seconds), Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Timeout_Handler'(Func))); end Add_Timeout; function Has_Timeout - (Func : in Timeout_Handler) + (Func : in not null Timeout_Handler) return Boolean is begin return fl_static_has_timeout (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)) /= 0; + Conv.To_Address (Timeout_Handler'(Func))) /= 0; end Has_Timeout; procedure Remove_Timeout - (Func : in Timeout_Handler) is + (Func : in not null Timeout_Handler) is begin fl_static_remove_timeout (Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Timeout_Handler'(Func))); end Remove_Timeout; procedure Repeat_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler) is + (Seconds : in Long_Float; + Func : in not null Timeout_Handler) is begin fl_static_repeat_timeout (Interfaces.C.double (Seconds), Storage.To_Integer (Timeout_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Timeout_Handler'(Func))); end Repeat_Timeout; @@ -599,16 +907,16 @@ package body FLTK.Static is -- Clipboard Callbacks -- procedure Add_Clipboard_Notify - (Func : in Clipboard_Notify_Handler) is + (Func : in not null Clipboard_Notify_Handler) is begin Current_Clip_Notes.Append (Func); end Add_Clipboard_Notify; procedure Remove_Clipboard_Notify - (Func : in Clipboard_Notify_Handler) is + (Func : in not null Clipboard_Notify_Handler) is begin - for Index in Current_Clip_Notes.First_Index .. Current_Clip_Notes.Last_Index loop + for Index in reverse Current_Clip_Notes.First_Index .. Current_Clip_Notes.Last_Index loop if Current_Clip_Notes (Index) = Func then Current_Clip_Notes.Delete (Index); return; @@ -622,8 +930,8 @@ package body FLTK.Static is -- File Descriptor Waiting Callbacks -- procedure Add_File_Descriptor - (FD : in File_Descriptor; - Func : in File_Handler) is + (FD : in File_Descriptor; + Func : in not null File_Handler) is begin fl_static_add_fd (Interfaces.C.int (FD), @@ -633,13 +941,13 @@ package body FLTK.Static is procedure Add_File_Descriptor - (FD : in File_Descriptor; - Mode : in File_Mode; - Func : in File_Handler) is + (FD : in File_Descriptor; + Mode : in File_Mode; + Func : in not null File_Handler) is begin fl_static_add_fd2 (Interfaces.C.int (FD), - File_Mode_Codes (Mode), + FMode_To_Cint (Mode), Storage.To_Integer (FD_Hook'Address), Conv.To_Address (Func)); end Add_File_Descriptor; @@ -656,7 +964,7 @@ package body FLTK.Static is (FD : in File_Descriptor; Mode : in File_Mode) is begin - fl_static_remove_fd2 (Interfaces.C.int (FD), File_Mode_Codes (Mode)); + fl_static_remove_fd2 (Interfaces.C.int (FD), FMode_To_Cint (Mode)); end Remove_File_Descriptor; @@ -665,30 +973,30 @@ package body FLTK.Static is -- Idle Callbacks -- procedure Add_Idle - (Func : in Idle_Handler) is + (Func : in not null Idle_Handler) is begin fl_static_add_idle (Storage.To_Integer (Idle_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Idle_Handler'(Func))); end Add_Idle; function Has_Idle - (Func : in Idle_Handler) + (Func : in not null Idle_Handler) return Boolean is begin return fl_static_has_idle (Storage.To_Integer (Idle_Hook'Address), - Conv.To_Address (Func)) /= 0; + Conv.To_Address (Idle_Handler'(Func))) /= 0; end Has_Idle; procedure Remove_Idle - (Func : in Idle_Handler) is + (Func : in not null Idle_Handler) is begin fl_static_remove_idle (Storage.To_Integer (Idle_Hook'Address), - Conv.To_Address (Func)); + Conv.To_Address (Idle_Handler'(Func))); end Remove_Idle; @@ -696,6 +1004,14 @@ package body FLTK.Static is -- Custom Colors -- + function Get_Color + (From : in Color) + return Color is + begin + return Color (fl_static_get_color2 (Interfaces.C.unsigned (From))); + end Get_Color; + + procedure Get_Color (From : in Color; R, G, B : out Color_Component) is @@ -709,11 +1025,20 @@ package body FLTK.Static is procedure Set_Color - (To : in Color; + (Target, Source : in Color) is + begin + fl_static_set_color2 + (Interfaces.C.unsigned (Target), + Interfaces.C.unsigned (Source)); + end Set_Color; + + + procedure Set_Color + (Target : in Color; R, G, B : in Color_Component) is begin fl_static_set_color - (Interfaces.C.unsigned (To), + (Interfaces.C.unsigned (Target), Interfaces.C.unsigned_char (R), Interfaces.C.unsigned_char (G), Interfaces.C.unsigned_char (B)); @@ -730,6 +1055,21 @@ package body FLTK.Static is end Free_Color; + function Get_Box_Color + (Tone : in Color) + return Color is + begin + return Color (fl_static_get_box_color (Interfaces.C.unsigned (Tone))); + end Get_Box_Color; + + + procedure Set_Box_Color + (Tone : in Color) is + begin + fl_static_set_box_color (Interfaces.C.unsigned (Tone)); + end Set_Box_Color; + + procedure Set_Foreground (R, G, B : in Color_Component) is begin @@ -783,9 +1123,19 @@ package body FLTK.Static is procedure Set_Font_Kind - (To, From : in Font_Kind) is + (Target, Source : in Font_Kind) is begin - fl_static_set_font (Font_Kind'Pos (To), Font_Kind'Pos (From)); + fl_static_set_font (Font_Kind'Pos (Target), Font_Kind'Pos (Source)); + end Set_Font_Kind; + + + procedure Set_Font_Kind + (Target : in Font_Kind; + Source : in String) is + begin + Interfaces.C.Strings.Free (Font_Overrides (Target)); + Font_Overrides (Target) := Interfaces.C.Strings.New_String (Source); + fl_static_set_font2 (Font_Kind'Pos (Target), Font_Overrides (Target)); end Set_Font_Kind; @@ -806,9 +1156,15 @@ package body FLTK.Static is procedure Setup_Fonts - (How_Many_Set_Up : out Natural) is + (How_Many_Set_Up : out Natural) + is + Result : Interfaces.C.int := fl_static_set_fonts; begin - How_Many_Set_Up := Natural (fl_static_set_fonts); + How_Many_Set_Up := Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::set_fonts returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Setup_Fonts; @@ -862,22 +1218,53 @@ package body FLTK.Static is end Draw_Box_Active; - -- function Get_Box_Draw_Function - -- (Kind : in Box_Kind) - -- return Box_Draw_Function is - -- begin - -- return null; - -- end Get_Box_Draw_Function; + function Get_Box_Draw_Function + (Kind : in Box_Kind) + return Box_Draw_Function is + begin + return FLTK.Box_Draw_Marshal.To_Ada (Kind, fl_static_get_boxtype (Box_Kind'Pos (Kind))); + end Get_Box_Draw_Function; + + procedure Set_Box_Draw_Function + (Kind : in Box_Kind; + Func : in Box_Draw_Function; + Offset_X, Offset_Y : in Byte_Integer := 0; + Offset_W, Offset_H : in Byte_Integer := 0) is + begin + fl_static_set_boxtype2 + (Box_Kind'Pos (Kind), + FLTK.Box_Draw_Marshal.To_C (Kind, Func), + Interfaces.C.unsigned_char (Offset_X), + Interfaces.C.unsigned_char (Offset_Y), + Interfaces.C.unsigned_char (Offset_W), + Interfaces.C.unsigned_char (Offset_H)); + end Set_Box_Draw_Function; - -- 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; + + + + -- Label_Kind Attributes -- + + procedure Set_Label_Kind + (Target, Source : in Label_Kind) is + begin + -- As of FLTK 1.3.11 there is no definition given for this function + -- so this is null to avoid linker errors. + null; + end Set_Label_Kind; + + + procedure Set_Label_Draw_Function + (Kind : in Label_Kind; + Draw_Func : in Label_Draw_Function; + Measure_Func : in Label_Measure_Function) is + begin + fl_static_set_labeltype + (Label_Kind'Pos (Kind), + FLTK.Label_Draw_Marshal.To_C (Kind, Draw_Func), + FLTK.Label_Draw_Marshal.To_C (Kind, Measure_Func)); + end Set_Label_Draw_Function; @@ -916,10 +1303,25 @@ package body FLTK.Static is end Selection; + function Clipboard_Contains + (Kind : in String) + return Boolean is + begin + return fl_static_clipboard_contains (Interfaces.C.To_C (Kind)) /= 0; + end Clipboard_Contains; + + -- Dragon Drop -- + procedure Drag_Drop_Start is + Ignore : Interfaces.C.int := fl_static_dnd; + begin + null; + end Drag_Drop_Start; + + function Get_Drag_Drop_Text_Support return Boolean is begin @@ -941,7 +1343,13 @@ package body FLTK.Static is procedure Default_Window_Close (Item : in out FLTK.Widgets.Widget'Class) is begin - fl_static_default_atclose (Wrapper (Item).Void_Ptr); + pragma Assert (Wrapper (Item).Void_Ptr /= Null_Pointer); + fl_static_default_atclose + (Wrapper (Item).Void_Ptr, + fl_widget_get_user_data (Wrapper (Item).Void_Ptr)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::default_atclose received uninitialised widget"; end Default_Window_Close; @@ -1049,15 +1457,22 @@ package body FLTK.Static is procedure Set_Scheme (To : in String) is begin + -- A copy of the Scheme string is stored in FLTK fl_static_set_scheme (Interfaces.C.To_C (To)); end Set_Scheme; function Is_Scheme (Scheme : in String) - return Boolean is + return Boolean + is + Result : Interfaces.C.int := fl_static_is_scheme (Interfaces.C.To_C (Scheme)); begin - return fl_static_is_scheme (Interfaces.C.To_C (Scheme)) /= 0; + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::is_scheme returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Is_Scheme; @@ -1086,9 +1501,15 @@ package body FLTK.Static is -- Scrollbars -- function Get_Default_Scrollbar_Size - return Natural is + return Natural + is + Result : Interfaces.C.int := fl_static_get_scrollbar_size; begin - return Natural (fl_static_get_scrollbar_size); + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::scrollbar_size returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Get_Default_Scrollbar_Size; diff --git a/body/fltk-widgets-groups-windows-double-overlay.adb b/body/fltk-widgets-groups-windows-double-overlay.adb index e6d00cf..2534d31 100644 --- a/body/fltk-widgets-groups-windows-double-overlay.adb +++ b/body/fltk-widgets-groups-windows-double-overlay.adb @@ -6,7 +6,7 @@ with - FLTK.Show_Argv, + FLTK.Args_Marshal, Interfaces.C, System.Address_To_Access_Conversions; @@ -257,7 +257,7 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is procedure Show_With_Args (This : in out Overlay_Window) is begin - FLTK.Show_Argv.Dispatch (fl_overlay_window_show2'Access, This.Void_Ptr); + FLTK.Args_Marshal.Dispatch (fl_overlay_window_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/body/fltk-widgets-groups-windows-double.adb b/body/fltk-widgets-groups-windows-double.adb index d4ec67c..9c388e0 100644 --- a/body/fltk-widgets-groups-windows-double.adb +++ b/body/fltk-widgets-groups-windows-double.adb @@ -6,7 +6,7 @@ with - FLTK.Show_Argv, + FLTK.Args_Marshal, Interfaces.C; @@ -225,7 +225,7 @@ package body FLTK.Widgets.Groups.Windows.Double is procedure Show_With_Args (This : in out Double_Window) is begin - FLTK.Show_Argv.Dispatch (fl_double_window_show2'Access, This.Void_Ptr); + FLTK.Args_Marshal.Dispatch (fl_double_window_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/body/fltk-widgets-groups-windows-opengl.adb b/body/fltk-widgets-groups-windows-opengl.adb index 55e80b6..c2bf078 100644 --- a/body/fltk-widgets-groups-windows-opengl.adb +++ b/body/fltk-widgets-groups-windows-opengl.adb @@ -6,7 +6,7 @@ with - FLTK.Show_Argv, + FLTK.Args_Marshal, Interfaces.C, System; @@ -355,7 +355,7 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is procedure Show_With_Args (This : in out GL_Window) is begin - FLTK.Show_Argv.Dispatch (fl_gl_window_show2'Access, This.Void_Ptr); + FLTK.Args_Marshal.Dispatch (fl_gl_window_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/body/fltk-widgets-groups-windows-single.adb b/body/fltk-widgets-groups-windows-single.adb index 7eed730..6788d1a 100644 --- a/body/fltk-widgets-groups-windows-single.adb +++ b/body/fltk-widgets-groups-windows-single.adb @@ -6,7 +6,7 @@ with - FLTK.Show_Argv, + FLTK.Args_Marshal, Interfaces.C; @@ -213,7 +213,7 @@ package body FLTK.Widgets.Groups.Windows.Single is procedure Show_With_Args (This : in out Single_Window) is begin - FLTK.Show_Argv.Dispatch (fl_single_window_show2'Access, This.Void_Ptr); + FLTK.Args_Marshal.Dispatch (fl_single_window_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/body/fltk-widgets-groups-windows.adb b/body/fltk-widgets-groups-windows.adb index 3ff2f32..76847db 100644 --- a/body/fltk-widgets-groups-windows.adb +++ b/body/fltk-widgets-groups-windows.adb @@ -9,7 +9,7 @@ with Ada.Command_Line, Interfaces.C.Strings, FLTK.Images.RGB, - FLTK.Show_Argv; + FLTK.Args_Marshal; use type @@ -513,7 +513,7 @@ package body FLTK.Widgets.Groups.Windows is procedure Show_With_Args (This : in out Window) is begin - FLTK.Show_Argv.Dispatch (fl_window_show2'Access, This.Void_Ptr); + FLTK.Args_Marshal.Dispatch (fl_window_show2'Access, This.Void_Ptr); end Show_With_Args; -- cgit