diff options
Diffstat (limited to 'body')
189 files changed, 3956 insertions, 1235 deletions
diff --git a/body/c_fl.cpp b/body/c_fl.cpp index a9e6d16..7bfc444 100644 --- a/body/c_fl.cpp +++ b/body/c_fl.cpp @@ -6,6 +6,7 @@ #include <FL/Enumerations.H> #include <FL/Fl.H> +#include <FL/Fl_Widget.H> #include "c_fl.h" @@ -51,88 +52,174 @@ size_t c_pointer_size() { -unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b) { - return fl_rgb_color(r, g, b); +const int fl_enum_num_red = FL_NUM_RED; +const int fl_enum_num_green = FL_NUM_GREEN; +const int fl_enum_num_blue = FL_NUM_BLUE; +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<unsigned int>(fl_rgb_color(l)); } -unsigned int fl_enum_contrast(unsigned int f, unsigned int b) { - return fl_contrast(f, b); +unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b) { + return static_cast<unsigned int>(fl_rgb_color(r, g, b)); } +unsigned int fl_enum_color_cube(int r, int g, int b) { + return static_cast<unsigned int>(fl_color_cube(r, g, b)); +} +unsigned int fl_enum_gray_ramp(int l) { + return static_cast<unsigned int>(fl_gray_ramp(l)); +} +unsigned int fl_enum_darker(unsigned int c) { + return static_cast<unsigned int>(fl_darker(static_cast<Fl_Color>(c))); +} -int fl_abi_check(int v) { - return Fl::abi_check(v); +unsigned int fl_enum_lighter(unsigned int c) { + return static_cast<unsigned int>(fl_lighter(static_cast<Fl_Color>(c))); } -int fl_abi_version() { - return Fl::abi_version(); +unsigned int fl_enum_contrast(unsigned int f, unsigned int b) { + return static_cast<unsigned int>(fl_contrast + (static_cast<Fl_Color>(f), static_cast<Fl_Color>(b))); } -int fl_api_version() { - return Fl::api_version(); +unsigned int fl_enum_inactive(unsigned int c) { + return static_cast<unsigned int>(fl_inactive(static_cast<Fl_Color>(c))); } -double fl_version() { - return Fl::version(); +unsigned int fl_enum_color_average(unsigned int c1, unsigned int c2, float w) { + return static_cast<unsigned int>(fl_color_average + (static_cast<Fl_Color>(c1), static_cast<Fl_Color>(c2), w)); } -void fl_awake() { - Fl::awake(); +int fl_enum_box(int b) { + return static_cast<int>(fl_box(static_cast<Fl_Boxtype>(b))); } -void fl_lock() { - Fl::lock(); +int fl_enum_frame(int b) { + return static_cast<int>(fl_frame(static_cast<Fl_Boxtype>(b))); } -void fl_unlock() { - Fl::unlock(); +int fl_enum_down(int b) { + return static_cast<int>(fl_down(static_cast<Fl_Boxtype>(b))); } -int fl_get_damage() { - return Fl::damage(); +const char * const fl_clip_image_char_ptr = Fl::clipboard_image; + +const char * const fl_clip_plain_text_char_ptr = Fl::clipboard_plain_text; + + + + +int fl_abi_check(int v) { + return Fl::abi_check(v); } -void fl_set_damage(int v) { - Fl::damage(v); +int fl_abi_version() { + return Fl::abi_version(); } -void fl_flush() { - Fl::flush(); +int fl_api_version() { + return Fl::api_version(); } -void fl_redraw() { - Fl::redraw(); +double fl_version() { + return Fl::version(); +} + + + + +short fl_inside_callback = 0; + +void fl_delete_widget(void * w) { + Fl::delete_widget(static_cast<Fl_Widget*>(w)); } int fl_check() { - return Fl::check(); + short temp = fl_inside_callback; + fl_inside_callback = 1; + int ret = Fl::check(); + fl_inside_callback = temp; + return ret; } int fl_ready() { - return Fl::ready(); + short temp = fl_inside_callback; + fl_inside_callback = 1; + int ret = Fl::ready(); + fl_inside_callback = temp; + return ret; } int fl_wait() { - return Fl::wait(); + short temp = fl_inside_callback; + fl_inside_callback = 1; + int ret = Fl::wait(); + fl_inside_callback = temp; + return ret; } -int fl_wait2(double s) { - return Fl::wait(s); +double fl_wait2(double s) { + short temp = fl_inside_callback; + fl_inside_callback = 1; + double ret = Fl::wait(s); + fl_inside_callback = temp; + return ret; } int fl_run() { - return Fl::run(); + short temp = fl_inside_callback; + fl_inside_callback = 1; + int ret = Fl::run(); + fl_inside_callback = temp; + return ret; } diff --git a/body/c_fl.h b/body/c_fl.h index 51dbedb..2149640 100644 --- a/body/c_fl.h +++ b/body/c_fl.h @@ -8,6 +8,9 @@ #define FL_GUARD +#include <cstddef> + + extern "C" const short fl_align_center; extern "C" const short fl_align_top; extern "C" const short fl_align_bottom; @@ -40,8 +43,45 @@ extern "C" const short fl_mod_command; extern "C" size_t c_pointer_size(); +extern "C" const int fl_enum_num_red; +extern "C" const int fl_enum_num_green; +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); +extern "C" unsigned int fl_enum_gray_ramp(int l); +extern "C" unsigned int fl_enum_darker(unsigned int c); +extern "C" unsigned int fl_enum_lighter(unsigned int c); extern "C" unsigned int fl_enum_contrast(unsigned int f, unsigned int b); +extern "C" unsigned int fl_enum_inactive(unsigned int c); +extern "C" unsigned int fl_enum_color_average(unsigned int c1, unsigned int c2, float w); + + +extern "C" int fl_enum_box(int b); +extern "C" int fl_enum_frame(int b); +extern "C" int fl_enum_down(int b); + + +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); @@ -50,21 +90,14 @@ 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); extern "C" int fl_check(); extern "C" int fl_ready(); extern "C" int fl_wait(); -extern "C" int fl_wait2(double s); +extern "C" double fl_wait2(double s); extern "C" int fl_run(); diff --git a/body/c_fl_adjuster.cpp b/body/c_fl_adjuster.cpp index 37a52cd..5550250 100644 --- a/body/c_fl_adjuster.cpp +++ b/body/c_fl_adjuster.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Adjuster.H> #include "c_fl_adjuster.h" +#include "c_fl.h" @@ -67,7 +68,11 @@ ADJUSTER new_fl_adjuster(int x, int y, int w, int h, char* label) { } void free_fl_adjuster(ADJUSTER a) { - delete static_cast<My_Adjuster*>(a); + if (fl_inside_callback) { + fl_delete_widget(a); + } else { + delete static_cast<My_Adjuster*>(a); + } } diff --git a/body/c_fl_box.cpp b/body/c_fl_box.cpp index e9c170d..22ef21e 100644 --- a/body/c_fl_box.cpp +++ b/body/c_fl_box.cpp @@ -6,6 +6,17 @@ #include <FL/Fl_Box.H> #include "c_fl_box.h" +#include "c_fl.h" + + + + +// Telprot stopover + +extern "C" void box_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); +void fl_box_extra_init(void * adaobj, int x, int y, int w, int h, const char * label) { + box_extra_init_hook(adaobj, x, y, w, h, label); +} @@ -55,7 +66,11 @@ BOX new_fl_box2(int k, int x, int y, int w, int h, char * label) { } void free_fl_box(BOX b) { - delete static_cast<My_Box*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Box*>(b); + } } diff --git a/body/c_fl_box.h b/body/c_fl_box.h index 5143c3f..f0f8352 100644 --- a/body/c_fl_box.h +++ b/body/c_fl_box.h @@ -8,6 +8,9 @@ #define FL_BOX_GUARD +extern "C" void fl_box_extra_init(void * adaobj, int x, int y, int w, int h, const char * label); + + typedef void* BOX; diff --git a/body/c_fl_browser.cpp b/body/c_fl_browser.cpp index bf700b7..b76c496 100644 --- a/body/c_fl_browser.cpp +++ b/body/c_fl_browser.cpp @@ -7,6 +7,7 @@ #include <FL/Fl_Browser.H> #include <FL/Fl_Image.H> #include "c_fl_browser.h" +#include "c_fl.h" @@ -183,7 +184,11 @@ BROWSER new_fl_browser(int x, int y, int w, int h, char * label) { } void free_fl_browser(BROWSER b) { - delete static_cast<My_Browser*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Browser*>(b); + } } diff --git a/body/c_fl_browser_.cpp b/body/c_fl_browser_.cpp index 58eaa3d..df65818 100644 --- a/body/c_fl_browser_.cpp +++ b/body/c_fl_browser_.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Browser_.H> #include "c_fl_browser_.h" +#include "c_fl.h" @@ -190,7 +191,11 @@ ABSTRACTBROWSER new_fl_abstract_browser(int x, int y, int w, int h, char * label } void free_fl_abstract_browser(ABSTRACTBROWSER b) { - delete static_cast<My_Browser_*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Browser_*>(b); + } } diff --git a/body/c_fl_button.cpp b/body/c_fl_button.cpp index 409b190..ba08bc9 100644 --- a/body/c_fl_button.cpp +++ b/body/c_fl_button.cpp @@ -6,22 +6,18 @@ #include <FL/Fl_Button.H> #include "c_fl_button.h" +#include "c_fl.h" -// Telprot stopovers +// Telprot stopover extern "C" void button_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); void fl_button_extra_init(void * adaobj, int x, int y, int w, int h, const char * label) { button_extra_init_hook(adaobj, x, y, w, h, label); } -extern "C" void button_extra_final_hook(void * aobj); -void fl_button_extra_final(void * adaobj) { - button_extra_final_hook(adaobj); -} - @@ -75,7 +71,11 @@ BUTTON new_fl_button(int x, int y, int w, int h, char* label) { } void free_fl_button(BUTTON b) { - delete static_cast<My_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Button*>(b); + } } diff --git a/body/c_fl_button.h b/body/c_fl_button.h index f644a50..dfc0631 100644 --- a/body/c_fl_button.h +++ b/body/c_fl_button.h @@ -9,7 +9,6 @@ extern "C" void fl_button_extra_init(void * adaobj, int x, int y, int w, int h, const char * label); -extern "C" void fl_button_extra_final(void * adaobj); typedef void* BUTTON; diff --git a/body/c_fl_cairo_window.cpp b/body/c_fl_cairo_window.cpp index 4bf75f0..b4891c6 100644 --- a/body/c_fl_cairo_window.cpp +++ b/body/c_fl_cairo_window.cpp @@ -7,6 +7,7 @@ #include <FL/Fl_Cairo_Window.H> #include <FL/Fl_Double_Window.H> #include "c_fl_cairo_window.h" +#include "c_fl.h" @@ -61,7 +62,11 @@ CAIROWINDOW new_fl_cairo_window(int w, int h) { } void free_fl_cairo_window(CAIROWINDOW w) { - delete static_cast<My_Cairo_Window*>(w); + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Cairo_Window*>(w); + } } diff --git a/body/c_fl_chart.cpp b/body/c_fl_chart.cpp index c065327..351841f 100644 --- a/body/c_fl_chart.cpp +++ b/body/c_fl_chart.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Chart.H> #include "c_fl_chart.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ CHART new_fl_chart(int x, int y, int w, int h, char* label) { } void free_fl_chart(CHART b) { - delete static_cast<My_Chart*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Chart*>(b); + } } diff --git a/body/c_fl_check_browser.cpp b/body/c_fl_check_browser.cpp index 947dc63..11fafa4 100644 --- a/body/c_fl_check_browser.cpp +++ b/body/c_fl_check_browser.cpp @@ -7,6 +7,7 @@ #include <FL/Fl_Check_Browser.H> #include <FL/Fl_Browser_.H> #include "c_fl_check_browser.h" +#include "c_fl.h" @@ -197,7 +198,11 @@ CHECKBROWSER new_fl_check_browser(int x, int y, int w, int h, char * label) { } void free_fl_check_browser(CHECKBROWSER c) { - delete static_cast<My_Check_Browser*>(c); + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Check_Browser*>(c); + } } diff --git a/body/c_fl_check_button.cpp b/body/c_fl_check_button.cpp index 8dab449..f590aa0 100644 --- a/body/c_fl_check_button.cpp +++ b/body/c_fl_check_button.cpp @@ -6,11 +6,12 @@ #include <FL/Fl_Check_Button.H> #include "c_fl_check_button.h" +#include "c_fl.h" -// Telprot stopovers +// Telprot stopover extern "C" void check_button_extra_init_hook (void * aobj, int x, int y, int w, int h, const char * l); @@ -18,11 +19,6 @@ void fl_check_button_extra_init (void * adaobj, int x, int y, int w, int h, cons check_button_extra_init_hook(adaobj, x, y, w, h, label); } -extern "C" void check_button_extra_final_hook(void * aobj); -void fl_check_button_extra_final(void * adaobj) { - check_button_extra_final_hook(adaobj); -} - @@ -66,7 +62,11 @@ CHECKBUTTON new_fl_check_button(int x, int y, int w, int h, char* label) { } void free_fl_check_button(CHECKBUTTON b) { - delete static_cast<My_Check_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Check_Button*>(b); + } } diff --git a/body/c_fl_check_button.h b/body/c_fl_check_button.h index cfa6bff..88f1a00 100644 --- a/body/c_fl_check_button.h +++ b/body/c_fl_check_button.h @@ -10,7 +10,6 @@ extern "C" void fl_check_button_extra_init (void * adaobj, int x, int y, int w, int h, const char * label); -extern "C" void fl_check_button_extra_final(void * adaobj); typedef void* CHECKBUTTON; diff --git a/body/c_fl_choice.cpp b/body/c_fl_choice.cpp index 4b03532..e4471e5 100644 --- a/body/c_fl_choice.cpp +++ b/body/c_fl_choice.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Choice.H> #include "c_fl_choice.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ CHOICE new_fl_choice(int x, int y, int w, int h, char* label) { } void free_fl_choice(CHOICE b) { - delete static_cast<My_Choice*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Choice*>(b); + } } diff --git a/body/c_fl_clock.cpp b/body/c_fl_clock.cpp index e2df99c..2828f9e 100644 --- a/body/c_fl_clock.cpp +++ b/body/c_fl_clock.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Clock.H> #include "c_fl_clock.h" +#include "c_fl.h" @@ -55,7 +56,11 @@ CLOCK new_fl_clock2(unsigned char k, int x, int y, int w, int h, char* label) { } void free_fl_clock(CLOCK c) { - delete static_cast<My_Clock*>(c); + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Clock*>(c); + } } diff --git a/body/c_fl_clock_output.cpp b/body/c_fl_clock_output.cpp index a34b1c4..7e977f3 100644 --- a/body/c_fl_clock_output.cpp +++ b/body/c_fl_clock_output.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Clock.H> #include "c_fl_clock_output.h" +#include "c_fl.h" @@ -61,7 +62,11 @@ CLOCKOUTPUT new_fl_clock_output(int x, int y, int w, int h, char* label) { } void free_fl_clock_output(CLOCKOUTPUT c) { - delete static_cast<My_Clock_Output*>(c); + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Clock_Output*>(c); + } } diff --git a/body/c_fl_color_chooser.cpp b/body/c_fl_color_chooser.cpp index 31551b8..8f54437 100644 --- a/body/c_fl_color_chooser.cpp +++ b/body/c_fl_color_chooser.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Color_Chooser.H> #include "c_fl_color_chooser.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ COLORCHOOSER new_fl_color_chooser(int x, int y, int w, int h, char* label) { } void free_fl_color_chooser(COLORCHOOSER n) { - delete static_cast<My_Color_Chooser*>(n); + if (fl_inside_callback) { + fl_delete_widget(n); + } else { + delete static_cast<My_Color_Chooser*>(n); + } } diff --git a/body/c_fl_counter.cpp b/body/c_fl_counter.cpp index 9fe5d20..086a41d 100644 --- a/body/c_fl_counter.cpp +++ b/body/c_fl_counter.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Counter.H> #include "c_fl_counter.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ COUNTER new_fl_counter(int x, int y, int w, int h, char* label) { } void free_fl_counter(COUNTER c) { - delete static_cast<My_Counter*>(c); + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Counter*>(c); + } } diff --git a/body/c_fl_dial.cpp b/body/c_fl_dial.cpp index af83c21..6bc5368 100644 --- a/body/c_fl_dial.cpp +++ b/body/c_fl_dial.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Dial.H> #include "c_fl_dial.h" +#include "c_fl.h" @@ -69,7 +70,11 @@ DIAL new_fl_dial(int x, int y, int w, int h, char* label) { } void free_fl_dial(DIAL v) { - delete static_cast<My_Dial*>(v); + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Dial*>(v); + } } diff --git a/body/c_fl_double_window.cpp b/body/c_fl_double_window.cpp index 67db73b..bc9c48f 100644 --- a/body/c_fl_double_window.cpp +++ b/body/c_fl_double_window.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Double_Window.H> #include "c_fl_double_window.h" +#include "c_fl.h" @@ -66,7 +67,11 @@ DOUBLEWINDOW new_fl_double_window2(int w, int h, char* label) { } void free_fl_double_window(DOUBLEWINDOW d) { - delete static_cast<My_Double_Window*>(d); + if (fl_inside_callback) { + fl_delete_widget(d); + } else { + delete static_cast<My_Double_Window*>(d); + } } diff --git a/body/c_fl_event.cpp b/body/c_fl_event.cpp index 59a22df..7bfb466 100644 --- a/body/c_fl_event.cpp +++ b/body/c_fl_event.cpp @@ -16,10 +16,29 @@ void fl_event_add_handler(void * f) { Fl::add_handler(reinterpret_cast<Fl_Event_Handler>(f)); } -void fl_event_set_event_dispatch(void * f) { +void fl_event_remove_handler(void * f) { + Fl::remove_handler(reinterpret_cast<Fl_Event_Handler>(f)); +} + +void fl_event_add_system_handler(void * h, void * f) { + Fl::add_system_handler(reinterpret_cast<Fl_System_Handler>(h), f); +} + +void fl_event_remove_system_handler(void * h) { + Fl::remove_system_handler(reinterpret_cast<Fl_System_Handler>(h)); +} + + + + +void fl_event_set_dispatch(void * f) { Fl::event_dispatch(reinterpret_cast<Fl_Event_Dispatch>(f)); } +int fl_event_handle_dispatch(int e, void * w) { + return Fl::handle(e, static_cast<Fl_Window*>(w)); +} + int fl_event_handle(int e, void * w) { return Fl::handle_(e, static_cast<Fl_Window*>(w)); } @@ -59,6 +78,25 @@ void fl_event_set_focus(void * w) { Fl::focus(static_cast<Fl_Widget*>(w)); } +int fl_event_get_visible_focus() { + return Fl::visible_focus(); +} + +void fl_event_set_visible_focus(int f) { + Fl::visible_focus(f); +} + + + + +const char * fl_event_clipboard_text() { + return static_cast<const char*>(Fl::event_clipboard()); +} + +const char * fl_event_clipboard_type() { + return Fl::event_clipboard_type(); +} + @@ -78,6 +116,10 @@ int fl_event_length() { return Fl::event_length(); } +int fl_event_test_shortcut(unsigned int s) { + return Fl::test_shortcut(static_cast<Fl_Shortcut>(s)); +} + @@ -128,7 +170,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(); } @@ -152,6 +198,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<Fl_Widget*>(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 cc1f930..4cb87cb 100644 --- a/body/c_fl_event.h +++ b/body/c_fl_event.h @@ -9,7 +9,13 @@ extern "C" void fl_event_add_handler(void * f); -extern "C" void fl_event_set_event_dispatch(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); @@ -21,12 +27,19 @@ extern "C" void * fl_event_get_belowmouse(); extern "C" void fl_event_set_belowmouse(void * w); extern "C" void * fl_event_get_focus(); extern "C" void fl_event_set_focus(void * w); +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(); @@ -42,12 +55,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_file_browser.cpp b/body/c_fl_file_browser.cpp index 2e4f4c9..dfe45a8 100644 --- a/body/c_fl_file_browser.cpp +++ b/body/c_fl_file_browser.cpp @@ -8,6 +8,7 @@ #include <FL/Fl_Browser.H> #include <FL/filename.H> #include "c_fl_file_browser.h" +#include "c_fl.h" @@ -191,7 +192,11 @@ FILEBROWSER new_fl_file_browser(int x, int y, int w, int h, char * label) { } void free_fl_file_browser(FILEBROWSER b) { - delete static_cast<My_File_Browser*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_File_Browser*>(b); + } } diff --git a/body/c_fl_file_input.cpp b/body/c_fl_file_input.cpp index 8d0b15f..0fbea0a 100644 --- a/body/c_fl_file_input.cpp +++ b/body/c_fl_file_input.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_File_Input.H> #include "c_fl_file_input.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ FILEINPUT new_fl_file_input(int x, int y, int w, int h, char* label) { } void free_fl_file_input(FILEINPUT i) { - delete static_cast<My_File_Input*>(i); + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_File_Input*>(i); + } } diff --git a/body/c_fl_fill_dial.cpp b/body/c_fl_fill_dial.cpp index 47833c1..b29d581 100644 --- a/body/c_fl_fill_dial.cpp +++ b/body/c_fl_fill_dial.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Fill_Dial.H> #include "c_fl_fill_dial.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ FILLDIAL new_fl_fill_dial(int x, int y, int w, int h, char* label) { } void free_fl_fill_dial(FILLDIAL v) { - delete static_cast<My_Fill_Dial*>(v); + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Fill_Dial*>(v); + } } diff --git a/body/c_fl_fill_slider.cpp b/body/c_fl_fill_slider.cpp index 49834d4..309960a 100644 --- a/body/c_fl_fill_slider.cpp +++ b/body/c_fl_fill_slider.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Fill_Slider.H> #include "c_fl_fill_slider.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ FILLSLIDER new_fl_fill_slider(int x, int y, int w, int h, char* label) { } void free_fl_fill_slider(FILLSLIDER s) { - delete static_cast<My_Fill_Slider*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Fill_Slider*>(s); + } } diff --git a/body/c_fl_float_input.cpp b/body/c_fl_float_input.cpp index eedfa36..ca8337a 100644 --- a/body/c_fl_float_input.cpp +++ b/body/c_fl_float_input.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Float_Input.H> #include "c_fl_float_input.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ FLOATINPUT new_fl_float_input(int x, int y, int w, int h, char* label) { } void free_fl_float_input(FLOATINPUT i) { - delete static_cast<My_Float_Input*>(i); + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Float_Input*>(i); + } } diff --git a/body/c_fl_gl_window.cpp b/body/c_fl_gl_window.cpp index 3d6cbd5..adc33d3 100644 --- a/body/c_fl_gl_window.cpp +++ b/body/c_fl_gl_window.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Gl_Window.H> #include "c_fl_gl_window.h" +#include "c_fl.h" @@ -55,7 +56,11 @@ GLWINDOW new_fl_gl_window2(int w, int h, char* label) { } void free_fl_gl_window(GLWINDOW w) { - delete static_cast<My_Gl_Window*>(w); + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Gl_Window*>(w); + } } diff --git a/body/c_fl_group.cpp b/body/c_fl_group.cpp index 62bee03..dde521c 100644 --- a/body/c_fl_group.cpp +++ b/body/c_fl_group.cpp @@ -8,6 +8,7 @@ #include <FL/Fl_Widget.H> #include "c_fl_group.h" #include "c_fl_widget.h" +#include "c_fl.h" @@ -65,7 +66,11 @@ GROUP new_fl_group(int x, int y, int w, int h, char* label) { } void free_fl_group(GROUP g) { - delete static_cast<My_Group*>(g); + if (fl_inside_callback) { + fl_delete_widget(g); + } else { + delete static_cast<My_Group*>(g); + } } diff --git a/body/c_fl_help_view.cpp b/body/c_fl_help_view.cpp index aa2fd65..db7807e 100644 --- a/body/c_fl_help_view.cpp +++ b/body/c_fl_help_view.cpp @@ -8,6 +8,7 @@ #include <FL/Fl_Help_View.H> #include <FL/Enumerations.H> #include "c_fl_help_view.h" +#include "c_fl.h" @@ -52,7 +53,11 @@ HELPVIEW new_fl_help_view(int x, int y, int w, int h, char * label) { } void free_fl_help_view(HELPVIEW v) { - delete static_cast<My_Help_View*>(v); + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Help_View*>(v); + } } diff --git a/body/c_fl_hold_browser.cpp b/body/c_fl_hold_browser.cpp index 023e9ec..f5c2268 100644 --- a/body/c_fl_hold_browser.cpp +++ b/body/c_fl_hold_browser.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Hold_Browser.H> #include "c_fl_hold_browser.h" +#include "c_fl.h" @@ -172,7 +173,11 @@ HOLDBROWSER new_fl_hold_browser(int x, int y, int w, int h, char * label) { } void free_fl_hold_browser(HOLDBROWSER b) { - delete static_cast<My_Hold_Browser*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Hold_Browser*>(b); + } } diff --git a/body/c_fl_hor_fill_slider.cpp b/body/c_fl_hor_fill_slider.cpp index 9cd6ae2..1b35cf3 100644 --- a/body/c_fl_hor_fill_slider.cpp +++ b/body/c_fl_hor_fill_slider.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Hor_Fill_Slider.H> #include "c_fl_hor_fill_slider.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ HORFILLSLIDER new_fl_hor_fill_slider(int x, int y, int w, int h, char* label) { } void free_fl_hor_fill_slider(HORFILLSLIDER s) { - delete static_cast<My_Hor_Fill_Slider*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Hor_Fill_Slider*>(s); + } } diff --git a/body/c_fl_hor_nice_slider.cpp b/body/c_fl_hor_nice_slider.cpp index 29b271d..508d28b 100644 --- a/body/c_fl_hor_nice_slider.cpp +++ b/body/c_fl_hor_nice_slider.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Hor_Nice_Slider.H> #include "c_fl_hor_nice_slider.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ HORNICESLIDER new_fl_hor_nice_slider(int x, int y, int w, int h, char* label) { } void free_fl_hor_nice_slider(HORNICESLIDER s) { - delete static_cast<My_Hor_Nice_Slider*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Hor_Nice_Slider*>(s); + } } diff --git a/body/c_fl_hor_value_slider.cpp b/body/c_fl_hor_value_slider.cpp index cff16f6..341eb60 100644 --- a/body/c_fl_hor_value_slider.cpp +++ b/body/c_fl_hor_value_slider.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Hor_Value_Slider.H> #include "c_fl_hor_value_slider.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ HORVALUESLIDER new_fl_hor_value_slider(int x, int y, int w, int h, char* label) } void free_fl_hor_value_slider(HORVALUESLIDER s) { - delete static_cast<My_Hor_Value_Slider*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Hor_Value_Slider*>(s); + } } diff --git a/body/c_fl_horizontal_slider.cpp b/body/c_fl_horizontal_slider.cpp index 6a0ac22..6433a73 100644 --- a/body/c_fl_horizontal_slider.cpp +++ b/body/c_fl_horizontal_slider.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Hor_Slider.H> #include "c_fl_horizontal_slider.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ HORIZONTALSLIDER new_fl_horizontal_slider(int x, int y, int w, int h, char* labe } void free_fl_horizontal_slider(HORIZONTALSLIDER s) { - delete static_cast<My_Horizontal_Slider*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Horizontal_Slider*>(s); + } } diff --git a/body/c_fl_input.cpp b/body/c_fl_input.cpp index 6fa6b2d..73517a7 100644 --- a/body/c_fl_input.cpp +++ b/body/c_fl_input.cpp @@ -6,22 +6,18 @@ #include <FL/Fl_Input.H> #include "c_fl_input.h" +#include "c_fl.h" -// Telprot stopovers +// Telprot stopover extern "C" void text_input_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); void fl_text_input_extra_init(void * adaobj, int x, int y, int w, int h, const char * label) { text_input_extra_init_hook(adaobj, x, y, w, h, label); } -extern "C" void text_input_extra_final_hook(void * aobj); -void fl_text_input_extra_final(void * adaobj) { - text_input_extra_final_hook(adaobj); -} - @@ -65,7 +61,11 @@ TEXTINPUT new_fl_text_input(int x, int y, int w, int h, char * label) { } void free_fl_text_input(TEXTINPUT t) { - delete static_cast<My_Text_Input*>(t); + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Text_Input*>(t); + } } diff --git a/body/c_fl_input.h b/body/c_fl_input.h index 06a8a0c..dec6265 100644 --- a/body/c_fl_input.h +++ b/body/c_fl_input.h @@ -10,7 +10,6 @@ extern "C" void fl_text_input_extra_init (void * adaobj, int x, int y, int w, int h, const char * label); -extern "C" void fl_text_input_extra_final(void * adaobj); typedef void* TEXTINPUT; diff --git a/body/c_fl_input_.cpp b/body/c_fl_input_.cpp index 7fe0556..087a4a1 100644 --- a/body/c_fl_input_.cpp +++ b/body/c_fl_input_.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Input_.H> #include "c_fl_input_.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ INPUT new_fl_input(int x, int y, int w, int h, char* label) { } void free_fl_input(INPUT i) { - delete static_cast<My_Input*>(i); + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Input*>(i); + } } diff --git a/body/c_fl_input_choice.cpp b/body/c_fl_input_choice.cpp index 247e8eb..dea3023 100644 --- a/body/c_fl_input_choice.cpp +++ b/body/c_fl_input_choice.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Input_Choice.H> #include "c_fl_input_choice.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ INPUTCHOICE new_fl_input_choice(int x, int y, int w, int h, char* label) { } void free_fl_input_choice(INPUTCHOICE n) { - delete static_cast<My_Input_Choice*>(n); + if (fl_inside_callback) { + fl_delete_widget(n); + } else { + delete static_cast<My_Input_Choice*>(n); + } } diff --git a/body/c_fl_int_input.cpp b/body/c_fl_int_input.cpp index 8f780d7..ff96560 100644 --- a/body/c_fl_int_input.cpp +++ b/body/c_fl_int_input.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Int_Input.H> #include "c_fl_int_input.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ INTINPUT new_fl_int_input(int x, int y, int w, int h, char* label) { } void free_fl_int_input(INTINPUT i) { - delete static_cast<My_Int_Input*>(i); + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Int_Input*>(i); + } } 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<Fl_Label*>(l)->value; +} + void fl_label_set_value(LABEL l, const char * v) { static_cast<Fl_Label*>(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_light_button.cpp b/body/c_fl_light_button.cpp index e11ce64..6c59730 100644 --- a/body/c_fl_light_button.cpp +++ b/body/c_fl_light_button.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Light_Button.H> #include "c_fl_light_button.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ LIGHTBUTTON new_fl_light_button(int x, int y, int w, int h, char* label) { } void free_fl_light_button(LIGHTBUTTON b) { - delete static_cast<My_Light_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Light_Button*>(b); + } } diff --git a/body/c_fl_line_dial.cpp b/body/c_fl_line_dial.cpp index 388264f..92059f2 100644 --- a/body/c_fl_line_dial.cpp +++ b/body/c_fl_line_dial.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Line_Dial.H> #include "c_fl_line_dial.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ LINEDIAL new_fl_line_dial(int x, int y, int w, int h, char* label) { } void free_fl_line_dial(LINEDIAL v) { - delete static_cast<My_Line_Dial*>(v); + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Line_Dial*>(v); + } } diff --git a/body/c_fl_menu.cpp b/body/c_fl_menu.cpp index e42e985..2ef9402 100644 --- a/body/c_fl_menu.cpp +++ b/body/c_fl_menu.cpp @@ -7,6 +7,7 @@ #include <FL/Fl_Menu_.H> #include <FL/Fl_Menu_Item.H> #include "c_fl_menu.h" +#include "c_fl.h" @@ -53,7 +54,11 @@ MENU new_fl_menu(int x, int y, int w, int h, char* label) { } void free_fl_menu(MENU m) { - delete static_cast<My_Menu*>(m); + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Menu*>(m); + } } diff --git a/body/c_fl_menu_bar.cpp b/body/c_fl_menu_bar.cpp index 5e73675..8419df6 100644 --- a/body/c_fl_menu_bar.cpp +++ b/body/c_fl_menu_bar.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Menu_Bar.H> #include "c_fl_menu_bar.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ MENUBAR new_fl_menu_bar(int x, int y, int w, int h, char* label) { } void free_fl_menu_bar(MENUBAR m) { - delete static_cast<My_Menu_Bar*>(m); + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Menu_Bar*>(m); + } } diff --git a/body/c_fl_menu_button.cpp b/body/c_fl_menu_button.cpp index abe9712..4537e8d 100644 --- a/body/c_fl_menu_button.cpp +++ b/body/c_fl_menu_button.cpp @@ -6,11 +6,12 @@ #include <FL/Fl_Menu_Button.H> #include "c_fl_menu_button.h" +#include "c_fl.h" -// Telprot stopovers +// Telprot stopover extern "C" void menu_button_extra_init_hook (void * aobj, int x, int y, int w, int h, const char * l); @@ -18,11 +19,6 @@ void fl_menu_button_extra_init(void * adaobj, int x, int y, int w, int h, const menu_button_extra_init_hook(adaobj, x, y, w, h, label); } -extern "C" void menu_button_extra_final_hook(void * aobj); -void fl_menu_button_extra_final(void * adaobj) { - menu_button_extra_final_hook(adaobj); -} - @@ -66,7 +62,11 @@ MENUBUTTON new_fl_menu_button(int x, int y, int w, int h, char* label) { } void free_fl_menu_button(MENUBUTTON m) { - delete static_cast<My_Menu_Button*>(m); + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Menu_Button*>(m); + } } diff --git a/body/c_fl_menu_button.h b/body/c_fl_menu_button.h index d567e4f..f8f721b 100644 --- a/body/c_fl_menu_button.h +++ b/body/c_fl_menu_button.h @@ -10,7 +10,6 @@ extern "C" void fl_menu_button_extra_init (void * adaobj, int x, int y, int w, int h, const char * label); -extern "C" void fl_menu_button_extra_final(void * adaobj); typedef void* MENUBUTTON; diff --git a/body/c_fl_menu_window.cpp b/body/c_fl_menu_window.cpp index cae1bf9..30020c6 100644 --- a/body/c_fl_menu_window.cpp +++ b/body/c_fl_menu_window.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Menu_Window.H> #include "c_fl_menu_window.h" +#include "c_fl.h" @@ -55,7 +56,11 @@ MENUWINDOW new_fl_menu_window2(int w, int h, char* label) { } void free_fl_menu_window(MENUWINDOW m) { - delete static_cast<My_Menu_Window*>(m); + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Menu_Window*>(m); + } } diff --git a/body/c_fl_multi_browser.cpp b/body/c_fl_multi_browser.cpp index 18bf5e8..ce0b077 100644 --- a/body/c_fl_multi_browser.cpp +++ b/body/c_fl_multi_browser.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Multi_Browser.H> #include "c_fl_multi_browser.h" +#include "c_fl.h" @@ -172,7 +173,11 @@ MULTIBROWSER new_fl_multi_browser(int x, int y, int w, int h, char * label) { } void free_fl_multi_browser(MULTIBROWSER b) { - delete static_cast<My_Multi_Browser*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Multi_Browser*>(b); + } } diff --git a/body/c_fl_multiline_input.cpp b/body/c_fl_multiline_input.cpp index ee99a13..2e193f2 100644 --- a/body/c_fl_multiline_input.cpp +++ b/body/c_fl_multiline_input.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Multiline_Input.H> #include "c_fl_multiline_input.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ MULTILINEINPUT new_fl_multiline_input(int x, int y, int w, int h, char* label) { } void free_fl_multiline_input(MULTILINEINPUT i) { - delete static_cast<My_Multiline_Input*>(i); + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Multiline_Input*>(i); + } } diff --git a/body/c_fl_multiline_output.cpp b/body/c_fl_multiline_output.cpp index 2401fc7..e5c8f05 100644 --- a/body/c_fl_multiline_output.cpp +++ b/body/c_fl_multiline_output.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Multiline_Output.H> #include "c_fl_multiline_output.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ MULTILINEOUTPUT new_fl_multiline_output(int x, int y, int w, int h, char* label) } void free_fl_multiline_output(MULTILINEOUTPUT i) { - delete static_cast<My_Multiline_Output*>(i); + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Multiline_Output*>(i); + } } diff --git a/body/c_fl_nice_slider.cpp b/body/c_fl_nice_slider.cpp index 082bbfc..5e34190 100644 --- a/body/c_fl_nice_slider.cpp +++ b/body/c_fl_nice_slider.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Nice_Slider.H> #include "c_fl_nice_slider.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ NICESLIDER new_fl_nice_slider(int x, int y, int w, int h, char* label) { } void free_fl_nice_slider(NICESLIDER s) { - delete static_cast<My_Nice_Slider*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Nice_Slider*>(s); + } } diff --git a/body/c_fl_output.cpp b/body/c_fl_output.cpp index 2e937dd..9fa36a1 100644 --- a/body/c_fl_output.cpp +++ b/body/c_fl_output.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Output.H> #include "c_fl_output.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ OUTPUTT new_fl_output(int x, int y, int w, int h, char* label) { } void free_fl_output(OUTPUTT i) { - delete static_cast<My_Output*>(i); + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Output*>(i); + } } diff --git a/body/c_fl_overlay_window.cpp b/body/c_fl_overlay_window.cpp index 0d434c3..fa92eed 100644 --- a/body/c_fl_overlay_window.cpp +++ b/body/c_fl_overlay_window.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Overlay_Window.H> #include "c_fl_overlay_window.h" +#include "c_fl.h" @@ -65,7 +66,11 @@ OVERLAYWINDOW new_fl_overlay_window2(int w, int h, char *label) { } void free_fl_overlay_window(OVERLAYWINDOW w) { - delete static_cast<My_Overlay_Window*>(w); + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Overlay_Window*>(w); + } } diff --git a/body/c_fl_pack.cpp b/body/c_fl_pack.cpp index e7cace9..48fa505 100644 --- a/body/c_fl_pack.cpp +++ b/body/c_fl_pack.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Pack.H> #include "c_fl_pack.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ PACK new_fl_pack(int x, int y, int w, int h, char* label) { } void free_fl_pack(PACK p) { - delete static_cast<My_Pack*>(p); + if (fl_inside_callback) { + fl_delete_widget(p); + } else { + delete static_cast<My_Pack*>(p); + } } diff --git a/body/c_fl_positioner.cpp b/body/c_fl_positioner.cpp index ce23b64..6a070d7 100644 --- a/body/c_fl_positioner.cpp +++ b/body/c_fl_positioner.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Positioner.H> #include "c_fl_positioner.h" +#include "c_fl.h" @@ -62,7 +63,11 @@ POSITIONER new_fl_positioner(int x, int y, int w, int h, char* label) { } void free_fl_positioner(POSITIONER p) { - delete static_cast<My_Positioner*>(p); + if (fl_inside_callback) { + fl_delete_widget(p); + } else { + delete static_cast<My_Positioner*>(p); + } } diff --git a/body/c_fl_progress.cpp b/body/c_fl_progress.cpp index 21a7a2d..7b13a48 100644 --- a/body/c_fl_progress.cpp +++ b/body/c_fl_progress.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Progress.H> #include "c_fl_progress.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ PROGRESS new_fl_progress(int x, int y, int w, int h, char* label) { } void free_fl_progress(PROGRESS p) { - delete static_cast<My_Progress*>(p); + if (fl_inside_callback) { + fl_delete_widget(p); + } else { + delete static_cast<My_Progress*>(p); + } } diff --git a/body/c_fl_radio_button.cpp b/body/c_fl_radio_button.cpp index 486c354..40c8fd5 100644 --- a/body/c_fl_radio_button.cpp +++ b/body/c_fl_radio_button.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Radio_Button.H> #include "c_fl_radio_button.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ RADIOBUTTON new_fl_radio_button(int x, int y, int w, int h, char* label) { } void free_fl_radio_button(RADIOBUTTON b) { - delete static_cast<My_Radio_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Radio_Button*>(b); + } } diff --git a/body/c_fl_radio_light_button.cpp b/body/c_fl_radio_light_button.cpp index f6da99e..ce57982 100644 --- a/body/c_fl_radio_light_button.cpp +++ b/body/c_fl_radio_light_button.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Radio_Light_Button.H> #include "c_fl_radio_light_button.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ RADIOLIGHTBUTTON new_fl_radio_light_button(int x, int y, int w, int h, char* lab } void free_fl_radio_light_button(RADIOLIGHTBUTTON b) { - delete static_cast<My_Radio_Light_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Radio_Light_Button*>(b); + } } diff --git a/body/c_fl_radio_round_button.cpp b/body/c_fl_radio_round_button.cpp index b09e1f3..62dc8e5 100644 --- a/body/c_fl_radio_round_button.cpp +++ b/body/c_fl_radio_round_button.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Radio_Round_Button.H> #include "c_fl_radio_round_button.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ RADIOROUNDBUTTON new_fl_radio_round_button(int x, int y, int w, int h, char* lab } void free_fl_radio_round_button(RADIOROUNDBUTTON b) { - delete static_cast<My_Radio_Round_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Radio_Round_Button*>(b); + } } diff --git a/body/c_fl_repeat_button.cpp b/body/c_fl_repeat_button.cpp index c3eb582..562a72d 100644 --- a/body/c_fl_repeat_button.cpp +++ b/body/c_fl_repeat_button.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Repeat_Button.H> #include "c_fl_repeat_button.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ REPEATBUTTON new_fl_repeat_button(int x, int y, int w, int h, char* label) { } void free_fl_repeat_button(REPEATBUTTON b) { - delete static_cast<My_Repeat_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Repeat_Button*>(b); + } } diff --git a/body/c_fl_return_button.cpp b/body/c_fl_return_button.cpp index 2c315d1..3211b7f 100644 --- a/body/c_fl_return_button.cpp +++ b/body/c_fl_return_button.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Return_Button.H> #include "c_fl_return_button.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ RETURNBUTTON new_fl_return_button(int x, int y, int w, int h, char* label) { } void free_fl_return_button(RETURNBUTTON b) { - delete static_cast<My_Return_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Return_Button*>(b); + } } diff --git a/body/c_fl_roller.cpp b/body/c_fl_roller.cpp index 1c65422..9f6753c 100644 --- a/body/c_fl_roller.cpp +++ b/body/c_fl_roller.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Roller.H> #include "c_fl_roller.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ ROLLER new_fl_roller(int x, int y, int w, int h, char* label) { } void free_fl_roller(ROLLER r) { - delete static_cast<My_Roller*>(r); + if (fl_inside_callback) { + fl_delete_widget(r); + } else { + delete static_cast<My_Roller*>(r); + } } diff --git a/body/c_fl_round_button.cpp b/body/c_fl_round_button.cpp index e6a9c43..3c9550e 100644 --- a/body/c_fl_round_button.cpp +++ b/body/c_fl_round_button.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Round_Button.H> #include "c_fl_round_button.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ ROUNDBUTTON new_fl_round_button(int x, int y, int w, int h, char* label) { } void free_fl_round_button(ROUNDBUTTON b) { - delete static_cast<My_Round_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Round_Button*>(b); + } } diff --git a/body/c_fl_round_clock.cpp b/body/c_fl_round_clock.cpp index 0036c00..85774c8 100644 --- a/body/c_fl_round_clock.cpp +++ b/body/c_fl_round_clock.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Round_Clock.H> #include "c_fl_round_clock.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ ROUNDCLOCK new_fl_round_clock(int x, int y, int w, int h, char* label) { } void free_fl_round_clock(ROUNDCLOCK c) { - delete static_cast<My_Round_Clock*>(c); + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Round_Clock*>(c); + } } diff --git a/body/c_fl_screen.cpp b/body/c_fl_screen.cpp index 88550bd..7a5fc2f 100644 --- a/body/c_fl_screen.cpp +++ b/body/c_fl_screen.cpp @@ -8,6 +8,27 @@ #include "c_fl_screen.h" + + +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); +} + + + + int fl_screen_x() { return Fl::x(); } @@ -82,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 9b4d4ec..c2b0e98 100644 --- a/body/c_fl_screen.h +++ b/body/c_fl_screen.h @@ -8,6 +8,16 @@ #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(); extern "C" int fl_screen_y(); extern "C" int fl_screen_w(); @@ -33,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_scroll.cpp b/body/c_fl_scroll.cpp index a240139..325d8cf 100644 --- a/body/c_fl_scroll.cpp +++ b/body/c_fl_scroll.cpp @@ -6,22 +6,18 @@ #include <FL/Fl_Scroll.H> #include "c_fl_scroll.h" +#include "c_fl.h" -// Telprot stopovers +// Telprot stopover extern "C" void scroll_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); void fl_scroll_extra_init(void * adaobj, int x, int y, int w, int h, const char * label) { scroll_extra_init_hook(adaobj, x, y, w, h, label); } -extern "C" void scroll_extra_final_hook(void * aobj); -void fl_scroll_extra_final(void * adaobj) { - scroll_extra_final_hook(adaobj); -} - @@ -75,7 +71,11 @@ SCROLL new_fl_scroll(int x, int y, int w, int h, char* label) { } void free_fl_scroll(SCROLL s) { - delete static_cast<My_Scroll*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Scroll*>(s); + } } diff --git a/body/c_fl_scroll.h b/body/c_fl_scroll.h index 17dec0f..e39e469 100644 --- a/body/c_fl_scroll.h +++ b/body/c_fl_scroll.h @@ -9,7 +9,6 @@ extern "C" void fl_scroll_extra_init(void * adaobj, int x, int y, int w, int h, const char * label); -extern "C" void fl_scroll_extra_final(void * adaobj); typedef void* SCROLL; diff --git a/body/c_fl_scrollbar.cpp b/body/c_fl_scrollbar.cpp index 2ebdb27..bf5ceaa 100644 --- a/body/c_fl_scrollbar.cpp +++ b/body/c_fl_scrollbar.cpp @@ -6,22 +6,18 @@ #include <FL/Fl_Scrollbar.H> #include "c_fl_scrollbar.h" +#include "c_fl.h" -// Telprot stopovers +// Telprot stopover extern "C" void scrollbar_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); void fl_scrollbar_extra_init (void * adaobj, int x, int y, int w, int h, const char * label) { scrollbar_extra_init_hook(adaobj, x, y, w, h, label); } -extern "C" void scrollbar_extra_final_hook(void * aobj); -void fl_scrollbar_extra_final(void * adaobj) { - scrollbar_extra_final_hook(adaobj); -} - @@ -72,7 +68,11 @@ SCROLLBAR new_fl_scrollbar(int x, int y, int w, int h, char* label) { } void free_fl_scrollbar(SCROLLBAR s) { - delete static_cast<My_Scrollbar*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Scrollbar*>(s); + } } diff --git a/body/c_fl_scrollbar.h b/body/c_fl_scrollbar.h index 870f256..6dd599d 100644 --- a/body/c_fl_scrollbar.h +++ b/body/c_fl_scrollbar.h @@ -10,7 +10,6 @@ extern "C" void fl_scrollbar_extra_init (void * adaobj, int x, int y, int w, int h, const char * label); -extern "C" void fl_scrollbar_extra_final(void * adaobj); typedef void* SCROLLBAR; diff --git a/body/c_fl_secret_input.cpp b/body/c_fl_secret_input.cpp index b3205cb..4ef4720 100644 --- a/body/c_fl_secret_input.cpp +++ b/body/c_fl_secret_input.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Secret_Input.H> #include "c_fl_secret_input.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ SECRETINPUT new_fl_secret_input(int x, int y, int w, int h, char* label) { } void free_fl_secret_input(SECRETINPUT i) { - delete static_cast<My_Secret_Input*>(i); + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Secret_Input*>(i); + } } diff --git a/body/c_fl_select_browser.cpp b/body/c_fl_select_browser.cpp index 5993703..a0173fc 100644 --- a/body/c_fl_select_browser.cpp +++ b/body/c_fl_select_browser.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Select_Browser.H> #include "c_fl_select_browser.h" +#include "c_fl.h" @@ -172,7 +173,11 @@ SELECTBROWSER new_fl_select_browser(int x, int y, int w, int h, char * label) { } void free_fl_select_browser(SELECTBROWSER b) { - delete static_cast<My_Select_Browser*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Select_Browser*>(b); + } } diff --git a/body/c_fl_simple_counter.cpp b/body/c_fl_simple_counter.cpp index cf42d03..53aafab 100644 --- a/body/c_fl_simple_counter.cpp +++ b/body/c_fl_simple_counter.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Simple_Counter.H> #include "c_fl_simple_counter.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ SIMPLECOUNTER new_fl_simple_counter(int x, int y, int w, int h, char* label) { } void free_fl_simple_counter(SIMPLECOUNTER c) { - delete static_cast<My_Simple_Counter*>(c); + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Simple_Counter*>(c); + } } diff --git a/body/c_fl_single_window.cpp b/body/c_fl_single_window.cpp index efafdc4..d22041e 100644 --- a/body/c_fl_single_window.cpp +++ b/body/c_fl_single_window.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Single_Window.H> #include "c_fl_single_window.h" +#include "c_fl.h" @@ -55,7 +56,11 @@ SINGLEWINDOW new_fl_single_window2(int x, int y, char* label) { } void free_fl_single_window(SINGLEWINDOW w) { - delete static_cast<My_Single_Window*>(w); + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Single_Window*>(w); + } } diff --git a/body/c_fl_slider.cpp b/body/c_fl_slider.cpp index 449988c..bad03cd 100644 --- a/body/c_fl_slider.cpp +++ b/body/c_fl_slider.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Slider.H> #include "c_fl_slider.h" +#include "c_fl.h" @@ -74,7 +75,11 @@ SLIDER new_fl_slider2(unsigned char k, int x, int y, int w, int h, char * label) } void free_fl_slider(SLIDER s) { - delete static_cast<My_Slider*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Slider*>(s); + } } diff --git a/body/c_fl_spinner.cpp b/body/c_fl_spinner.cpp index 67a5312..d8683e5 100644 --- a/body/c_fl_spinner.cpp +++ b/body/c_fl_spinner.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Spinner.H> #include "c_fl_spinner.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ SPINNER new_fl_spinner(int x, int y, int w, int h, char* label) { } void free_fl_spinner(SPINNER n) { - delete static_cast<My_Spinner*>(n); + if (fl_inside_callback) { + fl_delete_widget(n); + } else { + delete static_cast<My_Spinner*>(n); + } } diff --git a/body/c_fl_static.cpp b/body/c_fl_static.cpp index ad4cfe9..5dd90e2 100644 --- a/body/c_fl_static.cpp +++ b/body/c_fl_static.cpp @@ -12,64 +12,111 @@ -void fl_static_add_awake_handler(void * h, void * f) { - Fl::add_awake_handler_(reinterpret_cast<Fl_Awake_Handler>(h),f); +void fl_static_box_draw_marshal(void * f, int x, int y, int w, int h, unsigned int t) { + reinterpret_cast<Fl_Box_Draw_F*>(f)(x, y, w, h, static_cast<Fl_Color>(t)); } -void fl_static_get_awake_handler(void * &h, void * &f) { - Fl::get_awake_handler_(reinterpret_cast<Fl_Awake_Handler&>(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<char**>(v), i); +} + +void fl_static_args(int c, void * v) { + Fl::args(c, static_cast<char**>(v)); +} + +int fl_static_args2(int c, void * v, int &i, void * h) { + return Fl::args(c, static_cast<char**>(v), i, reinterpret_cast<Fl_Args_Handler>(h)); +} + + + + +int fl_static_add_awake_handler(void * h, void * f) { + return Fl::add_awake_handler_(reinterpret_cast<Fl_Awake_Handler>(h), f); +} + +int fl_static_get_awake_handler(void * &h, void * &f) { + return Fl::get_awake_handler_(reinterpret_cast<Fl_Awake_Handler&>(h), f); +} + +int fl_static_awake2(void * h, void * f) { + return Fl::awake(reinterpret_cast<Fl_Awake_Handler>(h), f); +} + +void fl_static_awake(void * msg) { + Fl::awake(msg); +} + +void fl_static_lock() { + Fl::lock(); +} + +void fl_static_unlock() { + Fl::unlock(); } void fl_static_add_check(void * h, void * f) { - Fl::add_check(reinterpret_cast<Fl_Timeout_Handler>(h),f); + Fl::add_check(reinterpret_cast<Fl_Timeout_Handler>(h), f); } int fl_static_has_check(void * h, void * f) { - return Fl::has_check(reinterpret_cast<Fl_Timeout_Handler>(h),f); + return Fl::has_check(reinterpret_cast<Fl_Timeout_Handler>(h), f); } void fl_static_remove_check(void * h, void * f) { - Fl::remove_check(reinterpret_cast<Fl_Timeout_Handler>(h),f); + Fl::remove_check(reinterpret_cast<Fl_Timeout_Handler>(h), f); } void fl_static_add_timeout(double s, void * h, void * f) { - Fl::add_timeout(s,reinterpret_cast<Fl_Timeout_Handler>(h),f); + Fl::add_timeout(s, reinterpret_cast<Fl_Timeout_Handler>(h), f); } int fl_static_has_timeout(void * h, void * f) { - return Fl::has_timeout(reinterpret_cast<Fl_Timeout_Handler>(h),f); + return Fl::has_timeout(reinterpret_cast<Fl_Timeout_Handler>(h), f); } void fl_static_remove_timeout(void * h, void * f) { - Fl::remove_timeout(reinterpret_cast<Fl_Timeout_Handler>(h),f); + Fl::remove_timeout(reinterpret_cast<Fl_Timeout_Handler>(h), f); } void fl_static_repeat_timeout(double s, void * h, void * f) { - Fl::repeat_timeout(s,reinterpret_cast<Fl_Timeout_Handler>(h),f); + Fl::repeat_timeout(s, reinterpret_cast<Fl_Timeout_Handler>(h), f); } void fl_static_add_clipboard_notify(void * h, void * f) { - Fl::add_clipboard_notify(reinterpret_cast<Fl_Clipboard_Notify_Handler>(h),f); + Fl::add_clipboard_notify(reinterpret_cast<Fl_Clipboard_Notify_Handler>(h), f); +} + +void fl_static_remove_clipboard_notify(void * h) { + Fl::remove_clipboard_notify(reinterpret_cast<Fl_Clipboard_Notify_Handler>(h)); } void fl_static_add_fd(int d, void * h, void * f) { - Fl::add_fd(d,reinterpret_cast<Fl_FD_Handler>(h),f); + Fl::add_fd(d,reinterpret_cast<Fl_FD_Handler>(h), f); } void fl_static_add_fd2(int d, int m, void * h, void * f) { - Fl::add_fd(d,m,reinterpret_cast<Fl_FD_Handler>(h),f); + Fl::add_fd(d,m,reinterpret_cast<Fl_FD_Handler>(h), f); } void fl_static_remove_fd(int d) { @@ -77,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<Fl_Idle_Handler>(h),f); + Fl::add_idle(reinterpret_cast<Fl_Idle_Handler>(h), f); } int fl_static_has_idle(void * h, void * f) { - return Fl::has_idle(reinterpret_cast<Fl_Idle_Handler>(h),f); + return Fl::has_idle(reinterpret_cast<Fl_Idle_Handler>(h), f); } void fl_static_remove_idle(void * h, void * f) { - Fl::remove_idle(reinterpret_cast<Fl_Idle_Handler>(h),f); + Fl::remove_idle(reinterpret_cast<Fl_Idle_Handler>(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<Fl_Color>(t)); +} + +void fl_static_set_box_color(unsigned int t) { + Fl::set_box_color(static_cast<Fl_Color>(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(); } @@ -134,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<Fl_Font>(t), static_cast<Fl_Font>(f)); +} + +void fl_static_set_font2(int t, char * s) { + Fl::set_font(static_cast<Fl_Font>(t), s); } int fl_static_get_font_sizes(int f, int * &a) { @@ -168,10 +243,20 @@ int fl_static_box_dy(int b) { return Fl::box_dy(static_cast<Fl_Boxtype>(b)); } +void * fl_static_get_boxtype(int t) { + return reinterpret_cast<void*>(Fl::get_boxtype(static_cast<Fl_Boxtype>(t))); +} + void fl_static_set_boxtype(int t, int f) { Fl::set_boxtype(static_cast<Fl_Boxtype>(t),static_cast<Fl_Boxtype>(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<Fl_Boxtype>(t), reinterpret_cast<Fl_Box_Draw_F*>(f), dx, dy, dw, dh); +} + int fl_static_draw_box_active() { return Fl::draw_box_active(); } @@ -179,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<Fl_Labeltype>(k), + reinterpret_cast<Fl_Label_Draw_F*>(d), reinterpret_cast<Fl_Label_Measure_F*>(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) { @@ -193,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() { @@ -219,19 +316,11 @@ void fl_static_disable_im() { Fl::disable_im(); } -int fl_static_get_visible_focus() { - return Fl::visible_focus(); -} - -void fl_static_set_visible_focus(int f) { - Fl::visible_focus(f); -} - -void fl_static_default_atclose(void * w) { - Fl::default_atclose(static_cast<Fl_Window*>(w), 0); +void fl_static_default_atclose(void * w, void * u) { + Fl::default_atclose(static_cast<Fl_Window*>(w), u); } void * fl_static_get_first_window() { @@ -257,10 +346,6 @@ void * fl_static_readqueue() { return Fl::readqueue(); } -void fl_static_do_widget_deletion() { - Fl::do_widget_deletion(); -} - @@ -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<Fl::Fl_Option>(o)); + return Fl::option(static_cast<Fl::Fl_Option>(o)) ? 1 : 0; } void fl_static_set_option(int o, int t) { - Fl::option(static_cast<Fl::Fl_Option>(o),t); + Fl::option(static_cast<Fl::Fl_Option>(o), t!=0); } diff --git a/body/c_fl_static.h b/body/c_fl_static.h index 692750b..f39e557 100644 --- a/body/c_fl_static.h +++ b/body/c_fl_static.h @@ -8,8 +8,23 @@ #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_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(); extern "C" void fl_static_add_check(void * h, void * f); @@ -24,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); @@ -37,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(); @@ -59,27 +82,32 @@ 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); extern "C" void fl_static_enable_im(); extern "C" void fl_static_disable_im(); -extern "C" int fl_static_get_visible_focus(); -extern "C" void fl_static_set_visible_focus(int f); -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); @@ -87,7 +115,6 @@ extern "C" void * fl_static_modal(); extern "C" void * fl_static_readqueue(); -extern "C" void fl_static_do_widget_deletion(); extern "C" const char * fl_static_get_scheme(); diff --git a/body/c_fl_sys_menu_bar.cpp b/body/c_fl_sys_menu_bar.cpp index fbd6e34..7f28574 100644 --- a/body/c_fl_sys_menu_bar.cpp +++ b/body/c_fl_sys_menu_bar.cpp @@ -7,6 +7,7 @@ #include <FL/Fl_Sys_Menu_Bar.H> #include <FL/Fl_Menu_Item.H> #include "c_fl_sys_menu_bar.h" +#include "c_fl.h" @@ -53,7 +54,11 @@ SYSMENUBAR new_fl_sys_menu_bar(int x, int y, int w, int h, char* label) { } void free_fl_sys_menu_bar(SYSMENUBAR m) { - delete static_cast<My_Sys_Menu_Bar*>(m); + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Sys_Menu_Bar*>(m); + } } diff --git a/body/c_fl_table.cpp b/body/c_fl_table.cpp index b264c1e..377ec37 100644 --- a/body/c_fl_table.cpp +++ b/body/c_fl_table.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Table.H> #include "c_fl_table.h" +#include "c_fl.h" @@ -105,7 +106,11 @@ TABLE new_fl_table(int x, int y, int w, int h, char * label) { } void free_fl_table(TABLE t) { - delete static_cast<My_Table*>(t); + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Table*>(t); + } } diff --git a/body/c_fl_table_row.cpp b/body/c_fl_table_row.cpp index 8094df4..0ded792 100644 --- a/body/c_fl_table_row.cpp +++ b/body/c_fl_table_row.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Table_Row.H> #include "c_fl_table_row.h" +#include "c_fl.h" @@ -68,7 +69,11 @@ ROWTABLE new_fl_table_row(int x, int y, int w, int h, char * label) { } void free_fl_table_row(ROWTABLE t) { - delete static_cast<My_Table_Row*>(t); + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Table_Row*>(t); + } } diff --git a/body/c_fl_tabs.cpp b/body/c_fl_tabs.cpp index df7327f..4e09135 100644 --- a/body/c_fl_tabs.cpp +++ b/body/c_fl_tabs.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Tabs.H> #include "c_fl_tabs.h" +#include "c_fl.h" @@ -60,7 +61,11 @@ TABS new_fl_tabs(int x, int y, int w, int h, char* label) { } void free_fl_tabs(TABS t) { - delete static_cast<My_Tabs*>(t); + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Tabs*>(t); + } } diff --git a/body/c_fl_text_display.cpp b/body/c_fl_text_display.cpp index a50f25d..bf9dacf 100644 --- a/body/c_fl_text_display.cpp +++ b/body/c_fl_text_display.cpp @@ -8,6 +8,7 @@ #include <FL/Fl_Text_Buffer.H> #include "c_fl_text_display.h" #include "c_fl_text_buffer.h" +#include "c_fl.h" @@ -104,7 +105,11 @@ TEXTDISPLAY new_fl_text_display(int x, int y, int w, int h, char* label) { } void free_fl_text_display(TEXTDISPLAY td) { - delete static_cast<My_Text_Display*>(td); + if (fl_inside_callback) { + fl_delete_widget(td); + } else { + delete static_cast<My_Text_Display*>(td); + } } diff --git a/body/c_fl_text_editor.cpp b/body/c_fl_text_editor.cpp index 0da5f5e..0efea0b 100644 --- a/body/c_fl_text_editor.cpp +++ b/body/c_fl_text_editor.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Text_Editor.H> #include "c_fl_text_editor.h" +#include "c_fl.h" @@ -61,7 +62,11 @@ TEXTEDITOR new_fl_text_editor(int x, int y, int w, int h, char* label) { } void free_fl_text_editor(TEXTEDITOR te) { - delete static_cast<My_Text_Editor*>(te); + if (fl_inside_callback) { + fl_delete_widget(te); + } else { + delete static_cast<My_Text_Editor*>(te); + } } diff --git a/body/c_fl_tile.cpp b/body/c_fl_tile.cpp index 81f820a..feea448 100644 --- a/body/c_fl_tile.cpp +++ b/body/c_fl_tile.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Tile.H> #include "c_fl_tile.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ TILE new_fl_tile(int x, int y, int w, int h, char* label) { } void free_fl_tile(TILE t) { - delete static_cast<My_Tile*>(t); + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Tile*>(t); + } } diff --git a/body/c_fl_toggle_button.cpp b/body/c_fl_toggle_button.cpp index d396f37..f87e78a 100644 --- a/body/c_fl_toggle_button.cpp +++ b/body/c_fl_toggle_button.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Toggle_Button.H> #include "c_fl_toggle_button.h" +#include "c_fl.h" @@ -50,7 +51,11 @@ TOGGLEBUTTON new_fl_toggle_button(int x, int y, int w, int h, char* label) { } void free_fl_toggle_button(TOGGLEBUTTON b) { - delete static_cast<My_Toggle_Button*>(b); + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Toggle_Button*>(b); + } } diff --git a/body/c_fl_valuator.cpp b/body/c_fl_valuator.cpp index 3b4ebba..44ab601 100644 --- a/body/c_fl_valuator.cpp +++ b/body/c_fl_valuator.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Valuator.H> #include "c_fl_valuator.h" +#include "c_fl.h" @@ -68,7 +69,11 @@ VALUATOR new_fl_valuator(int x, int y, int w, int h, char* label) { } void free_fl_valuator(VALUATOR v) { - delete static_cast<My_Valuator*>(v); + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Valuator*>(v); + } } diff --git a/body/c_fl_value_input.cpp b/body/c_fl_value_input.cpp index 3d19845..29a7772 100644 --- a/body/c_fl_value_input.cpp +++ b/body/c_fl_value_input.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Value_Input.H> #include "c_fl_value_input.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ VALUEINPUT new_fl_value_input(int x, int y, int w, int h, char* label) { } void free_fl_value_input(VALUEINPUT a) { - delete static_cast<My_Value_Input*>(a); + if (fl_inside_callback) { + fl_delete_widget(a); + } else { + delete static_cast<My_Value_Input*>(a); + } } diff --git a/body/c_fl_value_output.cpp b/body/c_fl_value_output.cpp index 5e42996..2929cc7 100644 --- a/body/c_fl_value_output.cpp +++ b/body/c_fl_value_output.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Value_Output.H> #include "c_fl_value_output.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ VALUEOUTPUT new_fl_value_output(int x, int y, int w, int h, char* label) { } void free_fl_value_output(VALUEOUTPUT a) { - delete static_cast<My_Value_Output*>(a); + if (fl_inside_callback) { + fl_delete_widget(a); + } else { + delete static_cast<My_Value_Output*>(a); + } } diff --git a/body/c_fl_value_slider.cpp b/body/c_fl_value_slider.cpp index ac7498c..4d881c9 100644 --- a/body/c_fl_value_slider.cpp +++ b/body/c_fl_value_slider.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Value_Slider.H> #include "c_fl_value_slider.h" +#include "c_fl.h" @@ -57,7 +58,11 @@ VALUESLIDER new_fl_value_slider(int x, int y, int w, int h, char* label) { } void free_fl_value_slider(VALUESLIDER s) { - delete static_cast<My_Value_Slider*>(s); + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Value_Slider*>(s); + } } diff --git a/body/c_fl_widget.cpp b/body/c_fl_widget.cpp index d226305..4ac39ed 100644 --- a/body/c_fl_widget.cpp +++ b/body/c_fl_widget.cpp @@ -7,6 +7,7 @@ #include <FL/Fl_Widget.H> #include <FL/Fl_Image.H> #include "c_fl_widget.h" +#include "c_fl.h" @@ -65,7 +66,11 @@ WIDGET new_fl_widget(int x, int y, int w, int h, char* label) { } void free_fl_widget(WIDGET w) { - delete static_cast<My_Widget*>(w); + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Widget*>(w); + } } diff --git a/body/c_fl_window.cpp b/body/c_fl_window.cpp index e41af01..d0314be 100644 --- a/body/c_fl_window.cpp +++ b/body/c_fl_window.cpp @@ -7,6 +7,7 @@ #include <FL/Fl_Window.H> #include <FL/Fl_RGB_Image.H> #include "c_fl_window.h" +#include "c_fl.h" @@ -67,7 +68,11 @@ WINDOW new_fl_window2(int w, int h, char* label) { } void free_fl_window(WINDOW n) { - delete static_cast<My_Window*>(n); + if (fl_inside_callback) { + fl_delete_widget(n); + } else { + delete static_cast<My_Window*>(n); + } } diff --git a/body/c_fl_wizard.cpp b/body/c_fl_wizard.cpp index e29995a..b494cc3 100644 --- a/body/c_fl_wizard.cpp +++ b/body/c_fl_wizard.cpp @@ -6,6 +6,7 @@ #include <FL/Fl_Wizard.H> #include "c_fl_wizard.h" +#include "c_fl.h" @@ -67,7 +68,11 @@ WIZARD new_fl_wizard(int x, int y, int w, int h, char* label) { } void free_fl_wizard(WIZARD w) { - delete static_cast<My_Wizard*>(w); + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Wizard*>(w); + } } diff --git a/body/fltk-show_argv.adb b/body/fltk-args_marshal.adb index 52e22e2..f08e025 100644 --- a/body/fltk-show_argv.adb +++ b/body/fltk-args_marshal.adb @@ -7,10 +7,10 @@ with Ada.Command_Line, - Interfaces.C.Strings; + Interfaces.C; -package body FLTK.Show_Argv is +package body FLTK.Args_Marshal is package ACom renames Ada.Command_Line; @@ -31,20 +31,26 @@ package body FLTK.Show_Argv is 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, IntC.int (ACom.Argument_Count + 1), - Storage.To_Integer (Argv (Argv'First)'Address)); - for Ptr of Argv loop - ICS.Free (Ptr); - end loop; + Func (CObj, Argv'Length, Storage.To_Integer (Argv (Argv'First)'Address)); + Free_Argv (Argv); end Dispatch; -end FLTK.Show_Argv; +end FLTK.Args_Marshal; diff --git a/body/fltk-show_argv.ads b/body/fltk-args_marshal.ads index faa93a4..b19c182 100644 --- a/body/fltk-show_argv.ads +++ b/body/fltk-args_marshal.ads @@ -6,10 +6,19 @@ with - Interfaces.C; + 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); -private package FLTK.Show_Argv is -- Used for implementing show(argc,argv) @@ -32,6 +41,6 @@ private pragma Convention (C, Show_With_Args_Func); -end FLTK.Show_Argv; +end FLTK.Args_Marshal; diff --git a/body/fltk-asks.adb b/body/fltk-asks.adb index 034a674..8d4f900 100644 --- a/body/fltk-asks.adb +++ b/body/fltk-asks.adb @@ -234,9 +234,9 @@ package body FLTK.Asks is - --------------- - -- Cleanup -- - --------------- + ------------------- + -- Destructors -- + ------------------- procedure Finalize (This : in out Dialog_String_Final_Controller) @@ -254,6 +254,21 @@ package body FLTK.Asks is + -------------------- + -- Constructors -- + -------------------- + + -- You can get out of a hole by digging deeper, right? + procedure fl_box_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_box_extra_init, "fl_box_extra_init"); + pragma Inline (fl_box_extra_init); + + + + ----------------------- -- API Subprograms -- ----------------------- @@ -362,13 +377,17 @@ package body FLTK.Asks is (Message, Button1 : in String) return Choice_Result is - Result : Interfaces.C.int := fl_ask_choice + Result : constant Interfaces.C.int := fl_ask_choice (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.Null_Ptr, Interfaces.C.Strings.Null_Ptr); begin return Choice_Result'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Choice; @@ -377,13 +396,17 @@ package body FLTK.Asks is return Choice_Result is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); - Result : Interfaces.C.int := fl_ask_choice + Result : constant Interfaces.C.int := fl_ask_choice (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), Interfaces.C.Strings.Null_Ptr); begin return Choice_Result'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Choice; @@ -393,13 +416,17 @@ package body FLTK.Asks is is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); - Result : Interfaces.C.int := fl_ask_choice + Result : constant Interfaces.C.int := fl_ask_choice (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access)); begin return Choice_Result'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Choice; @@ -407,7 +434,7 @@ package body FLTK.Asks is (Message, Button1 : in String) return Extended_Choice_Result is - Result : Interfaces.C.int := fl_ask_choice_n + Result : constant Interfaces.C.int := fl_ask_choice_n (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.Null_Ptr, @@ -427,7 +454,7 @@ package body FLTK.Asks is return Extended_Choice_Result is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); - Result : Interfaces.C.int := fl_ask_choice_n + Result : constant Interfaces.C.int := fl_ask_choice_n (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), @@ -448,7 +475,7 @@ package body FLTK.Asks is is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); - Result : Interfaces.C.int := fl_ask_choice_n + Result : constant Interfaces.C.int := fl_ask_choice_n (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), @@ -468,7 +495,7 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_input + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_input (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin @@ -493,7 +520,7 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_password + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_password (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin @@ -520,8 +547,8 @@ package body FLTK.Asks is C_R : Interfaces.C.double := Interfaces.C.double (R); C_G : Interfaces.C.double := Interfaces.C.double (G); C_B : Interfaces.C.double := Interfaces.C.double (B); - M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); - Result : Interfaces.C.int := fl_ask_color_chooser + M : constant Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : constant Interfaces.C.int := fl_ask_color_chooser (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin if Result = 1 then @@ -550,8 +577,8 @@ package body FLTK.Asks is C_R : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (R); C_G : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (G); C_B : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (B); - M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); - Result : Interfaces.C.int := fl_ask_color_chooser2 + M : constant Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : constant Interfaces.C.int := fl_ask_color_chooser2 (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin if Result = 1 then @@ -583,7 +610,7 @@ package body FLTK.Asks is Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default), Boolean'Pos (Relative)); @@ -602,7 +629,7 @@ package body FLTK.Asks is Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_file_chooser + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_file_chooser (Interfaces.C.To_C (Message), Interfaces.C.To_C (Filter_Pattern), Interfaces.C.To_C (Default), @@ -685,6 +712,14 @@ begin Wrapper (Icon_Box).Void_Ptr := fl_ask_message_icon; Wrapper (Icon_Box).Needs_Dealloc := False; + fl_box_extra_init + (Storage.To_Integer (Icon_Box'Address), + Interfaces.C.int (Icon_Box.Get_X), + Interfaces.C.int (Icon_Box.Get_Y), + Interfaces.C.int (Icon_Box.Get_W), + Interfaces.C.int (Icon_Box.Get_H), + Interfaces.C.To_C (Icon_Box.Get_Label)); + fl_ask_file_chooser_callback (Storage.To_Integer (File_Chooser_Callback_Hook'Address)); 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-devices-surface-paged-postscript.adb b/body/fltk-devices-surface-paged-postscript.adb index 76553b1..07284bb 100644 --- a/body/fltk-devices-surface-paged-postscript.adb +++ b/body/fltk-devices-surface-paged-postscript.adb @@ -7,7 +7,7 @@ with Ada.Assertions, - Interfaces.C.Strings; + Interfaces.C; use type @@ -75,11 +75,12 @@ package body FLTK.Devices.Surface.Paged.Postscript is -- Driver -- - function fl_postscript_file_device_get_driver - (D : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_postscript_file_device_get_driver, "fl_postscript_file_device_get_driver"); - pragma Inline (fl_postscript_file_device_get_driver); + -- function fl_postscript_file_device_get_driver + -- (D : in Storage.Integer_Address) + -- return Storage.Integer_Address; + -- pragma Import (C, fl_postscript_file_device_get_driver, + -- "fl_postscript_file_device_get_driver"); + -- pragma Inline (fl_postscript_file_device_get_driver); @@ -362,7 +363,7 @@ package body FLTK.Devices.Surface.Paged.Postscript is Format : in Page_Format := A4; Layout : in Page_Layout := Portrait) is - Code : Interfaces.C.int := fl_postscript_file_device_start_job3 + Code : constant Interfaces.C.int := fl_postscript_file_device_start_job3 (This.Void_Ptr, Output.C_File, Interfaces.C.int (Count), @@ -383,7 +384,7 @@ package body FLTK.Devices.Surface.Paged.Postscript is Format : in Page_Format := A4; Layout : in Page_Layout := Portrait) is - Code : Interfaces.C.int := fl_postscript_file_device_start_job4 + Code : constant Interfaces.C.int := fl_postscript_file_device_start_job4 (This.Void_Ptr, Interfaces.C.int (Count), To_Cint (Format), diff --git a/body/fltk-devices-surface-paged-printers.adb b/body/fltk-devices-surface-paged-printers.adb index e460eb1..8ee0660 100644 --- a/body/fltk-devices-surface-paged-printers.adb +++ b/body/fltk-devices-surface-paged-printers.adb @@ -6,7 +6,7 @@ with - Interfaces.C.Strings; + Interfaces.C; use type diff --git a/body/fltk-devices-surface-paged.adb b/body/fltk-devices-surface-paged.adb index 950d3ce..fbc8dc6 100644 --- a/body/fltk-devices-surface-paged.adb +++ b/body/fltk-devices-surface-paged.adb @@ -7,7 +7,6 @@ with Ada.Assertions, - Ada.Strings.Unbounded, Interfaces.C.Strings; use type diff --git a/body/fltk-draw.adb b/body/fltk-draw.adb index e7119ed..38ccb80 100644 --- a/body/fltk-draw.adb +++ b/body/fltk-draw.adb @@ -14,8 +14,7 @@ with use type - Interfaces.C.int, - Interfaces.C.size_t; + Interfaces.C.int; package body FLTK.Draw is @@ -642,7 +641,7 @@ package body FLTK.Draw is function Can_Do_Alpha_Blending return Boolean is - Result : Interfaces.C.int := fl_draw_can_do_alpha_blending; + Result : constant Interfaces.C.int := fl_draw_can_do_alpha_blending; begin if Result = 1 then return True; @@ -662,7 +661,7 @@ package body FLTK.Draw is return String is begin return Interfaces.C.Strings.Value - (fl_draw_shortcut_label (Interfaces.C.unsigned (To_C (Keys)))); + (fl_draw_shortcut_label (To_C (Keys))); end Shortcut_Label; @@ -716,7 +715,7 @@ package body FLTK.Draw is return Boolean is CX, CY, CW, CH : Interfaces.C.int; - Result : Interfaces.C.int := fl_draw_clip_box + Result : constant Interfaces.C.int := fl_draw_clip_box (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), @@ -1007,12 +1006,12 @@ package body FLTK.Draw is (X, Y, W, H : in Integer; Data : in Color_Component_Array; Depth : in Positive := 3; - Line_Data : in Natural := 0; + Line_Size : in Natural := 0; Flip_Horizontal : in Boolean := False; Flip_Vertical : in Boolean := False) is Real_Depth : Integer := Depth; - Real_Line_Data : Integer := Line_Data; + Real_Line_Data : Integer := Line_Size; begin if Flip_Horizontal then Real_Depth := Real_Depth * (-1); @@ -1025,7 +1024,9 @@ package body FLTK.Draw is end if; end if; fl_draw_draw_image - (Storage.To_Integer (Data (Data'First)'Address), + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), @@ -1038,18 +1039,17 @@ package body FLTK.Draw is Image_Func_Ptr : Image_Draw_Function; procedure Draw_Image_Hook - (User : in Storage.Integer_Address; + (Ignore : in Storage.Integer_Address; X, Y, W : in Interfaces.C.int; Buf_Ptr : in Storage.Integer_Address); - pragma Convention (C, Draw_Image_Hook); procedure Draw_Image_Hook - (User : in Storage.Integer_Address; + (Ignore : in Storage.Integer_Address; X, Y, W : in Interfaces.C.int; Buf_Ptr : in Storage.Integer_Address) is - Data_Buffer : Color_Component_Array (1 .. Integer (W)); + Data_Buffer : Color_Component_Array (1 .. Size_Type (W)); for Data_Buffer'Address use Storage.To_Address (Buf_Ptr); pragma Import (Ada, Data_Buffer); begin @@ -1077,12 +1077,12 @@ package body FLTK.Draw is (X, Y, W, H : in Integer; Data : in Color_Component_Array; Depth : in Positive := 1; - Line_Data : in Natural := 0; + Line_Size : in Natural := 0; Flip_Horizontal : Boolean := False; Flip_Vertical : Boolean := False) is Real_Depth : Integer := Depth; - Real_Line_Data : Integer := Line_Data; + Real_Line_Data : Integer := Line_Size; begin if Flip_Horizontal then Real_Depth := Real_Depth * (-1); @@ -1095,7 +1095,9 @@ package body FLTK.Draw is end if; end if; fl_draw_draw_image_mono - (Storage.To_Integer (Data (Data'First)'Address), + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), @@ -1108,18 +1110,17 @@ package body FLTK.Draw is Mono_Image_Func_Ptr : Image_Draw_Function; procedure Draw_Image_Mono_Hook - (User : in Storage.Integer_Address; + (Ignore : in Storage.Integer_Address; X, Y, W : in Interfaces.C.int; Buf_Ptr : in Storage.Integer_Address); - pragma Convention (C, Draw_Image_Mono_Hook); procedure Draw_Image_Mono_Hook - (User : in Storage.Integer_Address; + (Ignore : in Storage.Integer_Address; X, Y, W : in Interfaces.C.int; Buf_Ptr : in Storage.Integer_Address) is - Data_Buffer : Color_Component_Array (1 .. Integer (W)); + Data_Buffer : Color_Component_Array (1 .. Size_Type (W)); for Data_Buffer'Address use Storage.To_Address (Buf_Ptr); pragma Import (Ada, Data_Buffer); begin @@ -1148,15 +1149,15 @@ package body FLTK.Draw is Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; Pixels : in FLTK.Images.Pixmaps.Pixmap_Data; X, Y : in Integer; - Hue : in Color := Grey0_Color) + Tone : in Color := Grey0_Color) is C_Data : Pixmap_Marshal.chars_ptr_array_access := Pixmap_Marshal.Marshal_Data (Values, Colors, Pixels); - Result : Interfaces.C.int := fl_draw_draw_pixmap + Result : constant Interfaces.C.int := fl_draw_draw_pixmap (Storage.To_Integer (C_Data (C_Data'First)'Address), Interfaces.C.int (X), Interfaces.C.int (Y), - Interfaces.C.unsigned (Hue)); + Interfaces.C.unsigned (Tone)); begin pragma Assert (Result /= 0); Pixmap_Marshal.Free_Recursive (C_Data); @@ -1172,18 +1173,26 @@ package body FLTK.Draw is Alpha : in Integer := 0) return Color_Component_Array is - My_Len : Integer := (if Alpha = 0 then W * H * 3 else W * H * 4); + My_Len : constant Size_Type := + (if Alpha = 0 + then Size_Type (W) * Size_Type (H) * 3 + else Size_Type (W) * Size_Type (H) * 4); Result : Color_Component_Array (1 .. My_Len); Buffer : Storage.Integer_Address; begin Buffer := fl_draw_read_image - (Storage.To_Integer (Result (Result'First)'Address), + ((if Result'Length > 0 + then Storage.To_Integer (Result (Result'First)'Address) + else Null_Pointer), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), Interfaces.C.int (Alpha)); - pragma Assert (Buffer = Storage.To_Integer (Result (Result'First)'Address)); + pragma Assert + ((if Result'Length > 0 + then Buffer = Storage.To_Integer (Result (Result'First)'Address) + else Buffer = Null_Pointer)); return Result; exception when Chk.Assertion_Error => raise Internal_FLTK_Error with @@ -1201,7 +1210,7 @@ package body FLTK.Draw is Callback : in Symbol_Draw_Function; Scalable : in Boolean) is - Ret_Val : Interfaces.C.int := fl_draw_add_symbol + Ret_Val : constant Interfaces.C.int := fl_draw_add_symbol (Interfaces.C.To_C (Text), Storage.To_Integer (Callback.all'Address), Boolean'Pos (Scalable)); @@ -1374,7 +1383,7 @@ package body FLTK.Draw is Name : in String; Hue : in Color) is - Ret_Val : Interfaces.C.int := fl_draw_draw_symbol + Ret_Val : constant Interfaces.C.int := fl_draw_draw_symbol (Interfaces.C.To_C (Name), Interfaces.C.int (X), Interfaces.C.int (Y), @@ -1479,7 +1488,7 @@ package body FLTK.Draw is Buffer : Interfaces.C.Strings.chars_ptr; Length : Interfaces.C.int; Temp : Interfaces.C.char_array := Interfaces.C.To_C (Text); - Result : Char_Pointers.Pointer := fl_draw_expand_text + Result : constant Char_Pointers.Pointer := fl_draw_expand_text (Temp, Buffer, 0, Interfaces.C.double (Max_Width), Length, diff --git a/body/fltk-environment.adb b/body/fltk-environment.adb index f09795f..c510e26 100644 --- a/body/fltk-environment.adb +++ b/body/fltk-environment.adb @@ -125,9 +125,9 @@ package body FLTK.Environment is pragma Inline (fl_preferences_flush); function fl_preferences_getuserdatapath - (E : in Storage.Integer_Address; - P : in Interfaces.C.char_array; - L : in Interfaces.C.int) + (E : in Storage.Integer_Address; + P : out Interfaces.C.char_array; + L : in Interfaces.C.int) return Interfaces.C.int; pragma Import (C, fl_preferences_getuserdatapath, "fl_preferences_getuserdatapath"); pragma Inline (fl_preferences_getuserdatapath); @@ -285,11 +285,11 @@ package body FLTK.Environment is pragma Inline (fl_preferences_get_str); function fl_preferences_get_str_limit - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : in Interfaces.C.char_array; - D : in Interfaces.C.char_array; - M : in Interfaces.C.int) + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : out Interfaces.C.char_array; + D : in Interfaces.C.char_array; + M : in Interfaces.C.int) return Interfaces.C.int; pragma Import (C, fl_preferences_get_str_limit, "fl_preferences_get_str_limit"); pragma Inline (fl_preferences_get_str_limit); @@ -552,7 +552,7 @@ package body FLTK.Environment is function New_UUID return String is - Text : Interfaces.C.Strings.chars_ptr := fl_preferences_new_uuid; + Text : constant Interfaces.C.Strings.chars_ptr := fl_preferences_new_uuid; begin return Interfaces.C.Strings.Value (Text); end New_UUID; @@ -655,7 +655,7 @@ package body FLTK.Environment is Index : in Positive) return String is - Key : Interfaces.C.Strings.chars_ptr := + Key : constant Interfaces.C.Strings.chars_ptr := fl_preferences_entry (This.Void_Ptr, Interfaces.C.int (Index) - 1); begin -- no need for dealloc? @@ -702,7 +702,7 @@ package body FLTK.Environment is Index : in Positive) return String is - Name : Interfaces.C.Strings.chars_ptr := + Name : constant Interfaces.C.Strings.chars_ptr := fl_preferences_group (This.Void_Ptr, Interfaces.C.int (Index) - 1); begin -- no need for dealloc? @@ -731,7 +731,7 @@ package body FLTK.Environment is (This : in Pref_Group) return String is - Text : Interfaces.C.Strings.chars_ptr := fl_preferences_name (This.Void_Ptr); + Text : constant Interfaces.C.Strings.chars_ptr := fl_preferences_name (This.Void_Ptr); begin if Text = Interfaces.C.Strings.Null_Ptr then return ""; @@ -745,7 +745,7 @@ package body FLTK.Environment is (This : in Pref_Group) return String is - Text : Interfaces.C.Strings.chars_ptr := fl_preferences_path (This.Void_Ptr); + Text : constant Interfaces.C.Strings.chars_ptr := fl_preferences_path (This.Void_Ptr); begin if Text = Interfaces.C.Strings.Null_Ptr then return ""; @@ -783,9 +783,9 @@ package body FLTK.Environment is Default : in Integer) return Integer is - Value, X : Interfaces.C.int; + Value, Ignore : Interfaces.C.int; begin - X := fl_preferences_get_int + Ignore := fl_preferences_get_int (This.Void_Ptr, Interfaces.C.To_C (Key), Value, @@ -819,9 +819,9 @@ package body FLTK.Environment is return Float is Value : Interfaces.C.C_float; - X : Interfaces.C.int; + Ignore : Interfaces.C.int; begin - X := fl_preferences_get_float + Ignore := fl_preferences_get_float (This.Void_Ptr, Interfaces.C.To_C (Key), Value, @@ -855,9 +855,9 @@ package body FLTK.Environment is return Long_Float is Value : Interfaces.C.double; - X : Interfaces.C.int; + Ignore : Interfaces.C.int; begin - X := fl_preferences_get_double + Ignore := fl_preferences_get_double (This.Void_Ptr, Interfaces.C.To_C (Key), Value, @@ -872,7 +872,7 @@ package body FLTK.Environment is return String is Text : Interfaces.C.Strings.chars_ptr; - Check : Interfaces.C.int := fl_preferences_get_str + Check : constant Interfaces.C.int := fl_preferences_get_str (This.Void_Ptr, Interfaces.C.To_C (Key), Text, @@ -884,7 +884,7 @@ package body FLTK.Environment is if Text = Interfaces.C.Strings.Null_Ptr then return ""; end if; - return Str : String := Interfaces.C.Strings.Value (Text) do + return Str : constant String := Interfaces.C.Strings.Value (Text) do Interfaces.C.Strings.Free (Text); end return; end Get; @@ -897,7 +897,7 @@ package body FLTK.Environment is return String is Text : Interfaces.C.Strings.chars_ptr; - X : Interfaces.C.int := fl_preferences_get_str + Ignore : Interfaces.C.int := fl_preferences_get_str (This.Void_Ptr, Interfaces.C.To_C (Key), Text, @@ -906,7 +906,7 @@ package body FLTK.Environment is if Text = Interfaces.C.Strings.Null_Ptr then return Default; end if; - return Str : String := Interfaces.C.Strings.Value (Text) do + return Str : constant String := Interfaces.C.Strings.Value (Text) do Interfaces.C.Strings.Free (Text); end return; end Get; @@ -920,7 +920,7 @@ package body FLTK.Environment is return String is Text : Interfaces.C.char_array := (1 .. Interfaces.C.size_t (Max_Length + 1) => ' '); - Check : Interfaces.C.int := fl_preferences_get_str_limit + Check : constant Interfaces.C.int := fl_preferences_get_str_limit (This.Void_Ptr, Interfaces.C.To_C (Key), Text, @@ -942,7 +942,7 @@ package body FLTK.Environment is is Thing : Storage.Integer_Address; Dummy : Interfaces.C.int := 42; - Check : Interfaces.C.int := fl_preferences_get_void + Check : constant Interfaces.C.int := fl_preferences_get_void (This.Void_Ptr, Interfaces.C.To_C (Key), Thing, @@ -954,12 +954,12 @@ package body FLTK.Environment is raise Preference_Error; end if; declare - Length : Natural := This.Value_Size (Key) * Natural (c_pointer_size); + Length : constant Natural := This.Value_Size (Key) * Natural (c_pointer_size); Actual : Binary_Data (1 .. Length); for Actual'Address use Storage.To_Address (Thing); pragma Import (Ada, Actual); begin - return Result : Binary_Data := Actual do + return Result : constant Binary_Data := Actual do free_fl_preferences_void_data (Thing); end return; end; @@ -979,12 +979,12 @@ package body FLTK.Environment is Thing, Storage.To_Integer (Default'Address), Default'Length / Interfaces.C.int (c_pointer_size)); - Length : Natural := This.Value_Size (Key) * Natural (c_pointer_size); + Length : constant Natural := This.Value_Size (Key) * Natural (c_pointer_size); Actual : Binary_Data (1 .. Length); for Actual'Address use Storage.To_Address (Thing); pragma Import (Ada, Actual); begin - return Result : Binary_Data := Actual do + return Result : constant Binary_Data := Actual do free_fl_preferences_void_data (Thing); end return; end Get; @@ -1005,7 +1005,7 @@ package body FLTK.Environment is Storage.To_Integer (Default'Address), Default'Length / Interfaces.C.int (c_pointer_size), Interfaces.C.int (Max_Length) / Interfaces.C.int (c_pointer_size)); - Length : Natural := This.Value_Size (Key) * Natural (c_pointer_size); + Length : constant Natural := This.Value_Size (Key) * Natural (c_pointer_size); begin return Actual (1 .. Length); end Get; diff --git a/body/fltk-event.adb b/body/fltk-events.adb index 8c3db1f..7a5932f 100644 --- a/body/fltk-event.adb +++ b/body/fltk-events.adb @@ -7,6 +7,7 @@ with Ada.Assertions, + Ada.Containers.Vectors, Interfaces.C.Strings; use type @@ -15,7 +16,7 @@ use type Interfaces.C.Strings.chars_ptr; -package body FLTK.Event is +package body FLTK.Events is package Chk renames Ada.Assertions; @@ -24,6 +25,43 @@ package body FLTK.Event is ------------------------ + -- 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 -- ------------------------ @@ -34,12 +72,38 @@ package body FLTK.Event is pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); pragma Inline (fl_event_add_handler); - procedure fl_event_set_event_dispatch + 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_event_dispatch, "fl_event_set_event_dispatch"); - pragma Inline (fl_event_set_event_dispatch); + 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); - -- 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) @@ -92,6 +156,31 @@ package body FLTK.Event is 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); + @@ -113,6 +202,12 @@ package body FLTK.Event is 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); + @@ -179,10 +274,15 @@ package body FLTK.Event is pragma Import (C, fl_event_is_click, "fl_event_is_click"); pragma Inline (fl_event_is_click); - function fl_event_is_clicks + 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_is_clicks, "fl_event_is_clicks"); - pragma Inline (fl_event_is_clicks); + 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); @@ -209,6 +309,27 @@ package body FLTK.Event is 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; @@ -269,41 +390,100 @@ package body FLTK.Event 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; - -- 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; + -- 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) + 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 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; @@ -315,14 +495,14 @@ package body FLTK.Event 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 @@ -333,38 +513,78 @@ package body FLTK.Event is 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 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 + 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; - -- procedure Set_Dispatch - -- (Func : in Event_Dispatch) is - -- begin - -- Current_Dispatch := Func; - -- end Set_Dispatch; + function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome + is + Result : constant 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 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; + function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome + is + Result : constant 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; @@ -477,6 +697,50 @@ package body FLTK.Event is 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 : constant 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 : constant 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 -- @@ -492,7 +756,7 @@ package body FLTK.Event is function Text return String is - Str : Interfaces.C.Strings.chars_ptr := fl_event_text; + Str : constant Interfaces.C.Strings.chars_ptr := fl_event_text; begin if Str = Interfaces.C.Strings.Null_Ptr then return ""; @@ -509,21 +773,34 @@ package body FLTK.Event is 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 + return Event_Kind + is + Value : constant Interfaces.C.int := fl_event_get; begin - return Event_Kind'Val (fl_event_get); + 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 (fl_event_state); + return To_Ada (Interfaces.C.unsigned (fl_event_state)); end Last_Modifier; @@ -531,7 +808,7 @@ package body FLTK.Event is (Had : in Modifier) return Boolean is begin - return fl_event_check_state (To_C (Had)) /= 0; + return fl_event_check_state (Interfaces.C.int (To_C (Had))) /= 0; end Last_Modifier; @@ -596,24 +873,73 @@ package body FLTK.Event is 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_is_clicks /= 0; + return fl_event_get_clicks /= 0; end Is_Multi_Click; + function Get_Clicks + return Natural + is + Raw : constant 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 - fl_event_set_clicks (Interfaces.C.int (To)); + 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 + return Mouse_Button + is + Code : constant Interfaces.C.int := fl_event_button; begin - return Mouse_Button'Val (fl_event_button); + 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; @@ -638,6 +964,46 @@ package body FLTK.Event is 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 : constant 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 @@ -657,14 +1023,14 @@ package body FLTK.Event is function Last_Key return Keypress is begin - return To_Ada (fl_event_key); + return To_Ada (Interfaces.C.unsigned (fl_event_key)); end Last_Key; function Original_Last_Key return Keypress is begin - return To_Ada (fl_event_original_key); + return To_Ada (Interfaces.C.unsigned (fl_event_original_key)); end Original_Last_Key; @@ -672,7 +1038,7 @@ package body FLTK.Event is (Key : in Keypress) return Boolean is begin - return fl_event_key_during (To_C (Key)) /= 0; + return fl_event_key_during (Interfaces.C.int (To_C (Key))) /= 0; end Pressed_During; @@ -680,7 +1046,7 @@ package body FLTK.Event is (Key : in Keypress) return Boolean is begin - return fl_event_get_key (To_C (Key)) /= 0; + return fl_event_get_key (Interfaces.C.int (To_C (Key))) /= 0; end Key_Now; @@ -716,9 +1082,9 @@ begin fl_event_add_handler (Storage.To_Integer (Event_Handler_Hook'Address)); - -- fl_event_set_event_dispatch (Storage.To_Integer (Dispatch_Hook'Address)); + fl_event_add_system_handler (Storage.To_Integer (System_Handler_Hook'Address), Null_Pointer); -end FLTK.Event; +end FLTK.Events; diff --git a/body/fltk-file_choosers.adb b/body/fltk-file_choosers.adb index a1ef4f7..ef33753 100644 --- a/body/fltk-file_choosers.adb +++ b/body/fltk-file_choosers.adb @@ -39,16 +39,16 @@ package body FLTK.File_Choosers is pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); pragma Inline (fl_widget_get_user_data); - procedure fl_widget_set_user_data - (W, D : in Storage.Integer_Address); - pragma Import (C, fl_widget_set_user_data, "fl_widget_set_user_data"); - pragma Inline (fl_widget_set_user_data); + -- procedure fl_widget_set_user_data + -- (W, D : in Storage.Integer_Address); + -- pragma Import (C, fl_widget_set_user_data, "fl_widget_set_user_data"); + -- pragma Inline (fl_widget_set_user_data); - function fl_file_chooser_get_user_data - (F : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_file_chooser_get_user_data, "fl_file_chooser_get_user_data"); - pragma Inline (fl_file_chooser_get_user_data); + -- function fl_file_chooser_get_user_data + -- (F : in Storage.Integer_Address) + -- return Storage.Integer_Address; + -- pragma Import (C, fl_file_chooser_get_user_data, "fl_file_chooser_get_user_data"); + -- pragma Inline (fl_file_chooser_get_user_data); procedure fl_file_chooser_set_user_data (F, U : in Storage.Integer_Address); @@ -514,14 +514,13 @@ package body FLTK.File_Choosers is procedure File_Chooser_Callback_Hook - (C_Addr, User_Data : in Storage.Integer_Address); - + (Ignore, User_Data : in Storage.Integer_Address); pragma Convention (C, File_Chooser_Callback_Hook); procedure File_Chooser_Callback_Hook - (C_Addr, User_Data : in Storage.Integer_Address) + (Ignore, User_Data : in Storage.Integer_Address) is - Ada_Obj : access File_Chooser'Class := + Ada_Obj : constant access File_Chooser'Class := File_Chooser_Convert.To_Pointer (Storage.To_Address (User_Data)); begin if Ada_Obj.My_Callback /= null then @@ -536,28 +535,11 @@ package body FLTK.File_Choosers is -- Destructors -- ------------------- - -- Releasing carrier pigeon - procedure fl_button_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_button_extra_final, "fl_button_extra_final"); - pragma Inline (fl_button_extra_final); - - - -- Entering wormhole - procedure fl_check_button_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_check_button_extra_final, "fl_check_button_extra_final"); - pragma Inline (fl_check_button_extra_final); - - procedure Extra_Final (This : in out File_Chooser) is use Interfaces.C.Strings; begin - fl_button_extra_final (Storage.To_Integer (This.New_Butt'Address)); - fl_check_button_extra_final (Storage.To_Integer (This.Preview_Butt'Address)); - fl_check_button_extra_final (Storage.To_Integer (This.Hidden_Butt'Address)); Free (This.My_Label); Free (This.My_OK_Label); end Extra_Final; @@ -960,18 +942,19 @@ package body FLTK.File_Choosers is (This : in out File_Chooser; Item : in out Widgets.Widget'Class) is - C_Addr : Storage.Integer_Address; + Ignore : Storage.Integer_Address := + fl_file_chooser_add_extra (This.Void_Ptr, Wrapper (Item).Void_Ptr); begin - C_Addr := fl_file_chooser_add_extra (This.Void_Ptr, Wrapper (Item).Void_Ptr); + null; end Add_Extra; procedure Remove_Extra (This : in out File_Chooser) is - C_Addr : Storage.Integer_Address; + Ignore : Storage.Integer_Address := fl_file_chooser_add_extra (This.Void_Ptr, Null_Pointer); begin - C_Addr := fl_file_chooser_add_extra (This.Void_Ptr, Null_Pointer); + null; end Remove_Extra; @@ -1080,7 +1063,7 @@ package body FLTK.File_Choosers is (This : in File_Chooser) return Boolean is - Ret : Interfaces.C.int := fl_file_chooser_get_preview (This.Void_Ptr); + Ret : constant Interfaces.C.int := fl_file_chooser_get_preview (This.Void_Ptr); begin pragma Assert (Ret in 0 .. 1); return Boolean'Val (Ret); @@ -1151,7 +1134,7 @@ package body FLTK.File_Choosers is (This : in File_Chooser) return Chooser_Kind is - Ret : Interfaces.C.int := fl_file_chooser_get_type (This.Void_Ptr); + Ret : constant Interfaces.C.int := fl_file_chooser_get_type (This.Void_Ptr); begin pragma Assert (Ret in 0 .. Chooser_Kind'Pos (Chooser_Kind'Last)); return Chooser_Kind'Val (Ret); @@ -1186,7 +1169,8 @@ package body FLTK.File_Choosers is (This : in File_Chooser) return String is - C_Ptr : Interfaces.C.Strings.chars_ptr := fl_file_chooser_get_directory (This.Void_Ptr); + C_Ptr : constant Interfaces.C.Strings.chars_ptr := + fl_file_chooser_get_directory (This.Void_Ptr); begin if C_Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1217,7 +1201,8 @@ package body FLTK.File_Choosers is (This : in File_Chooser) return String is - C_Ptr : Interfaces.C.Strings.chars_ptr := fl_file_chooser_get_filter (This.Void_Ptr); + C_Ptr : constant Interfaces.C.Strings.chars_ptr := + fl_file_chooser_get_filter (This.Void_Ptr); begin if C_Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1279,7 +1264,7 @@ package body FLTK.File_Choosers is Index : in Positive := 1) return String is - C_Ptr : Interfaces.C.Strings.chars_ptr := + C_Ptr : constant Interfaces.C.Strings.chars_ptr := fl_file_chooser_get_value (This.Void_Ptr, Interfaces.C.int (Index)); begin if C_Ptr = Interfaces.C.Strings.Null_Ptr then diff --git a/body/fltk-filenames.adb b/body/fltk-filenames.adb index 0612810..9e41b7d 100644 --- a/body/fltk-filenames.adb +++ b/body/fltk-filenames.adb @@ -63,17 +63,17 @@ package body FLTK.Filenames is pragma Inline (filename_decode_uri); function filename_absolute - (To : in Interfaces.C.char_array; - Len : in Interfaces.C.int; - From : in Interfaces.C.char_array) + (To : out Interfaces.C.char_array; + Len : in Interfaces.C.int; + From : in Interfaces.C.char_array) return Interfaces.C.int; pragma Import (C, filename_absolute, "filename_absolute"); pragma Inline (filename_absolute); function filename_expand - (To : in Interfaces.C.char_array; - Len : in Interfaces.C.int; - From : in Interfaces.C.char_array) + (To : out Interfaces.C.char_array; + Len : in Interfaces.C.int; + From : in Interfaces.C.char_array) return Interfaces.C.int; pragma Import (C, filename_expand, "filename_expand"); pragma Inline (filename_expand); @@ -111,9 +111,9 @@ package body FLTK.Filenames is pragma Inline (filename_name); function filename_relative - (To : in Interfaces.C.char_array; - Len : in Interfaces.C.int; - From : in Interfaces.C.char_array) + (To : out Interfaces.C.char_array; + Len : in Interfaces.C.int; + From : in Interfaces.C.char_array) return Interfaces.C.int; pragma Import (C, filename_relative, "filename_relative"); pragma Inline (filename_relative); @@ -127,8 +127,9 @@ package body FLTK.Filenames is pragma Inline (filename_setext); function filename_open_uri - (U, M : in Interfaces.C.char_array; - Len : in Interfaces.C.int) + (U : in Interfaces.C.char_array; + M : out Interfaces.C.char_array; + Len : in Interfaces.C.int) return Interfaces.C.int; pragma Import (C, filename_open_uri, "filename_open_uri"); pragma Inline (filename_open_uri); @@ -171,7 +172,7 @@ package body FLTK.Filenames is (A, B : in String) return Comparison is - Result : Interfaces.C.int := + Result : constant Interfaces.C.int := filename_alphasort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); begin pragma Assert @@ -188,7 +189,7 @@ package body FLTK.Filenames is (A, B : in String) return Comparison is - Result : Interfaces.C.int := + Result : constant Interfaces.C.int := filename_casealphasort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); begin pragma Assert @@ -205,7 +206,7 @@ package body FLTK.Filenames is (A, B : in String) return Comparison is - Result : Interfaces.C.int := + Result : constant Interfaces.C.int := filename_numericsort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); begin pragma Assert @@ -222,7 +223,7 @@ package body FLTK.Filenames is (A, B : in String) return Comparison is - Result : Interfaces.C.int := + Result : constant Interfaces.C.int := filename_casenumericsort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); begin pragma Assert @@ -279,7 +280,7 @@ package body FLTK.Filenames is (URI : in Path_String) return Path_String is - C_Ptr : Interfaces.C.char_array := Interfaces.C.To_C (URI); + C_Ptr : constant Interfaces.C.char_array := Interfaces.C.To_C (URI); begin filename_decode_uri (C_Ptr); return Interfaces.C.To_Ada (C_Ptr); @@ -291,7 +292,7 @@ package body FLTK.Filenames is is Message : Interfaces.C.char_array (1 .. Interfaces.C.size_t (error_bsize)) := (others => Interfaces.C.char'Val (0)); - Result : Interfaces.C.int := filename_open_uri + Result : constant Interfaces.C.int := filename_open_uri (Interfaces.C.To_C (URI), Message, error_bsize); @@ -317,7 +318,7 @@ package body FLTK.Filenames is is Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := (others => Interfaces.C.char'Val (0)); - Code : Interfaces.C.int := filename_absolute + Ignore : constant Interfaces.C.int := filename_absolute (Result, Interfaces.C.int (Max_Path_Length), Interfaces.C.To_C (Name)); @@ -333,7 +334,7 @@ package body FLTK.Filenames is is Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := (others => Interfaces.C.char'Val (0)); - Code : Interfaces.C.int := filename_absolute + Code : constant Interfaces.C.int := filename_absolute (Result, Interfaces.C.int (Max_Path_Length), Interfaces.C.To_C (Name)); @@ -349,7 +350,7 @@ package body FLTK.Filenames is is Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := (others => Interfaces.C.char'Val (0)); - Code : Interfaces.C.int := filename_relative + Ignore : constant Interfaces.C.int := filename_relative (Result, Interfaces.C.int (Max_Path_Length), Interfaces.C.To_C (Name)); @@ -365,7 +366,7 @@ package body FLTK.Filenames is is Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := (others => Interfaces.C.char'Val (0)); - Code : Interfaces.C.int := filename_relative + Code : constant Interfaces.C.int := filename_relative (Result, Interfaces.C.int (Max_Path_Length), Interfaces.C.To_C (Name)); @@ -381,7 +382,7 @@ package body FLTK.Filenames is is Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := (others => Interfaces.C.char'Val (0)); - Code : Interfaces.C.int := filename_expand + Ignore : constant Interfaces.C.int := filename_expand (Result, Interfaces.C.int (Max_Path_Length), Interfaces.C.To_C (Name)); @@ -397,7 +398,7 @@ package body FLTK.Filenames is is Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := (others => Interfaces.C.char'Val (0)); - Code : Interfaces.C.int := filename_expand + Code : constant Interfaces.C.int := filename_expand (Result, Interfaces.C.int (Max_Path_Length), Interfaces.C.To_C (Name)); @@ -415,7 +416,7 @@ package body FLTK.Filenames is (Name : in Path_String) return Path_String is - Data : Interfaces.C.char_array := Interfaces.C.To_C (Name); + Data : constant Interfaces.C.char_array := Interfaces.C.To_C (Name); begin return Interfaces.C.Strings.Value (filename_name (Data)); end Base_Name; @@ -425,8 +426,8 @@ package body FLTK.Filenames is (Name : in Path_String) return Path_String is - Data : Interfaces.C.char_array := Interfaces.C.To_C (Name); - Result : Interfaces.C.Strings.chars_ptr := filename_ext (Data); + Data : constant Interfaces.C.char_array := Interfaces.C.To_C (Name); + Result : constant Interfaces.C.Strings.chars_ptr := filename_ext (Data); begin if Result = Interfaces.C.Strings.Null_Ptr then return ""; @@ -478,7 +479,7 @@ package body FLTK.Filenames is (DA, DB : in Storage.Integer_Address) return Interfaces.C.int is - Result : Comparison := Current_Sort + Result : constant Comparison := Current_Sort (Interfaces.C.Strings.Value (filename_dname (DA, 0)), Interfaces.C.Strings.Value (filename_dname (DB, 0))); begin diff --git a/body/fltk-help_dialogs.adb b/body/fltk-help_dialogs.adb index 48cdf18..d316662 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; @@ -282,7 +282,8 @@ package body FLTK.Help_Dialogs is (This : in Help_Dialog) return String is - Raw_Chars : Interfaces.C.Strings.chars_ptr := fl_help_dialog_get_value (This.Void_Ptr); + Raw_Chars : constant Interfaces.C.Strings.chars_ptr := + fl_help_dialog_get_value (This.Void_Ptr); use type Interfaces.C.Strings.chars_ptr; begin if Raw_Chars = Interfaces.C.Strings.Null_Ptr then diff --git a/body/fltk-images-bitmaps.adb b/body/fltk-images-bitmaps.adb index cfb63d7..5b59c13 100644 --- a/body/fltk-images-bitmaps.adb +++ b/body/fltk-images-bitmaps.adb @@ -118,7 +118,9 @@ package body FLTK.Images.Bitmaps is begin return This : Bitmap do This.Void_Ptr := new_fl_bitmap - (Storage.To_Integer (Data (Data'First)'Address), + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), Interfaces.C.int (Width), Interfaces.C.int (Height)); end return; @@ -135,13 +137,13 @@ package body FLTK.Images.Bitmaps is -- Contracts -- - function To_Next_Byte + function Bytes_Needed (Bits : in Natural) return Natural is begin - return Integer (Float'Ceiling (Float (Bits) / Float (Color_Component_Array'Component_Size))) - * Color_Component_Array'Component_Size; - end To_Next_Byte; + return Integer (Float'Ceiling + (Float (Bits) / Float (Color_Component_Array'Component_Size))); + end Bytes_Needed; @@ -189,15 +191,15 @@ package body FLTK.Images.Bitmaps is function Data_Size (This : in Bitmap) - return Natural is + return Size_Type is begin - return To_Next_Byte (This.Get_W) * This.Get_H; + return Size_Type (Bytes_Needed (This.Get_W)) * Size_Type (This.Get_H); end Data_Size; function Get_Datum (This : in Bitmap; - Place : in Positive) + Place : in Positive_Size) return Color_Component is The_Data : Color_Component_Array (1 .. This.Data_Size); @@ -210,7 +212,7 @@ package body FLTK.Images.Bitmaps is procedure Set_Datum (This : in out Bitmap; - Place : in Positive; + Place : in Positive_Size; Value : in Color_Component) is The_Data : Color_Component_Array (1 .. This.Data_Size); @@ -223,8 +225,8 @@ package body FLTK.Images.Bitmaps is function Slice (This : in Bitmap; - Low : in Positive; - High : in Natural) + Low : in Positive_Size; + High : in Size_Type) return Color_Component_Array is The_Data : Color_Component_Array (1 .. This.Data_Size); @@ -237,7 +239,7 @@ package body FLTK.Images.Bitmaps is procedure Overwrite (This : in out Bitmap; - Place : in Positive; + Place : in Positive_Size; Values : in Color_Component_Array) is The_Data : Color_Component_Array (1 .. This.Data_Size); diff --git a/body/fltk-images-pixmaps.adb b/body/fltk-images-pixmaps.adb index 80d6c03..8487459 100644 --- a/body/fltk-images-pixmaps.adb +++ b/body/fltk-images-pixmaps.adb @@ -6,8 +6,7 @@ with - FLTK.Pixmap_Marshal, - Interfaces.C.Strings; + FLTK.Pixmap_Marshal; package body FLTK.Images.Pixmaps is diff --git a/body/fltk-images-rgb-jpeg.adb b/body/fltk-images-rgb-jpeg.adb index 8706778..61d06e6 100644 --- a/body/fltk-images-rgb-jpeg.adb +++ b/body/fltk-images-rgb-jpeg.adb @@ -81,7 +81,9 @@ package body FLTK.Images.RGB.JPEG is return This : JPEG_Image do This.Void_Ptr := new_fl_jpeg_image2 (Interfaces.C.To_C (Name), - Storage.To_Integer (Data (Data'First)'Address)); + (if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer)); Raise_Fail_Errors (This); end return; end Create; diff --git a/body/fltk-images-rgb-png.adb b/body/fltk-images-rgb-png.adb index aa25b7b..1f6e7b9 100644 --- a/body/fltk-images-rgb-png.adb +++ b/body/fltk-images-rgb-png.adb @@ -82,7 +82,9 @@ package body FLTK.Images.RGB.PNG is return This : PNG_Image do This.Void_Ptr := new_fl_png_image2 (Interfaces.C.To_C (Name), - Storage.To_Integer (Data (Data'First)'Address), + (if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), Data'Length); Raise_Fail_Errors (This); end return; diff --git a/body/fltk-images-rgb.adb b/body/fltk-images-rgb.adb index f3dff61..71d2520 100644 --- a/body/fltk-images-rgb.adb +++ b/body/fltk-images-rgb.adb @@ -159,7 +159,9 @@ package body FLTK.Images.RGB is begin return This : RGB_Image do This.Void_Ptr := new_fl_rgb_image - (Storage.To_Integer (Data (Data'First)'Address), + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), Interfaces.C.int (Width), Interfaces.C.int (Height), Interfaces.C.int (Depth), @@ -192,14 +194,14 @@ package body FLTK.Images.RGB is -- Static Settings -- function Get_Max_Size - return Natural is + return Size_Type is begin - return Natural (fl_rgb_image_get_max_size); + return Size_Type (fl_rgb_image_get_max_size); end Get_Max_Size; procedure Set_Max_Size - (Value : in Natural) is + (Value : in Size_Type) is begin fl_rgb_image_set_max_size (Interfaces.C.size_t (Value)); end Set_Max_Size; @@ -273,21 +275,21 @@ package body FLTK.Images.RGB is function Data_Size (This : in RGB_Image) - return Natural + return Size_Type is - Per_Line : Natural := This.Get_Line_Size; + Per_Line : constant Natural := This.Get_Line_Size; begin if Per_Line = 0 then - return This.Get_W * This.Get_D * This.Get_H; + return Size_Type (This.Get_W) * Size_Type (This.Get_D) * Size_Type (This.Get_H); else - return Per_Line * This.Get_H; + return Size_Type (Per_Line) * Size_Type (This.Get_H); end if; end Data_Size; function Get_Datum (This : in RGB_Image; - Place : in Positive) + Place : in Positive_Size) return Color_Component is The_Data : Color_Component_Array (1 .. This.Data_Size); @@ -300,7 +302,7 @@ package body FLTK.Images.RGB is procedure Set_Datum (This : in out RGB_Image; - Place : in Positive; + Place : in Positive_Size; Value : in Color_Component) is The_Data : Color_Component_Array (1 .. This.Data_Size); @@ -313,8 +315,8 @@ package body FLTK.Images.RGB is function Slice (This : in RGB_Image; - Low : in Positive; - High : in Natural) + Low : in Positive_Size; + High : in Size_Type) return Color_Component_Array is The_Data : Color_Component_Array (1 .. This.Data_Size); @@ -327,7 +329,7 @@ package body FLTK.Images.RGB is procedure Overwrite (This : in out RGB_Image; - Place : in Positive; + Place : in Positive_Size; Values : in Color_Component_Array) is The_Data : Color_Component_Array (1 .. This.Data_Size); diff --git a/body/fltk-images-shared.adb b/body/fltk-images-shared.adb index e932a09..b8de511 100644 --- a/body/fltk-images-shared.adb +++ b/body/fltk-images-shared.adb @@ -287,7 +287,7 @@ package body FLTK.Images.Shared is (This : in Shared_Image) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_shared_image_name (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_shared_image_name (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; diff --git a/body/fltk-images.adb b/body/fltk-images.adb index 3ce3bee..3d5dce7 100644 --- a/body/fltk-images.adb +++ b/body/fltk-images.adb @@ -6,7 +6,7 @@ with - Interfaces.C.Strings; + Interfaces.C; use type @@ -181,7 +181,7 @@ package body FLTK.Images is procedure Raise_Fail_Errors (This : in Image'Class) is - Result : Interfaces.C.int := fl_image_fail (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_image_fail (This.Void_Ptr); begin if Result = fl_image_err_no_image and This.Is_Empty then raise No_Image_Error; 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..1cbf6fc 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 : constant 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-menu_items.adb b/body/fltk-menu_items.adb index 4ab9f7f..d75dd4a 100644 --- a/body/fltk-menu_items.adb +++ b/body/fltk-menu_items.adb @@ -297,8 +297,8 @@ 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 (Flags)); + Interfaces.C.int (To_C (Shortcut)), + MFlag_To_Cint (Flags)); end return; end Create; @@ -419,7 +419,7 @@ package body FLTK.Menu_Items is (This : in Menu_Item) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_menu_item_get_label (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_menu_item_get_label (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -466,7 +466,7 @@ package body FLTK.Menu_Items is (This : in Menu_Item) return Font_Kind is - Result : Interfaces.C.int := fl_menu_item_get_labelfont (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_menu_item_get_labelfont (This.Void_Ptr); begin return Font_Kind'Val (Result); exception @@ -488,7 +488,7 @@ package body FLTK.Menu_Items is (This : in Menu_Item) return Font_Size is - Result : Interfaces.C.int := fl_menu_item_get_labelsize (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_menu_item_get_labelsize (This.Void_Ptr); begin return Font_Size (Result); exception @@ -510,7 +510,7 @@ package body FLTK.Menu_Items is (This : in Menu_Item) return Label_Kind is - Result : Interfaces.C.int := fl_menu_item_get_labeltype (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_menu_item_get_labeltype (This.Void_Ptr); begin return Label_Kind'Val (Result); exception @@ -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; @@ -552,7 +552,7 @@ package body FLTK.Menu_Items is (This : in Menu_Item) return Menu_Flag is begin - return Menu_Flag (fl_menu_item_get_flags (This.Void_Ptr)); + return Cint_To_MFlag (fl_menu_item_get_flags (This.Void_Ptr)); end Get_Flags; @@ -560,7 +560,7 @@ package body FLTK.Menu_Items is (This : in out Menu_Item; To : in Menu_Flag) is begin - fl_menu_item_set_flags (This.Void_Ptr, Interfaces.C.int (To)); + fl_menu_item_set_flags (This.Void_Ptr, MFlag_To_Cint (To)); end Set_Flags; diff --git a/body/fltk-pixmap_marshal.adb b/body/fltk-pixmap_marshal.adb index 768cd08..966e29b 100644 --- a/body/fltk-pixmap_marshal.adb +++ b/body/fltk-pixmap_marshal.adb @@ -9,8 +9,7 @@ with Ada.Strings.Fixed, Ada.Strings.Unbounded, Ada.Unchecked_Deallocation, - FLTK.Images.Pixmaps, - Interfaces.C.Strings; + FLTK.Images.Pixmaps; package body FLTK.Pixmap_Marshal is @@ -45,7 +44,7 @@ package body FLTK.Pixmap_Marshal is Pixels : in Pix.Pixmap_Data) return chars_ptr_array_access is - C_Data : chars_ptr_array_access := new CS.chars_ptr_array + C_Data : constant chars_ptr_array_access := new CS.chars_ptr_array (1 .. C.size_t (1 + Colors'Length + Pixels'Length (1))); begin -- Header values line 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-screen.adb b/body/fltk-screen.adb index c7c7957..6b8118e 100644 --- a/body/fltk-screen.adb +++ b/body/fltk-screen.adb @@ -17,9 +17,44 @@ 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 -- ------------------------ + -- Environment -- + + procedure fl_screen_display + (V : in Interfaces.C.char_array); + 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); + + + + -- Basic Dimensions -- function fl_screen_x @@ -123,10 +158,59 @@ 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 -- ----------------------- + -- Environment -- + + procedure Set_Display_String + (Value : in String) is + begin + fl_screen_display (Interfaces.C.To_C (Value)); + 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 -- function Get_X return Integer is @@ -297,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-static.adb b/body/fltk-static.adb index 59a3aa2..663a7c7 100644 --- a/body/fltk-static.adb +++ b/body/fltk-static.adb @@ -10,6 +10,8 @@ with Ada.Containers.Vectors, Interfaces.C.Strings, System.Address_To_Access_Conversions, + FLTK.Box_Draw_Marshal, + FLTK.Label_Draw_Marshal, FLTK.Static_Callback_Conversions; use type @@ -27,22 +29,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 +176,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); + @@ -155,12 +234,23 @@ package body FLTK.Static is -- Custom Colors -- + function fl_static_get_color2 + (C : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_static_get_color2, "fl_static_get_color2"); + pragma Inline (fl_static_get_color2); + procedure fl_static_get_color (C : in Interfaces.C.unsigned; R, G, B : out Interfaces.C.unsigned_char); pragma Import (C, fl_static_get_color, "fl_static_get_color"); pragma Inline (fl_static_get_color); + procedure fl_static_set_color2 + (T, F : in Interfaces.C.unsigned); + pragma Import (C, fl_static_set_color2, "fl_static_set_color2"); + pragma Inline (fl_static_set_color2); + procedure fl_static_set_color (C : in Interfaces.C.unsigned; R, G, B : in Interfaces.C.unsigned_char); @@ -173,6 +263,17 @@ package body FLTK.Static is pragma Import (C, fl_static_free_color, "fl_static_free_color"); pragma Inline (fl_static_free_color); + function fl_static_get_box_color + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_static_get_box_color, "fl_static_get_box_color"); + pragma Inline (fl_static_get_box_color); + + procedure fl_static_set_box_color + (T : in Interfaces.C.unsigned); + pragma Import (C, fl_static_set_box_color, "fl_static_set_box_color"); + pragma Inline (fl_static_set_box_color); + procedure fl_static_foreground (R, G, B : in Interfaces.C.unsigned_char); pragma Import (C, fl_static_foreground, "fl_static_foreground"); @@ -210,6 +311,12 @@ package body FLTK.Static is pragma Import (C, fl_static_set_font, "fl_static_set_font"); pragma Inline (fl_static_set_font); + procedure fl_static_set_font2 + (T : in Interfaces.C.int; + S : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_static_set_font2, "fl_static_set_font2"); + pragma Inline (fl_static_set_font2); + function fl_static_get_font_sizes (F : in Interfaces.C.int; A : out Storage.Integer_Address) @@ -258,11 +365,24 @@ package body FLTK.Static is pragma Import (C, fl_static_box_dy, "fl_static_box_dy"); pragma Inline (fl_static_box_dy); + function fl_static_get_boxtype + (T : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_static_get_boxtype, "fl_static_get_boxtype"); + pragma Inline (fl_static_get_boxtype); + procedure fl_static_set_boxtype (T, F : in Interfaces.C.int); pragma Import (C, fl_static_set_boxtype, "fl_static_set_boxtype"); pragma Inline (fl_static_set_boxtype); + procedure fl_static_set_boxtype2 + (T : in Interfaces.C.int; + F : in Storage.Integer_Address; + DX, DY, DW, DH : in Interfaces.C.unsigned_char); + pragma Import (C, fl_static_set_boxtype2, "fl_static_set_boxtype2"); + pragma Inline (fl_static_set_boxtype2); + function fl_static_draw_box_active return Interfaces.C.int; pragma Import (C, fl_static_draw_box_active, "fl_static_draw_box_active"); @@ -271,6 +391,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 +423,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"); @@ -310,25 +452,10 @@ package body FLTK.Static is - -- Input Focus -- - - function fl_static_get_visible_focus - return Interfaces.C.int; - pragma Import (C, fl_static_get_visible_focus, "fl_static_get_visible_focus"); - pragma Inline (fl_static_get_visible_focus); - - procedure fl_static_set_visible_focus - (T : in Interfaces.C.int); - pragma Import (C, fl_static_set_visible_focus, "fl_static_set_visible_focus"); - pragma Inline (fl_static_set_visible_focus); - - - - -- Windows -- procedure fl_static_default_atclose - (W : in Storage.Integer_Address); + (W, U : in Storage.Integer_Address); pragma Import (C, fl_static_default_atclose, "fl_static_default_atclose"); pragma Inline (fl_static_default_atclose); @@ -437,6 +564,37 @@ package body FLTK.Static is -- Callback Hooks -- ---------------------- + Current_Args_Handler : Args_Handler; + + function Args_Hook + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int; + pragma Convention (C, Args_Hook); + + function Args_Hook + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int + is + Result : Natural; + begin + pragma Assert (I < C and V /= Null_Pointer); + Result := Current_Args_Handler (Positive (I)); + I := I + Interfaces.C.int (Result); + return Interfaces.C.int (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Args_Handler callback was supplied unexpected int i value of " & + Interfaces.C.int'Image (I); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Args_Handler callback was supplied irregular argc and argv values of " & + Interfaces.C.int'Image (C) & " and " & Storage.Integer_Address'Image (V); + end Args_Hook; + + procedure Awake_Hook (U : in Storage.Integer_Address); pragma Convention (C, Awake_Hook); @@ -444,7 +602,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; @@ -461,7 +621,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); @@ -477,9 +638,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; @@ -509,17 +676,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 : constant Interfaces.C.int := fl_static_add_awake_handler + (Storage.To_Integer (Awake_Hook'Address), + Conv.To_Address (Func)); begin - fl_static_add_awake_handler - (Storage.To_Integer (Awake_Hook'Address), Conv.To_Address (Func)); + pragma Assert (Result = 0); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with + "Fl::add_awake_handler_ failed to register Awake_Handler callback"; + else + raise Internal_FLTK_Error with + "Fl::add_awake_handler_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; end Add_Awake_Handler; @@ -527,40 +776,77 @@ package body FLTK.Static is return Awake_Handler is Hook, Func : Storage.Integer_Address; + Result : constant Interfaces.C.int := fl_static_get_awake_handler (Hook, Func); begin - fl_static_get_awake_handler (Hook, Func); + pragma Assert (Result = 0); return Conv.To_Awake_Access (Func); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with + "Fl::get_awake_handler_ invoked without prior awake setup"; + else + raise Internal_FLTK_Error with + "Fl::get_awake_handler_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; end Get_Awake_Handler; + procedure Awake + (Func : in Awake_Handler) + is + Result : constant Interfaces.C.int := fl_static_awake2 + (Storage.To_Integer (Awake_Hook'Address), + Conv.To_Address (Func)); + begin + pragma Assert (Result = 0); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with "Fl::awake failed to register Awake_Handler callback"; + else + raise Internal_FLTK_Error with "Fl::awake returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; + end Awake; + + + procedure 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; @@ -569,43 +855,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; @@ -614,16 +900,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; @@ -637,8 +923,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), @@ -648,13 +934,13 @@ package body FLTK.Static is procedure Add_File_Descriptor - (FD : in File_Descriptor; - Mode : in File_Mode; - Func : in File_Handler) is + (FD : in File_Descriptor; + Mode : in File_Mode; + Func : in not null File_Handler) is begin fl_static_add_fd2 (Interfaces.C.int (FD), - File_Mode_Codes (Mode), + FMode_To_Cint (Mode), Storage.To_Integer (FD_Hook'Address), Conv.To_Address (Func)); end Add_File_Descriptor; @@ -671,7 +957,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; @@ -680,30 +966,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; @@ -711,6 +997,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 @@ -724,11 +1018,20 @@ package body FLTK.Static is procedure Set_Color - (To : in Color; + (Target, Source : in Color) is + begin + fl_static_set_color2 + (Interfaces.C.unsigned (Target), + Interfaces.C.unsigned (Source)); + end Set_Color; + + + procedure Set_Color + (Target : in Color; R, G, B : in Color_Component) is begin fl_static_set_color - (Interfaces.C.unsigned (To), + (Interfaces.C.unsigned (Target), Interfaces.C.unsigned_char (R), Interfaces.C.unsigned_char (G), Interfaces.C.unsigned_char (B)); @@ -745,6 +1048,21 @@ package body FLTK.Static is end Free_Color; + function Get_Box_Color + (Tone : in Color) + return Color is + begin + return Color (fl_static_get_box_color (Interfaces.C.unsigned (Tone))); + end Get_Box_Color; + + + procedure Set_Box_Color + (Tone : in Color) is + begin + fl_static_set_box_color (Interfaces.C.unsigned (Tone)); + end Set_Box_Color; + + procedure Set_Foreground (R, G, B : in Color_Component) is begin @@ -798,9 +1116,19 @@ package body FLTK.Static is procedure Set_Font_Kind - (To, From : in Font_Kind) is + (Target, Source : in Font_Kind) is begin - fl_static_set_font (Font_Kind'Pos (To), Font_Kind'Pos (From)); + fl_static_set_font (Font_Kind'Pos (Target), Font_Kind'Pos (Source)); + end Set_Font_Kind; + + + procedure Set_Font_Kind + (Target : in Font_Kind; + Source : in String) is + begin + Interfaces.C.Strings.Free (Font_Overrides (Target)); + Font_Overrides (Target) := Interfaces.C.Strings.New_String (Source); + fl_static_set_font2 (Font_Kind'Pos (Target), Font_Overrides (Target)); end Set_Font_Kind; @@ -821,9 +1149,15 @@ package body FLTK.Static is procedure Setup_Fonts - (How_Many_Set_Up : out Natural) is + (How_Many_Set_Up : out Natural) + is + Result : constant Interfaces.C.int := fl_static_set_fonts; begin - How_Many_Set_Up := Natural (fl_static_set_fonts); + How_Many_Set_Up := Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::set_fonts returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Setup_Fonts; @@ -877,22 +1211,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; @@ -931,10 +1296,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 @@ -951,30 +1331,18 @@ package body FLTK.Static is - -- Input Focus -- - - function Has_Visible_Focus - return Boolean is - begin - return fl_static_get_visible_focus /= 0; - end Has_Visible_Focus; - - - procedure Set_Visible_Focus - (To : in Boolean) is - begin - fl_static_set_visible_focus (Boolean'Pos (To)); - end Set_Visible_Focus; - - - - -- Windows -- procedure Default_Window_Close (Item : in out FLTK.Widgets.Widget'Class) is begin - fl_static_default_atclose (Wrapper (Item).Void_Ptr); + pragma Assert (Wrapper (Item).Void_Ptr /= Null_Pointer); + fl_static_default_atclose + (Wrapper (Item).Void_Ptr, + fl_widget_get_user_data (Wrapper (Item).Void_Ptr)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::default_atclose received uninitialised widget"; end Default_Window_Close; @@ -1069,7 +1437,7 @@ package body FLTK.Static is function Get_Scheme return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_static_get_scheme; + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_static_get_scheme; begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1082,15 +1450,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 : constant Interfaces.C.int := fl_static_is_scheme (Interfaces.C.To_C (Scheme)); begin - return fl_static_is_scheme (Interfaces.C.To_C (Scheme)) /= 0; + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::is_scheme returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Is_Scheme; @@ -1119,9 +1494,15 @@ package body FLTK.Static is -- Scrollbars -- function Get_Default_Scrollbar_Size - return Natural is + return Natural + is + Result : constant Interfaces.C.int := fl_static_get_scrollbar_size; begin - return Natural (fl_static_get_scrollbar_size); + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::scrollbar_size returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Get_Default_Scrollbar_Size; diff --git a/body/fltk-text_buffers.adb b/body/fltk-text_buffers.adb index f113e22..a870ece 100644 --- a/body/fltk-text_buffers.adb +++ b/body/fltk-text_buffers.adb @@ -498,11 +498,11 @@ package body FLTK.Text_Buffers is UD : in Storage.Integer_Address) is Action : Modification; - Place : Position := Position (Pos); + Place : constant Position := Position (Pos); Length : Natural; Deleted_Text : Unbounded_String := To_Unbounded_String (""); - Ada_Text_Buffer : access Text_Buffer := + Ada_Text_Buffer : constant access Text_Buffer := Text_Buffer_Convert.To_Pointer (Storage.To_Address (UD)); begin if Ada_Text_Buffer.CB_Active then @@ -534,10 +534,10 @@ package body FLTK.Text_Buffers is (Pos, Deleted : in Interfaces.C.int; UD : in Storage.Integer_Address) is - Place : Position := Position (Pos); - Length : Natural := Natural (Deleted); + Place : constant Position := Position (Pos); + Length : constant Natural := Natural (Deleted); - Ada_Text_Buffer : access Text_Buffer := + Ada_Text_Buffer : constant access Text_Buffer := Text_Buffer_Convert.To_Pointer (Storage.To_Address (UD)); begin if Ada_Text_Buffer.CB_Active then @@ -682,10 +682,10 @@ package body FLTK.Text_Buffers is Name : in String; Buffer : in Natural := 128 * 1024) is - Err_No : Interfaces.C.int := fl_text_buffer_loadfile - (This.Void_Ptr, - Interfaces.C.To_C (Name), - Interfaces.C.int (Buffer)); + Err_No : constant Interfaces.C.int := fl_text_buffer_loadfile + (This.Void_Ptr, + Interfaces.C.To_C (Name), + Interfaces.C.int (Buffer)); begin if Err_No /= 0 then raise Storage_Error with Interfaces.C.Strings.Value (strerror (Err_No)); @@ -698,7 +698,7 @@ package body FLTK.Text_Buffers is Name : in String; Buffer : in Natural := 128 * 1024) is - Err_No : Interfaces.C.int := fl_text_buffer_appendfile + Err_No : constant Interfaces.C.int := fl_text_buffer_appendfile (This.Void_Ptr, Interfaces.C.To_C (Name), Interfaces.C.int (Buffer)); @@ -715,7 +715,7 @@ package body FLTK.Text_Buffers is Place : in Position; Buffer : in Natural := 128 * 1024) is - Err_No : Interfaces.C.int := fl_text_buffer_insertfile + Err_No : constant Interfaces.C.int := fl_text_buffer_insertfile (This.Void_Ptr, Interfaces.C.To_C (Name), Interfaces.C.int (Place), @@ -733,7 +733,7 @@ package body FLTK.Text_Buffers is Start, Finish : in Position; Buffer : in Natural := 128 * 1024) is - Err_No : Interfaces.C.int := fl_text_buffer_outputfile + Err_No : constant Interfaces.C.int := fl_text_buffer_outputfile (This.Void_Ptr, Interfaces.C.To_C (Name), Interfaces.C.int (Start), @@ -751,10 +751,10 @@ package body FLTK.Text_Buffers is Name : in String; Buffer : in Natural := 128 * 1024) is - Err_No : Interfaces.C.int := fl_text_buffer_savefile - (This.Void_Ptr, - Interfaces.C.To_C (Name), - Interfaces.C.int (Buffer)); + Err_No : constant Interfaces.C.int := fl_text_buffer_savefile + (This.Void_Ptr, + Interfaces.C.To_C (Name), + Interfaces.C.int (Buffer)); begin if Err_No /= 0 then raise Storage_Error with Interfaces.C.Strings.Value (strerror (Err_No)); @@ -772,9 +772,9 @@ package body FLTK.Text_Buffers is Text : in String) is begin fl_text_buffer_insert - (This.Void_Ptr, - Interfaces.C.int (Place), - Interfaces.C.To_C (Text)); + (This.Void_Ptr, + Interfaces.C.int (Place), + Interfaces.C.To_C (Text)); end Insert_Text; @@ -806,9 +806,9 @@ package body FLTK.Text_Buffers is Start, Finish : in Position) is begin fl_text_buffer_remove - (This.Void_Ptr, - Interfaces.C.int (Start), - Interfaces.C.int (Finish)); + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); end Remove_Text; @@ -823,7 +823,7 @@ package body FLTK.Text_Buffers is return ""; else declare - Ada_String : String := Interfaces.C.Strings.Value (Raw); + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); begin Interfaces.C.Strings.Free (Raw); return Ada_String; @@ -856,8 +856,8 @@ package body FLTK.Text_Buffers is return Character is begin return Character'Val (fl_text_buffer_char_at - (This.Void_Ptr, - Interfaces.C.int (Place))); + (This.Void_Ptr, + Interfaces.C.int (Place))); end Character_At; @@ -867,15 +867,15 @@ package body FLTK.Text_Buffers is return String is C_Str : Interfaces.C.Strings.chars_ptr := fl_text_buffer_text_range - (This.Void_Ptr, - Interfaces.C.int (Start), - Interfaces.C.int (Finish)); + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); begin if C_Str = Interfaces.C.Strings.Null_Ptr then return ""; else declare - The_Text : String := Interfaces.C.Strings.Value (C_Str); + The_Text : constant String := Interfaces.C.Strings.Value (C_Str); begin Interfaces.C.Strings.Free (C_Str); return The_Text; @@ -1001,9 +1001,9 @@ package body FLTK.Text_Buffers is Start, Finish : in Position) is begin fl_text_buffer_select - (This.Void_Ptr, - Interfaces.C.int (Start), - Interfaces.C.int (Finish)); + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); end Set_Selection; @@ -1045,7 +1045,7 @@ package body FLTK.Text_Buffers is return ""; else declare - Ada_String : String := Interfaces.C.Strings.Value (Raw); + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); begin Interfaces.C.Strings.Free (Raw); return Ada_String; @@ -1065,7 +1065,7 @@ package body FLTK.Text_Buffers is return ""; else declare - Ada_String : String := Interfaces.C.Strings.Value (Raw); + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); begin Interfaces.C.Strings.Free (Raw); return Ada_String; @@ -1155,7 +1155,7 @@ package body FLTK.Text_Buffers is return ""; else declare - Ada_String : String := Interfaces.C.Strings.Value (Raw); + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); begin Interfaces.C.Strings.Free (Raw); return Ada_String; @@ -1324,7 +1324,7 @@ package body FLTK.Text_Buffers is return ""; else declare - Ada_String : String := Interfaces.C.Strings.Value (Raw); + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); begin Interfaces.C.Strings.Free (Raw); return Ada_String; diff --git a/body/fltk-widgets-boxes.adb b/body/fltk-widgets-boxes.adb index 6bd11f4..efe6e54 100644 --- a/body/fltk-widgets-boxes.adb +++ b/body/fltk-widgets-boxes.adb @@ -86,6 +86,30 @@ package body FLTK.Widgets.Boxes is -- Constructors -- -------------------- + -- Hole successfully dug out of + procedure box_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, box_extra_init_hook, "box_extra_init_hook"); + + procedure box_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr) + is + My_Box : Box; + for My_Box'Address use Storage.To_Address (Ada_Obj); + pragma Import (Ada, My_Box); + begin + Extra_Init + (My_Box, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Interfaces.C.Strings.Value (C_Str)); + end box_extra_init_hook; + + procedure Extra_Init (This : in out Box; X, Y, W, H : in Integer; diff --git a/body/fltk-widgets-buttons-light-check.adb b/body/fltk-widgets-buttons-light-check.adb index b75ef64..c3f1971 100644 --- a/body/fltk-widgets-buttons-light-check.adb +++ b/body/fltk-widgets-buttons-light-check.adb @@ -55,22 +55,6 @@ package body FLTK.Widgets.Buttons.Light.Check is -- Destructors -- ------------------- - -- Round the world and home again, that's the sailor's way! - procedure check_button_extra_final_hook - (Ada_Obj : in Storage.Integer_Address); - pragma Export (C, check_button_extra_final_hook, "check_button_extra_final_hook"); - - procedure check_button_extra_final_hook - (Ada_Obj : in Storage.Integer_Address) - is - My_Check_Button : Check_Button; - for My_Check_Button'Address use Storage.To_Address (Ada_Obj); - pragma Import (Ada, My_Check_Button); - begin - Extra_Final (My_Check_Button); - end check_button_extra_final_hook; - - procedure Extra_Final (This : in out Check_Button) is begin diff --git a/body/fltk-widgets-buttons.adb b/body/fltk-widgets-buttons.adb index d6e587e..2d1e169 100644 --- a/body/fltk-widgets-buttons.adb +++ b/body/fltk-widgets-buttons.adb @@ -116,22 +116,6 @@ package body FLTK.Widgets.Buttons is -- Destructors -- ------------------- - -- Clipper route successfully navigated - procedure button_extra_final_hook - (Ada_Obj : in Storage.Integer_Address); - pragma Export (C, button_extra_final_hook, "button_extra_final_hook"); - - procedure button_extra_final_hook - (Ada_Obj : in Storage.Integer_Address) - is - My_Button : Button; - for My_Button'Address use Storage.To_Address (Ada_Obj); - pragma Import (Ada, My_Button); - begin - Extra_Final (My_Button); - end button_extra_final_hook; - - procedure Extra_Final (This : in out Button) is begin @@ -293,7 +277,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-clocks-updated-round.adb b/body/fltk-widgets-clocks-updated-round.adb index 0b7590b..a91584e 100644 --- a/body/fltk-widgets-clocks-updated-round.adb +++ b/body/fltk-widgets-clocks-updated-round.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Clocks.Updated.Round is diff --git a/body/fltk-widgets-clocks-updated.adb b/body/fltk-widgets-clocks-updated.adb index 035ffda..63337f1 100644 --- a/body/fltk-widgets-clocks-updated.adb +++ b/body/fltk-widgets-clocks-updated.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Clocks.Updated is diff --git a/body/fltk-widgets-clocks.adb b/body/fltk-widgets-clocks.adb index 0d78df0..dc2ee6d 100644 --- a/body/fltk-widgets-clocks.adb +++ b/body/fltk-widgets-clocks.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Clocks is diff --git a/body/fltk-widgets-groups-browsers-check.adb b/body/fltk-widgets-groups-browsers-check.adb index 9890cdf..c519f31 100644 --- a/body/fltk-widgets-groups-browsers-check.adb +++ b/body/fltk-widgets-groups-browsers-check.adb @@ -321,7 +321,7 @@ package body FLTK.Widgets.Groups.Browsers.Check is Text : in String; Checked : in Boolean := False) is - Code : Interfaces.C.int := fl_check_browser_add + Ignore : Interfaces.C.int := fl_check_browser_add (This.Void_Ptr, Interfaces.C.To_C (Text), Boolean'Pos (Checked)); @@ -334,7 +334,7 @@ package body FLTK.Widgets.Groups.Browsers.Check is (This : in out Check_Browser; Index : in Positive) is - Code : Interfaces.C.int := fl_check_browser_remove + Ignore : Interfaces.C.int := fl_check_browser_remove (This.Void_Ptr, Interfaces.C.int (Index)); begin diff --git a/body/fltk-widgets-groups-browsers-textline-file.adb b/body/fltk-widgets-groups-browsers-textline-file.adb index b437bae..d22cfc1 100644 --- a/body/fltk-widgets-groups-browsers-textline-file.adb +++ b/body/fltk-widgets-groups-browsers-textline-file.adb @@ -266,7 +266,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is (DA, DB : in Storage.Integer_Address) return Interfaces.C.int is - Result : FLTK.Filenames.Comparison := Current_Sort + Result : constant FLTK.Filenames.Comparison := Current_Sort (Interfaces.C.Strings.Value (filename_dname (DA, 0)), Interfaces.C.Strings.Value (filename_dname (DB, 0))); begin @@ -411,7 +411,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is Sort : in not null FLTK.Filenames.Compare_Function := FLTK.Filenames.Numeric_Sort'Access) is - Result : Natural := This.Load (Dir, Sort); + Ignore : constant Natural := This.Load (Dir, Sort); begin null; end Load; @@ -425,7 +425,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is (This : in File_Browser) return File_Kind is - Code : Interfaces.C.int := fl_file_browser_get_filetype (This.Void_Ptr); + Code : constant Interfaces.C.int := fl_file_browser_get_filetype (This.Void_Ptr); begin pragma Assert (Code in File_Kind'Pos (File_Kind'First) .. File_Kind'Pos (File_Kind'Last)); return File_Kind'Val (Code); @@ -448,7 +448,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is (This : in File_Browser) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_file_browser_get_filter (This.Void_Ptr); + Result : constant Interfaces.C.Strings.chars_ptr := + fl_file_browser_get_filter (This.Void_Ptr); begin if Result = Interfaces.C.Strings.Null_Ptr then return ""; diff --git a/body/fltk-widgets-groups-browsers-textline.adb b/body/fltk-widgets-groups-browsers-textline.adb index c772a10..e75ea6f 100644 --- a/body/fltk-widgets-groups-browsers-textline.adb +++ b/body/fltk-widgets-groups-browsers-textline.adb @@ -8,7 +8,6 @@ with Ada.Assertions, Ada.Unchecked_Deallocation, - FLTK.Images, Interfaces.C.Strings; use type @@ -644,7 +643,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is File : in String) is Msg : Interfaces.C.Strings.chars_ptr; - Code : Interfaces.C.int := fl_browser_load (This.Void_Ptr, Interfaces.C.To_C (File)); + Code : constant Interfaces.C.int := + fl_browser_load (This.Void_Ptr, Interfaces.C.To_C (File)); begin if Code = 0 then Msg := get_error_message; @@ -667,7 +667,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline is Line : in Positive) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_browser_get_text + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_browser_get_text (This.Void_Ptr, Interfaces.C.int (Line)); begin @@ -828,7 +828,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline is State : in Boolean := True) return Boolean is - Code : Interfaces.C.int := fl_browser_select + Code : constant Interfaces.C.int := fl_browser_select (This.Void_Ptr, Interfaces.C.int (Line), Boolean'Pos (State)); @@ -846,7 +846,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline is Line : in Positive; State : in Boolean := True) is - Code : Interfaces.C.int := fl_browser_select + Code : constant Interfaces.C.int := fl_browser_select (This.Void_Ptr, Interfaces.C.int (Line), Boolean'Pos (State)); @@ -863,7 +863,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline is Line : in Positive) return Boolean is - Code : Interfaces.C.int := fl_browser_selected + Code : constant Interfaces.C.int := fl_browser_selected (This.Void_Ptr, Interfaces.C.int (Line)); begin @@ -909,7 +909,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline is Line : in Positive) return Boolean is - Code : Interfaces.C.int := fl_browser_displayed + Code : constant Interfaces.C.int := fl_browser_displayed (This.Void_Ptr, Interfaces.C.int (Line)); begin @@ -1174,7 +1174,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is return Interfaces.C.int; for my_item_selected'Address use This.Item_Override_Ptrs (Item_Selected_Ptr); pragma Import (Ada, my_item_selected); - Code : Interfaces.C.int := my_item_selected (This.Void_Ptr, Cursor_To_Address (Item)); + Code : constant Interfaces.C.int := + my_item_selected (This.Void_Ptr, Cursor_To_Address (Item)); begin pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); diff --git a/body/fltk-widgets-groups-browsers.adb b/body/fltk-widgets-groups-browsers.adb index d60ecca..13cdba7 100644 --- a/body/fltk-widgets-groups-browsers.adb +++ b/body/fltk-widgets-groups-browsers.adb @@ -7,7 +7,7 @@ with Ada.Assertions, - Interfaces.C.Strings, + Interfaces.C, System.Address_To_Access_Conversions; @@ -366,7 +366,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Full_List_Width); @@ -382,7 +382,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Full_List_Height); @@ -398,7 +398,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Average_Item_Height); @@ -414,7 +414,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Item_Quick_Height (Address_To_Cursor (Item_Ptr))); @@ -430,7 +430,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Item_Width (Address_To_Cursor (Item_Ptr))); @@ -446,7 +446,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Interfaces.C.int (Ada_Object.Item_Height (Address_To_Cursor (Item_Ptr))); @@ -462,7 +462,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Cursor_To_Address (Ada_Object.Item_First); @@ -478,7 +478,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr : in Storage.Integer_Address) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Cursor_To_Address (Ada_Object.Item_Last); @@ -494,7 +494,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Cursor_To_Address (Ada_Object.Item_Next (Address_To_Cursor (Item_Ptr))); @@ -510,7 +510,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Cursor_To_Address (Ada_Object.Item_Previous (Address_To_Cursor (Item_Ptr))); @@ -528,7 +528,7 @@ package body FLTK.Widgets.Groups.Browsers is Index : in Interfaces.C.int) return Storage.Integer_Address is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); use type Interfaces.C.int; begin @@ -545,7 +545,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address; Int_State : in Interfaces.C.int) is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); use type Interfaces.C.int; begin @@ -564,7 +564,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin return Boolean'Pos (Ada_Object.Item_Selected (Address_To_Cursor (Item_Ptr))); @@ -578,7 +578,7 @@ package body FLTK.Widgets.Groups.Browsers is procedure Item_Swap_Hook (Ada_Addr, A_Ptr, B_Ptr : in Storage.Integer_Address) is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin Ada_Object.Item_Swap (Address_To_Cursor (A_Ptr), Address_To_Cursor (B_Ptr)); @@ -606,13 +606,13 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin Interfaces.C.Strings.Free (Ada_Object.Text_Store (Ada_Object.Current)); Ada_Object.Text_Store (Ada_Object.Current) := Interfaces.C.Strings.New_String (Ada_Object.Item_Text (Address_To_Cursor (Item_Ptr))); - return C_Char_Is_Not_A_String : Interfaces.C.Strings.chars_ptr := + return C_Char_Is_Not_A_String : constant Interfaces.C.Strings.chars_ptr := Ada_Object.Text_Store (Ada_Object.Current) do Ada_Object.Current := Ada_Object.Current + 1; @@ -632,7 +632,7 @@ package body FLTK.Widgets.Groups.Browsers is (Ada_Addr, Item_Ptr : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int) is - Ada_Object : access Browser'Class := + Ada_Object : constant access Browser'Class := Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); begin Ada_Object.Item_Draw @@ -650,18 +650,9 @@ package body FLTK.Widgets.Groups.Browsers is -- Destructors -- ------------------- - -- Preparing to use morse code - procedure fl_scrollbar_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_scrollbar_extra_final, "fl_scrollbar_extra_final"); - pragma Inline (fl_scrollbar_extra_final); - - procedure Extra_Final (This : in out Browser) is begin - fl_scrollbar_extra_final (Storage.To_Integer (This.Horizon'Address)); - fl_scrollbar_extra_final (Storage.To_Integer (This.Vertigo'Address)); Extra_Final (Group (This)); for Index in This.Text_Store'Range loop Interfaces.C.Strings.Free (This.Text_Store (Index)); @@ -803,7 +794,7 @@ package body FLTK.Widgets.Groups.Browsers is Do_Callbacks : in Boolean := False) return Boolean is - Code : Interfaces.C.int := fl_abstract_browser_select + Code : constant Interfaces.C.int := fl_abstract_browser_select (This.Void_Ptr, Cursor_To_Address (Item), Boolean'Pos (State), @@ -823,7 +814,7 @@ package body FLTK.Widgets.Groups.Browsers is State : in Boolean := True; Do_Callbacks : in Boolean := False) is - Code : Interfaces.C.int := fl_abstract_browser_select + Code : constant Interfaces.C.int := fl_abstract_browser_select (This.Void_Ptr, Cursor_To_Address (Item), Boolean'Pos (State), @@ -842,7 +833,7 @@ package body FLTK.Widgets.Groups.Browsers is Do_Callbacks : in Boolean := False) return Boolean is - Code : Interfaces.C.int := fl_abstract_browser_select_only + Code : constant Interfaces.C.int := fl_abstract_browser_select_only (This.Void_Ptr, Cursor_To_Address (Item), Boolean'Pos (Do_Callbacks)); @@ -861,7 +852,7 @@ package body FLTK.Widgets.Groups.Browsers is Item : in Item_Cursor; Do_Callbacks : in Boolean := False) is - Code : Interfaces.C.int := fl_abstract_browser_select_only + Code : constant Interfaces.C.int := fl_abstract_browser_select_only (This.Void_Ptr, Cursor_To_Address (Item), Boolean'Pos (Do_Callbacks)); @@ -887,7 +878,7 @@ package body FLTK.Widgets.Groups.Browsers is Do_Callbacks : in Boolean := False) return Boolean is - Code : Interfaces.C.int := fl_abstract_browser_deselect + Code : constant Interfaces.C.int := fl_abstract_browser_deselect (This.Void_Ptr, Boolean'Pos (Do_Callbacks)); begin @@ -904,7 +895,7 @@ package body FLTK.Widgets.Groups.Browsers is (This : in out Browser; Do_Callbacks : in Boolean := False) is - Code : Interfaces.C.int := fl_abstract_browser_deselect + Code : constant Interfaces.C.int := fl_abstract_browser_deselect (This.Void_Ptr, Boolean'Pos (Do_Callbacks)); begin @@ -929,7 +920,7 @@ package body FLTK.Widgets.Groups.Browsers is Item : in Item_Cursor) return Boolean is - Code : Interfaces.C.int := fl_abstract_browser_displayed + Code : constant Interfaces.C.int := fl_abstract_browser_displayed (This.Void_Ptr, Cursor_To_Address (Item)); begin pragma Assert (Code in 0 .. 1); @@ -964,7 +955,7 @@ package body FLTK.Widgets.Groups.Browsers is (This : in out Browser; Order : in Sort_Order) is - Code : Interfaces.C.int := + Code : constant Interfaces.C.int := (case Order is when Ascending => fl_sort_ascending, when Descending => fl_sort_descending); diff --git a/body/fltk-widgets-groups-color_choosers.adb b/body/fltk-widgets-groups-color_choosers.adb index 15c7000..cce0f08 100644 --- a/body/fltk-widgets-groups-color_choosers.adb +++ b/body/fltk-widgets-groups-color_choosers.adb @@ -268,7 +268,7 @@ package body FLTK.Widgets.Groups.Color_Choosers is (This : in out Color_Chooser; R, G, B : in Long_Float) is - Result : Interfaces.C.int := fl_color_chooser_rgb + Result : constant Interfaces.C.int := fl_color_chooser_rgb (This.Void_Ptr, Interfaces.C.double (R), Interfaces.C.double (G), @@ -287,7 +287,7 @@ package body FLTK.Widgets.Groups.Color_Choosers is R, G, B : in Long_Float) return Boolean is - Result : Interfaces.C.int := fl_color_chooser_rgb + Result : constant Interfaces.C.int := fl_color_chooser_rgb (This.Void_Ptr, Interfaces.C.double (R), Interfaces.C.double (G), @@ -333,7 +333,7 @@ package body FLTK.Widgets.Groups.Color_Choosers is (This : in out Color_Chooser; H, S, V : in Long_Float) is - Result : Interfaces.C.int := fl_color_chooser_hsv + Result : constant Interfaces.C.int := fl_color_chooser_hsv (This.Void_Ptr, Interfaces.C.double (H), Interfaces.C.double (S), @@ -352,7 +352,7 @@ package body FLTK.Widgets.Groups.Color_Choosers is H, S, V : in Long_Float) return Boolean is - Result : Interfaces.C.int := fl_color_chooser_hsv + Result : constant Interfaces.C.int := fl_color_chooser_hsv (This.Void_Ptr, Interfaces.C.double (H), Interfaces.C.double (S), diff --git a/body/fltk-widgets-groups-help_views.adb b/body/fltk-widgets-groups-help_views.adb index cdc0046..d31e532 100644 --- a/body/fltk-widgets-groups-help_views.adb +++ b/body/fltk-widgets-groups-help_views.adb @@ -7,7 +7,7 @@ with Ada.Assertions, - Interfaces.C.Strings, + Interfaces.C, System.Address_To_Access_Conversions; use type @@ -255,7 +255,7 @@ package body FLTK.Widgets.Groups.Help_Views is S : in Interfaces.C.Strings.chars_ptr) return Interfaces.C.Strings.chars_ptr is - User_Data : Storage.Integer_Address := fl_widget_get_user_data (V); + User_Data : constant Storage.Integer_Address := fl_widget_get_user_data (V); Ada_Help_View : access Help_View'Class; begin pragma Assert (User_Data /= Null_Pointer); @@ -463,7 +463,8 @@ package body FLTK.Widgets.Groups.Help_Views is (This : in out Help_View; Name : in String) is - Code : Interfaces.C.int := fl_help_view_load (This.Void_Ptr, Interfaces.C.To_C (Name)); + Code : constant Interfaces.C.int := + fl_help_view_load (This.Void_Ptr, Interfaces.C.To_C (Name)); begin if Code = -1 then raise Load_Help_Error; @@ -481,7 +482,7 @@ package body FLTK.Widgets.Groups.Help_Views is (This : in Help_View) return String is - Raw_Chars : Interfaces.C.Strings.chars_ptr := fl_help_view_title (This.Void_Ptr); + Raw_Chars : constant Interfaces.C.Strings.chars_ptr := fl_help_view_title (This.Void_Ptr); use type Interfaces.C.Strings.chars_ptr; begin if Raw_Chars = Interfaces.C.Strings.Null_Ptr then @@ -496,7 +497,8 @@ package body FLTK.Widgets.Groups.Help_Views is (This : in Help_View) return String is - Raw_Chars : Interfaces.C.Strings.chars_ptr := fl_help_view_get_value (This.Void_Ptr); + Raw_Chars : constant Interfaces.C.Strings.chars_ptr := + fl_help_view_get_value (This.Void_Ptr); use type Interfaces.C.Strings.chars_ptr; begin if Raw_Chars = Interfaces.C.Strings.Null_Ptr then diff --git a/body/fltk-widgets-groups-input_choices.adb b/body/fltk-widgets-groups-input_choices.adb index 0479920..9119768 100644 --- a/body/fltk-widgets-groups-input_choices.adb +++ b/body/fltk-widgets-groups-input_choices.adb @@ -184,25 +184,9 @@ package body FLTK.Widgets.Groups.Input_Choices is -- Destructors -- ------------------- - -- Resorting to smoke signals - procedure fl_text_input_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_text_input_extra_final, "fl_text_input_extra_final"); - pragma Inline (fl_text_input_extra_final); - - - -- Message in a bottle - procedure fl_menu_button_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_menu_button_extra_final, "fl_menu_button_extra_final"); - pragma Inline (fl_menu_button_extra_final); - - procedure Extra_Final (This : in out Input_Choice) is begin - fl_text_input_extra_final (Storage.To_Integer (This.My_Input'Address)); - fl_menu_button_extra_final (Storage.To_Integer (This.My_Menu_Button'Address)); Extra_Final (Group (This)); end Extra_Final; @@ -468,7 +452,7 @@ package body FLTK.Widgets.Groups.Input_Choices is (This : in Input_Choice) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_input_choice_get_value (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_input_choice_get_value (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; diff --git a/body/fltk-widgets-groups-packed.adb b/body/fltk-widgets-groups-packed.adb index c5edda9..d832a35 100644 --- a/body/fltk-widgets-groups-packed.adb +++ b/body/fltk-widgets-groups-packed.adb @@ -173,7 +173,7 @@ package body FLTK.Widgets.Groups.Packed is (This : in Packed_Group) return Pack_Kind is - Result : Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); begin return Pack_Kind'Val (Result); exception diff --git a/body/fltk-widgets-groups-scrolls.adb b/body/fltk-widgets-groups-scrolls.adb index a75d677..65498a6 100644 --- a/body/fltk-widgets-groups-scrolls.adb +++ b/body/fltk-widgets-groups-scrolls.adb @@ -153,34 +153,9 @@ package body FLTK.Widgets.Groups.Scrolls is -- Destructors -- ------------------- - -- I used the FFI to bypass namespace rules and all I got was this lousy tshirt - procedure scroll_extra_final_hook - (Ada_Obj : in Storage.Integer_Address); - pragma Export (C, scroll_extra_final_hook, "scroll_extra_final_hook"); - - procedure scroll_extra_final_hook - (Ada_Obj : in Storage.Integer_Address) - is - My_Scroll : Scroll; - for My_Scroll'Address use Storage.To_Address (Ada_Obj); - pragma Import (Ada, My_Scroll); - begin - Extra_Final (My_Scroll); - end scroll_extra_final_hook; - - - -- It's the only way to be sure - procedure fl_scrollbar_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_scrollbar_extra_final, "fl_scrollbar_extra_final"); - pragma Inline (fl_scrollbar_extra_final); - - procedure Extra_Final (This : in out Scroll) is begin - fl_scrollbar_extra_final (Storage.To_Integer (This.Horizon'Address)); - fl_scrollbar_extra_final (Storage.To_Integer (This.Vertigo'Address)); Extra_Final (Group (This)); end Extra_Final; @@ -397,7 +372,7 @@ package body FLTK.Widgets.Groups.Scrolls is (This : in Scroll) return Scroll_Kind is - Result : Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); begin return Scroll_Kind'Val (Result - 1); exception diff --git a/body/fltk-widgets-groups-spinners.adb b/body/fltk-widgets-groups-spinners.adb index 255daec..d9501ee 100644 --- a/body/fltk-widgets-groups-spinners.adb +++ b/body/fltk-widgets-groups-spinners.adb @@ -481,7 +481,7 @@ package body FLTK.Widgets.Groups.Spinners is (This : in Spinner) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_spinner_get_format (This.Void_Ptr); + Result : constant Interfaces.C.Strings.chars_ptr := fl_spinner_get_format (This.Void_Ptr); begin if Result = Interfaces.C.Strings.Null_Ptr then return ""; @@ -505,7 +505,7 @@ package body FLTK.Widgets.Groups.Spinners is (This : in Spinner) return Spinner_Kind is - Result : Interfaces.C.unsigned_char := fl_spinner_get_type (This.Void_Ptr); + Result : constant Interfaces.C.unsigned_char := fl_spinner_get_type (This.Void_Ptr); begin return Spinner_Kind'Val (Result - 1); exception diff --git a/body/fltk-widgets-groups-tables-row.adb b/body/fltk-widgets-groups-tables-row.adb index 5848cb9..0a7250a 100644 --- a/body/fltk-widgets-groups-tables-row.adb +++ b/body/fltk-widgets-groups-tables-row.adb @@ -232,7 +232,7 @@ package body FLTK.Widgets.Groups.Tables.Row is (This : in Row_Table) return Natural is - Result : Interfaces.C.int := fl_table_row_get_rows (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_row_get_rows (This.Void_Ptr); begin return Natural (Result); exception @@ -259,7 +259,7 @@ package body FLTK.Widgets.Groups.Tables.Row is Row : in Positive) return Boolean is - Result : Interfaces.C.int := fl_table_row_row_selected + Result : constant Interfaces.C.int := fl_table_row_row_selected (This.Void_Ptr, Interfaces.C.int (Row) - 1); begin return Boolean'Val (Result); @@ -275,7 +275,7 @@ package body FLTK.Widgets.Groups.Tables.Row is Row : in Positive; Value : in Selection_State := Selected) is - Result : Interfaces.C.int := fl_table_row_select_row + Result : constant Interfaces.C.int := fl_table_row_select_row (This.Void_Ptr, Interfaces.C.int (Row) - 1, Selection_State'Pos (Value)); @@ -298,7 +298,7 @@ package body FLTK.Widgets.Groups.Tables.Row is Value : in Selection_State := Selected) return Boolean is - Result : Interfaces.C.int := fl_table_row_select_row + Result : constant Interfaces.C.int := fl_table_row_select_row (This.Void_Ptr, Interfaces.C.int (Row) - 1, Selection_State'Pos (Value)); @@ -327,7 +327,7 @@ package body FLTK.Widgets.Groups.Tables.Row is (This : in Row_Table) return Row_Select_Mode is - Result : Interfaces.C.int := fl_table_row_get_type (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_row_get_type (This.Void_Ptr); begin return Row_Select_Mode'Val (Result); exception @@ -355,7 +355,7 @@ package body FLTK.Widgets.Groups.Tables.Row is Row, Column : in Positive; X, Y, W, H : out Integer) is - Result : Interfaces.C.int := fl_table_row_find_cell + Result : constant Interfaces.C.int := fl_table_row_find_cell (This.Void_Ptr, To_Cint (Context), Interfaces.C.int (Row) - 1, diff --git a/body/fltk-widgets-groups-tables.adb b/body/fltk-widgets-groups-tables.adb index 74ed22d..8417cd6 100644 --- a/body/fltk-widgets-groups-tables.adb +++ b/body/fltk-widgets-groups-tables.adb @@ -743,26 +743,9 @@ package body FLTK.Widgets.Groups.Tables is -- Destructors -- ------------------- - -- Attempting to divide by zero - procedure fl_scrollbar_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_scrollbar_extra_final, "fl_scrollbar_extra_final"); - pragma Inline (fl_scrollbar_extra_final); - - - -- Close the door; Open the nExt - procedure fl_scroll_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_scroll_extra_final, "fl_scroll_extra_final"); - pragma Inline (fl_scroll_extra_final); - - procedure Extra_Final (This : in out Table) is begin - fl_scrollbar_extra_final (Storage.To_Integer (This.Horizon'Address)); - fl_scrollbar_extra_final (Storage.To_Integer (This.Vertigo'Address)); - fl_scroll_extra_final (Storage.To_Integer (This.Playing_Area'Address)); Extra_Final (Group (This)); end Extra_Final; @@ -1024,7 +1007,7 @@ package body FLTK.Widgets.Groups.Tables is Item : in Widget'Class) return Extended_Index is - Result : Interfaces.C.int := fl_table_find (This.Void_Ptr, Item.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_find (This.Void_Ptr, Item.Void_Ptr); begin if Result = fl_table_children (This.Void_Ptr) then return No_Index; @@ -1086,7 +1069,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Positive is - Result : Interfaces.C.int := fl_table_callback_col (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_callback_col (This.Void_Ptr); begin return Positive (Result + 1); exception @@ -1100,7 +1083,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Positive is - Result : Interfaces.C.int := fl_table_callback_row (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_callback_row (This.Void_Ptr); begin return Positive (Result + 1); exception @@ -1114,7 +1097,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Table_Context is - Result : Interfaces.C.int := fl_table_callback_context (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_callback_context (This.Void_Ptr); begin return To_Context (Result); exception @@ -1192,7 +1175,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Positive is - Result : Interfaces.C.int := fl_table_get_col_header_height (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_col_header_height (This.Void_Ptr); begin return Positive (Result); exception @@ -1215,7 +1198,7 @@ package body FLTK.Widgets.Groups.Tables is Column : in Positive) return Positive is - Result : Interfaces.C.int := fl_table_get_col_width + Result : constant Interfaces.C.int := fl_table_get_col_width (This.Void_Ptr, Interfaces.C.int (Column) - 1); begin return Positive (Result); @@ -1250,7 +1233,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Natural is - Result : Interfaces.C.int := fl_table_get_cols (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_cols (This.Void_Ptr); begin return Natural (Result); exception @@ -1272,7 +1255,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Positive is - Result : Interfaces.C.int := fl_table_get_col_position (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_col_position (This.Void_Ptr); begin return Positive (Result + 1); exception @@ -1321,7 +1304,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Positive is - Result : Interfaces.C.int := fl_table_get_col_resize_min (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_col_resize_min (This.Void_Ptr); begin return Positive (Result); exception @@ -1379,7 +1362,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Positive is - Result : Interfaces.C.int := fl_table_get_row_header_width (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_row_header_width (This.Void_Ptr); begin return Positive (Result); exception @@ -1402,7 +1385,7 @@ package body FLTK.Widgets.Groups.Tables is Row : in Positive) return Positive is - Result : Interfaces.C.int := fl_table_get_row_height + Result : constant Interfaces.C.int := fl_table_get_row_height (This.Void_Ptr, Interfaces.C.int (Row) - 1); begin return Positive (Result); @@ -1437,7 +1420,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Natural is - Result : Interfaces.C.int := fl_table_get_rows (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_rows (This.Void_Ptr); begin return Natural (Result); exception @@ -1459,7 +1442,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Positive is - Result : Interfaces.C.int := fl_table_get_row_position (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_row_position (This.Void_Ptr); begin return Positive (Result + 1); exception @@ -1508,7 +1491,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Positive is - Result : Interfaces.C.int := fl_table_get_row_resize_min (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_row_resize_min (This.Void_Ptr); begin return Positive (Result); exception @@ -1530,7 +1513,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Positive is - Result : Interfaces.C.int := fl_table_get_top_row (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_top_row (This.Void_Ptr); begin return Positive (Result + 1); exception @@ -1567,7 +1550,7 @@ package body FLTK.Widgets.Groups.Tables is Resize : out Resize_Flag) is C_Row, C_Column, C_Flag : Interfaces.C.int; - Result : Interfaces.C.int := fl_table_cursor2rowcol + Result : constant Interfaces.C.int := fl_table_cursor2rowcol (This.Void_Ptr, C_Row, C_Column, C_Flag); begin Row := Positive (C_Row + 1); @@ -1659,7 +1642,7 @@ package body FLTK.Widgets.Groups.Tables is Row, Column : in Positive) return Boolean is - Result : Interfaces.C.int := fl_table_is_selected + Result : constant Interfaces.C.int := fl_table_is_selected (This.Void_Ptr, Interfaces.C.int (Row) - 1, Interfaces.C.int (Column) - 1); @@ -1677,7 +1660,7 @@ package body FLTK.Widgets.Groups.Tables is Row, Column : in Positive; Shift_Select : in Boolean := True) is - Result : Interfaces.C.int := fl_table_move_cursor + Result : constant Interfaces.C.int := fl_table_move_cursor (This.Void_Ptr, Interfaces.C.int (Row) - 1, Interfaces.C.int (Column) - 1, @@ -1697,7 +1680,7 @@ package body FLTK.Widgets.Groups.Tables is Shift_Select : in Boolean := True) return Boolean is - Result : Interfaces.C.int := fl_table_move_cursor + Result : constant Interfaces.C.int := fl_table_move_cursor (This.Void_Ptr, Interfaces.C.int (Row) - 1, Interfaces.C.int (Column) - 1, @@ -1715,7 +1698,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Tab_Navigation is - Result : Interfaces.C.int := fl_table_get_tab_cell_nav (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_tab_cell_nav (This.Void_Ptr); begin return Tab_Navigation'Val (Result); exception @@ -1737,7 +1720,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Box_Kind is - Result : Interfaces.C.int := fl_table_get_table_box (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_get_table_box (This.Void_Ptr); begin return Box_Kind'Val (Result); exception @@ -1792,7 +1775,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in Table) return Boolean is - Result : Interfaces.C.int := fl_table_is_interactive_resize (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_table_is_interactive_resize (This.Void_Ptr); begin return Boolean'Val (Result); exception @@ -1922,7 +1905,7 @@ package body FLTK.Widgets.Groups.Tables is Row, Column : in Positive; X, Y, W, H : out Integer) is - Result : Interfaces.C.int := fl_table_find_cell + Result : constant Interfaces.C.int := fl_table_find_cell (This.Void_Ptr, To_Cint (Context), Interfaces.C.int (Row) - 1, @@ -1967,7 +1950,7 @@ package body FLTK.Widgets.Groups.Tables is is C_Row : Interfaces.C.int := Interfaces.C.int (Row) - 1; C_Column : Interfaces.C.int := Interfaces.C.int (Column) - 1; - Result : Interfaces.C.int := fl_table_row_col_clamp + Result : constant Interfaces.C.int := fl_table_row_col_clamp (This.Void_Ptr, To_Cint (Context), C_Row, C_Column); @@ -1990,7 +1973,7 @@ package body FLTK.Widgets.Groups.Tables is is C_Row : Interfaces.C.int := Interfaces.C.int (Row) - 1; C_Column : Interfaces.C.int := Interfaces.C.int (Column) - 1; - Result : Interfaces.C.int := fl_table_row_col_clamp + Result : constant Interfaces.C.int := fl_table_row_col_clamp (This.Void_Ptr, To_Cint (Context), C_Row, C_Column); diff --git a/body/fltk-widgets-groups-text_displays-text_editors.adb b/body/fltk-widgets-groups-text_displays-text_editors.adb index 906edef..c2722b6 100644 --- a/body/fltk-widgets-groups-text_displays-text_editors.adb +++ b/body/fltk-widgets-groups-text_displays-text_editors.adb @@ -8,8 +8,7 @@ with Ada.Assertions, Ada.Characters.Latin_1, - FLTK.Event, - Interfaces.C; + FLTK.Events; package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is @@ -385,12 +384,12 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is -- Key Binding Modification -- - procedure fl_text_editor_add_key_binding - (TE : in Storage.Integer_Address; - K, S : in Interfaces.C.int; - F : in Storage.Integer_Address); - pragma Import (C, fl_text_editor_add_key_binding, "fl_text_editor_add_key_binding"); - pragma Inline (fl_text_editor_add_key_binding); + -- procedure fl_text_editor_add_key_binding + -- (TE : in Storage.Integer_Address; + -- K, S : in Interfaces.C.int; + -- F : in Storage.Integer_Address); + -- pragma Import (C, fl_text_editor_add_key_binding, "fl_text_editor_add_key_binding"); + -- pragma Inline (fl_text_editor_add_key_binding); procedure fl_text_editor_remove_all_key_bindings (TE : in Storage.Integer_Address); @@ -473,12 +472,13 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is E : in Storage.Integer_Address) return Interfaces.C.int is - Editor_Ptr : Storage.Integer_Address := fl_widget_get_user_data (E); + Editor_Ptr : constant 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 - Ada_Key : Key_Combo := Extra_Keys + Actual_Key; + Extra_Keys : constant Modifier := FLTK.Events.Last_Modifier; + Actual_Key : constant Keypress := FLTK.Events.Last_Key; + -- fuck you FLTK, give me the real code + Ada_Key : constant Key_Combo := Extra_Keys + Actual_Key; -- For whatever reason, if a regular key function is used then FLTK will -- give you the key code, but if a default key function is used instead it @@ -577,9 +577,7 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is function Create (X, Y, W, H : in Integer; Text : in String := "") - return Text_Editor - is - use type Interfaces.C.int; + return Text_Editor is begin return This : Text_Editor do This.Void_Ptr := new_fl_text_editor @@ -1198,7 +1196,7 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is (This : in Text_Editor) return Insert_Mode is - Result : Interfaces.C.int := fl_text_editor_get_insert_mode (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_editor_get_insert_mode (This.Void_Ptr); begin return Insert_Mode'Val (Result); exception @@ -1220,7 +1218,7 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is (This : in Text_Editor) return Tab_Navigation is - Result : Interfaces.C.int := fl_text_editor_get_tab_nav (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_editor_get_tab_nav (This.Void_Ptr); begin return Tab_Navigation'Val (Result); exception @@ -1255,7 +1253,7 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is (This : in out Text_Editor) return Event_Outcome is - Result : Interfaces.C.int := fl_text_editor_handle_key (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_editor_handle_key (This.Void_Ptr); begin return Event_Outcome'Val (Result); exception diff --git a/body/fltk-widgets-groups-text_displays.adb b/body/fltk-widgets-groups-text_displays.adb index 7fda2fd..ac1f6e9 100644 --- a/body/fltk-widgets-groups-text_displays.adb +++ b/body/fltk-widgets-groups-text_displays.adb @@ -9,8 +9,7 @@ with Ada.Assertions, Ada.Characters.Latin_1, Ada.Unchecked_Conversion, - Interfaces.C.Strings, - FLTK.Text_Buffers; + Interfaces.C.Strings; use type @@ -50,11 +49,11 @@ package body FLTK.Widgets.Groups.Text_Displays is -- Buffers -- - function fl_text_display_get_buffer - (TD : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_text_display_get_buffer, "fl_text_display_get_buffer"); - pragma Inline (fl_text_display_get_buffer); + -- function fl_text_display_get_buffer + -- (TD : in Storage.Integer_Address) + -- return Storage.Integer_Address; + -- pragma Import (C, fl_text_display_get_buffer, "fl_text_display_get_buffer"); + -- pragma Inline (fl_text_display_get_buffer); procedure fl_text_display_set_buffer (TD, TB : in Storage.Integer_Address); @@ -834,7 +833,7 @@ package body FLTK.Widgets.Groups.Text_Displays is is use Styles; -- for maximum stylin' - Ada_Widget : access Text_Display'Class := + Ada_Widget : constant access Text_Display'Class := Text_Display_Convert.To_Pointer (Storage.To_Address (D)); begin if Ada_Widget.Style_Callback /= null then @@ -1010,7 +1009,9 @@ package body FLTK.Widgets.Groups.Text_Displays is fl_text_display_highlight_data (This.Void_Ptr, Wrapper (Buff).Void_Ptr, - Storage.To_Integer (Table (Table'First)'Address), + (if Table'Length > 0 + then Storage.To_Integer (Table (Table'First)'Address) + else Null_Pointer), Table'Length); end Highlight_Data; @@ -1026,7 +1027,9 @@ package body FLTK.Widgets.Groups.Text_Displays is fl_text_display_highlight_data2 (This.Void_Ptr, Wrapper (Buff).Void_Ptr, - Storage.To_Integer (Table (Table'First)'Address), + (if Table'Length > 0 + then Storage.To_Integer (Table (Table'First)'Address) + else Null_Pointer), Table'Length, Interfaces.C.To_C (Unfinished), Storage.To_Integer (Style_Hook'Address), @@ -1041,7 +1044,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Line_Index : in Natural) return Styles.Style_Info is - Result : Interfaces.C.int := fl_text_display_position_style + Result : constant Interfaces.C.int := fl_text_display_position_style (This.Void_Ptr, Interfaces.C.int (Line_Start), Interfaces.C.int (Line_Length), @@ -1134,7 +1137,7 @@ package body FLTK.Widgets.Groups.Text_Displays is X : in Integer) return Natural is - Result : Interfaces.C.int := fl_text_display_find_x + Result : constant Interfaces.C.int := fl_text_display_find_x (This.Void_Ptr, Interfaces.C.To_C (Text), Text'Length, @@ -1155,7 +1158,7 @@ package body FLTK.Widgets.Groups.Text_Displays is return Natural is C_Line_Num : Interfaces.C.int; - Result : Interfaces.C.int := fl_text_display_position_to_line + Result : constant Interfaces.C.int := fl_text_display_position_to_line (This.Void_Ptr, Interfaces.C.int (Position), C_Line_Num); @@ -1179,7 +1182,7 @@ package body FLTK.Widgets.Groups.Text_Displays is return Natural is C_Line_Num : Interfaces.C.int; - Result : Interfaces.C.int := fl_text_display_position_to_line + Result : constant Interfaces.C.int := fl_text_display_position_to_line (This.Void_Ptr, Interfaces.C.int (Position), C_Line_Num); @@ -1204,7 +1207,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Column : out Natural) is C_Line_Num, C_Column : Interfaces.C.int; - Result : Interfaces.C.int := fl_text_display_position_to_linecol + Result : constant Interfaces.C.int := fl_text_display_position_to_linecol (This.Void_Ptr, Interfaces.C.int (Position), C_Line_Num, C_Column); @@ -1231,7 +1234,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Displayed : out Boolean) is C_Line_Num, C_Column : Interfaces.C.int; - Result : Interfaces.C.int := fl_text_display_position_to_linecol + Result : constant Interfaces.C.int := fl_text_display_position_to_linecol (This.Void_Ptr, Interfaces.C.int (Position), C_Line_Num, C_Column); @@ -1257,7 +1260,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Kind : in Position_Kind := Character_Position) return Natural is - Result : Interfaces.C.int := fl_text_display_xy_to_position + Result : constant Interfaces.C.int := fl_text_display_xy_to_position (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y), @@ -1493,7 +1496,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Row : in Natural) return Natural is - Result : Interfaces.C.int := fl_text_display_wrapped_row + Result : constant Interfaces.C.int := fl_text_display_wrapped_row (This.Void_Ptr, Interfaces.C.int (Row)); begin @@ -1510,7 +1513,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Row, Column : in Natural) return Natural is - Result : Interfaces.C.int := fl_text_display_wrapped_column + Result : constant Interfaces.C.int := fl_text_display_wrapped_column (This.Void_Ptr, Interfaces.C.int (Row), Interfaces.C.int (Column)); @@ -1528,7 +1531,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Line_End : in Natural) return Boolean is - Result : Interfaces.C.int := fl_text_display_wrap_uses_character + Result : constant Interfaces.C.int := fl_text_display_wrap_uses_character (This.Void_Ptr, Interfaces.C.int (Line_End)); begin @@ -1693,7 +1696,8 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in Text_Display) return Natural is - Result : Interfaces.C.int := fl_text_display_get_absolute_top_line_number (This.Void_Ptr); + Result : constant Interfaces.C.int := + fl_text_display_get_absolute_top_line_number (This.Void_Ptr); begin return Natural (Result); exception @@ -1715,7 +1719,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in Text_Display) return Boolean is - Result : Interfaces.C.int := fl_text_display_maintaining_absolute_top_line_number + Result : constant Interfaces.C.int := fl_text_display_maintaining_absolute_top_line_number (This.Void_Ptr); begin return Boolean'Val (Result); @@ -1741,7 +1745,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in Text_Display) return Boolean is - Result : Interfaces.C.int := fl_text_display_empty_vlines (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_empty_vlines (This.Void_Ptr); begin return Boolean'Val (Result); exception @@ -1755,7 +1759,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in Text_Display) return Natural is - Result : Interfaces.C.int := fl_text_display_longest_vline (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_longest_vline (This.Void_Ptr); begin return Natural (Result); exception @@ -1770,7 +1774,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Line : in Natural) return Natural is - Result : Interfaces.C.int := fl_text_display_vline_length + Result : constant Interfaces.C.int := fl_text_display_vline_length (This.Void_Ptr, Interfaces.C.int (Line)); begin @@ -1898,7 +1902,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in Text_Display) return String is - Result : Interfaces.C.Strings.chars_ptr := + Result : constant Interfaces.C.Strings.chars_ptr := fl_text_display_get_linenumber_format (This.Void_Ptr); begin if Result = Interfaces.C.Strings.Null_Ptr then @@ -1941,7 +1945,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Line : in Natural) return Natural is - Result : Interfaces.C.int := fl_text_display_measure_vline + Result : constant Interfaces.C.int := fl_text_display_measure_vline (This.Void_Ptr, Interfaces.C.int (Line)); begin @@ -1974,7 +1978,7 @@ package body FLTK.Widgets.Groups.Text_Displays is procedure Move_Down (This : in out Text_Display) is - Result : Interfaces.C.int := fl_text_display_move_down (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_move_down (This.Void_Ptr); begin pragma Assert (Result in 0 .. 1); exception @@ -1988,7 +1992,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display) return Boolean is - Result : Interfaces.C.int := fl_text_display_move_down (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_move_down (This.Void_Ptr); begin return Boolean'Val (Result); exception @@ -2001,7 +2005,7 @@ package body FLTK.Widgets.Groups.Text_Displays is procedure Move_Left (This : in out Text_Display) is - Result : Interfaces.C.int := fl_text_display_move_left (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_move_left (This.Void_Ptr); begin pragma Assert (Result in 0 .. 1); exception @@ -2015,7 +2019,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display) return Boolean is - Result : Interfaces.C.int := fl_text_display_move_left (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_move_left (This.Void_Ptr); begin return Boolean'Val (Result); exception @@ -2028,7 +2032,7 @@ package body FLTK.Widgets.Groups.Text_Displays is procedure Move_Right (This : in out Text_Display) is - Result : Interfaces.C.int := fl_text_display_move_right (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_move_right (This.Void_Ptr); begin pragma Assert (Result in 0 .. 1); exception @@ -2042,7 +2046,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display) return Boolean is - Result : Interfaces.C.int := fl_text_display_move_right (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_move_right (This.Void_Ptr); begin return Boolean'Val (Result); exception @@ -2055,7 +2059,7 @@ package body FLTK.Widgets.Groups.Text_Displays is procedure Move_Up (This : in out Text_Display) is - Result : Interfaces.C.int := fl_text_display_move_up (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_move_up (This.Void_Ptr); begin pragma Assert (Result in 0 .. 1); exception @@ -2069,7 +2073,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display) return Boolean is - Result : Interfaces.C.int := fl_text_display_move_up (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_text_display_move_up (This.Void_Ptr); begin return Boolean'Val (Result); exception @@ -2101,7 +2105,7 @@ package body FLTK.Widgets.Groups.Text_Displays is Pixel : in Natural := 0) return Boolean is - Result : Interfaces.C.int := fl_text_display_scroll2 + Result : constant Interfaces.C.int := fl_text_display_scroll2 (This.Void_Ptr, Interfaces.C.int (Line), Interfaces.C.int (Pixel)); @@ -2172,7 +2176,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 +2184,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-groups-windows-double-cairo.adb b/body/fltk-widgets-groups-windows-double-cairo.adb index 270a30e..1560c20 100644 --- a/body/fltk-widgets-groups-windows-double-cairo.adb +++ b/body/fltk-widgets-groups-windows-double-cairo.adb @@ -81,9 +81,9 @@ package body FLTK.Widgets.Groups.Windows.Double.Cairo is procedure Cairo_Draw_Hook (C_Addr, Cairo_Addr : in Storage.Integer_Address) is - Ada_Addr : System.Address := + Ada_Addr : constant System.Address := Storage.To_Address (fl_widget_get_user_data (C_Addr)); - Ada_Object : access Cairo_Window'Class := + Ada_Object : constant access Cairo_Window'Class := Cairo_Convert.To_Pointer (Ada_Addr); begin pragma Assert (Ada_Object /= null); diff --git a/body/fltk-widgets-groups-windows-double-overlay.adb b/body/fltk-widgets-groups-windows-double-overlay.adb index e6d00cf..94542af 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; @@ -125,7 +125,7 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is procedure Overlay_Window_Draw_Overlay_Hook (U : in Storage.Integer_Address) is - Overlay_Widget : access Overlay_Window'Class := + Overlay_Widget : constant access Overlay_Window'Class := Over_Convert.To_Pointer (Storage.To_Address (U)); begin Overlay_Widget.Draw_Overlay; @@ -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..df61bd9 100644 --- a/body/fltk-widgets-groups-windows-opengl.adb +++ b/body/fltk-widgets-groups-windows-opengl.adb @@ -6,9 +6,8 @@ with - FLTK.Show_Argv, - Interfaces.C, - System; + FLTK.Args_Marshal, + Interfaces.C; use type @@ -355,7 +354,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..55f3506 100644 --- a/body/fltk-widgets-groups-windows.adb +++ b/body/fltk-widgets-groups-windows.adb @@ -6,10 +6,8 @@ with - Ada.Command_Line, Interfaces.C.Strings, - FLTK.Images.RGB, - FLTK.Show_Argv; + FLTK.Args_Marshal; use type @@ -513,7 +511,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; @@ -638,7 +636,9 @@ package body FLTK.Widgets.Groups.Windows is end loop; fl_window_icons (This.Void_Ptr, - Storage.To_Integer (Pointers (Pointers'First)'Address), + (if Pointers'Length > 0 + then Storage.To_Integer (Pointers (Pointers'First)'Address) + else Null_Pointer), Pointers'Length); end Set_Icons; @@ -666,7 +666,9 @@ package body FLTK.Widgets.Groups.Windows is Pointers (Index) := Wrapper (Pics (Index)).Void_Ptr; end loop; fl_window_default_icons - (Storage.To_Integer (Pointers (Pointers'First)'Address), + ((if Pointers'Length > 0 + then Storage.To_Integer (Pointers (Pointers'First)'Address) + else Null_Pointer), Pointers'Length); end Set_Default_Icons; @@ -681,7 +683,7 @@ package body FLTK.Widgets.Groups.Windows is (This : in Window) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_window_get_iconlabel (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_window_get_iconlabel (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -842,7 +844,7 @@ package body FLTK.Widgets.Groups.Windows is (This : in Window) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_window_get_label (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_window_get_label (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -942,7 +944,7 @@ package body FLTK.Widgets.Groups.Windows is (This : in Window) return Boolean is - Result : Interfaces.C.int := fl_window_get_force_position (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_window_get_force_position (This.Void_Ptr); begin return Boolean'Val (Result); exception @@ -1000,7 +1002,7 @@ package body FLTK.Widgets.Groups.Windows is (This : in Window) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_window_get_xclass (This.Void_Ptr); + Result : constant Interfaces.C.Strings.chars_ptr := fl_window_get_xclass (This.Void_Ptr); begin if Result = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1021,7 +1023,7 @@ package body FLTK.Widgets.Groups.Windows is function Get_Default_X_Class return String is - Result : Interfaces.C.Strings.chars_ptr := fl_window_get_default_xclass; + Result : constant Interfaces.C.Strings.chars_ptr := fl_window_get_default_xclass; begin if Result = Interfaces.C.Strings.Null_Ptr then return ""; diff --git a/body/fltk-widgets-groups.adb b/body/fltk-widgets-groups.adb index 6c94c4a..d6b51d4 100644 --- a/body/fltk-widgets-groups.adb +++ b/body/fltk-widgets-groups.adb @@ -217,7 +217,9 @@ package body FLTK.Widgets.Groups is procedure Extra_Final (This : in out Group) is begin - This.Clear; + if This.Needs_Dealloc then + This.Clear; + end if; Extra_Final (Widget (This)); end Extra_Final; @@ -411,7 +413,7 @@ package body FLTK.Widgets.Groups is Item : in Widget'Class) return Extended_Index is - Result : Interfaces.C.int := fl_group_find (This.Void_Ptr, Item.Void_Ptr); + Result : constant Interfaces.C.int := fl_group_find (This.Void_Ptr, Item.Void_Ptr); begin if Result = fl_group_children (This.Void_Ptr) then return No_Index; @@ -436,7 +438,7 @@ package body FLTK.Widgets.Groups is (This : in Group) return Group_Iterators.Reversible_Iterator'Class is begin - return It : Iterator := (My_Container => This'Unrestricted_Access); + return It : constant Iterator := (My_Container => This'Unrestricted_Access); end Iterate; @@ -444,7 +446,7 @@ package body FLTK.Widgets.Groups is (Object : in Iterator) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Object.My_Container, My_Index => 1); end First; @@ -458,7 +460,7 @@ package body FLTK.Widgets.Groups is if Object.My_Container /= Place.My_Container then raise Program_Error; end if; - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Place.My_Container, My_Index => Place.My_Index + 1); end Next; @@ -468,7 +470,7 @@ package body FLTK.Widgets.Groups is (Object : in Iterator) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Object.My_Container, My_Index => Object.My_Container.Number_Of_Children); end Last; @@ -482,7 +484,7 @@ package body FLTK.Widgets.Groups is if Object.My_Container /= Place.My_Container then raise Program_Error; end if; - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Place.My_Container, My_Index => Place.My_Index - 1); end Previous; @@ -496,7 +498,7 @@ package body FLTK.Widgets.Groups is (This : in Group) return Clip_Mode is - Result : Interfaces.C.unsigned := fl_group_get_clip_children (This.Void_Ptr); + Result : constant Interfaces.C.unsigned := fl_group_get_clip_children (This.Void_Ptr); begin return Clip_Mode'Val (Result); exception diff --git a/body/fltk-widgets-inputs-text-file.adb b/body/fltk-widgets-inputs-text-file.adb index ac3cec7..42c4961 100644 --- a/body/fltk-widgets-inputs-text-file.adb +++ b/body/fltk-widgets-inputs-text-file.adb @@ -236,7 +236,7 @@ package body FLTK.Widgets.Inputs.Text.File is (This : in File_Input) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_file_input_get_value (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_file_input_get_value (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -251,7 +251,7 @@ package body FLTK.Widgets.Inputs.Text.File is (This : in out File_Input; To : in String) is - Result : Interfaces.C.int := fl_file_input_set_value + Result : constant Interfaces.C.int := fl_file_input_set_value (This.Void_Ptr, Interfaces.C.To_C (To), To'Length); begin diff --git a/body/fltk-widgets-inputs-text-floating_point.adb b/body/fltk-widgets-inputs-text-floating_point.adb index 4bdcc0f..6a7925c 100644 --- a/body/fltk-widgets-inputs-text-floating_point.adb +++ b/body/fltk-widgets-inputs-text-floating_point.adb @@ -145,7 +145,7 @@ package body FLTK.Widgets.Inputs.Text.Floating_Point is (This : in Float_Input) return Long_Float is - Ptr : Interfaces.C.Strings.chars_ptr := fl_input_get_value (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_input_get_value (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr or else Interfaces.C.Strings.Value (Ptr) = "" diff --git a/body/fltk-widgets-inputs-text-multiline.adb b/body/fltk-widgets-inputs-text-multiline.adb index 4969082..b348ce5 100644 --- a/body/fltk-widgets-inputs-text-multiline.adb +++ b/body/fltk-widgets-inputs-text-multiline.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Inputs.Text.Multiline is diff --git a/body/fltk-widgets-inputs-text-outputs-multiline.adb b/body/fltk-widgets-inputs-text-outputs-multiline.adb index 3f01dc3..e18d9b3 100644 --- a/body/fltk-widgets-inputs-text-outputs-multiline.adb +++ b/body/fltk-widgets-inputs-text-outputs-multiline.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Inputs.Text.Outputs.Multiline is diff --git a/body/fltk-widgets-inputs-text-outputs.adb b/body/fltk-widgets-inputs-text-outputs.adb index eeb83fb..6be0738 100644 --- a/body/fltk-widgets-inputs-text-outputs.adb +++ b/body/fltk-widgets-inputs-text-outputs.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Inputs.Text.Outputs is diff --git a/body/fltk-widgets-inputs-text-secret.adb b/body/fltk-widgets-inputs-text-secret.adb index 72d9f77..146133f 100644 --- a/body/fltk-widgets-inputs-text-secret.adb +++ b/body/fltk-widgets-inputs-text-secret.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Inputs.Text.Secret is diff --git a/body/fltk-widgets-inputs-text-whole_number.adb b/body/fltk-widgets-inputs-text-whole_number.adb index b0a5aa5..070dc0f 100644 --- a/body/fltk-widgets-inputs-text-whole_number.adb +++ b/body/fltk-widgets-inputs-text-whole_number.adb @@ -145,7 +145,7 @@ package body FLTK.Widgets.Inputs.Text.Whole_Number is (This : in Integer_Input) return Long_Integer is - Ptr : Interfaces.C.Strings.chars_ptr := fl_input_get_value (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_input_get_value (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr or else Interfaces.C.Strings.Value (Ptr) = "" diff --git a/body/fltk-widgets-inputs-text.adb b/body/fltk-widgets-inputs-text.adb index 472f279..ddac5d9 100644 --- a/body/fltk-widgets-inputs-text.adb +++ b/body/fltk-widgets-inputs-text.adb @@ -55,22 +55,6 @@ package body FLTK.Widgets.Inputs.Text is -- Destructors -- ------------------- - -- Message received, every zig will take off - procedure text_input_extra_final_hook - (Ada_Obj : in Storage.Integer_Address); - pragma Export (C, text_input_extra_final_hook, "text_input_extra_final_hook"); - - procedure text_input_extra_final_hook - (Ada_Obj : in Storage.Integer_Address) - is - My_Text_Input : Text_Input; - for My_Text_Input'Address use Storage.To_Address (Ada_Obj); - pragma Import (Ada, My_Text_Input); - begin - Extra_Final (My_Text_Input); - end text_input_extra_final_hook; - - procedure Extra_Final (This : in out Text_Input) is begin diff --git a/body/fltk-widgets-inputs.adb b/body/fltk-widgets-inputs.adb index 888ef68..2057f96 100644 --- a/body/fltk-widgets-inputs.adb +++ b/body/fltk-widgets-inputs.adb @@ -429,7 +429,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input; Destination : in Clipboard_Kind := Cut_Paste_Board) is - Result : Interfaces.C.int := fl_input_copy + Result : constant Interfaces.C.int := fl_input_copy (This.Void_Ptr, Clipboard_Kind'Pos (Destination)); begin pragma Assert (Result in 0 .. 1); @@ -445,7 +445,7 @@ package body FLTK.Widgets.Inputs is Destination : in Clipboard_Kind := Cut_Paste_Board) return Boolean is - Result : Interfaces.C.int := fl_input_copy + Result : constant Interfaces.C.int := fl_input_copy (This.Void_Ptr, Clipboard_Kind'Pos (Destination)); begin pragma Assert (Result in 0 .. 1); @@ -460,7 +460,7 @@ package body FLTK.Widgets.Inputs is procedure Cut (This : in out Input) is - Result : Interfaces.C.int := fl_input_cut (This.Void_Ptr); + Ignore : constant Interfaces.C.int := fl_input_cut (This.Void_Ptr); begin null; end Cut; @@ -478,7 +478,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input; Num_Bytes : in Integer) is - Result : Interfaces.C.int := fl_input_cut2 + Ignore : constant Interfaces.C.int := fl_input_cut2 (This.Void_Ptr, Interfaces.C.int (Num_Bytes)); begin @@ -501,7 +501,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input; Start, Finish : in Integer) is - Result : Interfaces.C.int := fl_input_cut3 + Ignore : constant Interfaces.C.int := fl_input_cut3 (This.Void_Ptr, Interfaces.C.int (Start), Interfaces.C.int (Finish)); @@ -525,7 +525,7 @@ package body FLTK.Widgets.Inputs is procedure Copy_Cuts (This : in out Input) is - Result : Interfaces.C.int := fl_input_copy_cuts (This.Void_Ptr); + Ignore : constant Interfaces.C.int := fl_input_copy_cuts (This.Void_Ptr); begin null; end Copy_Cuts; @@ -535,7 +535,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input) return Boolean is - Result : Interfaces.C.int := fl_input_copy_cuts (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_input_copy_cuts (This.Void_Ptr); begin return Result /= 0; end Copy_Cuts; @@ -544,7 +544,7 @@ package body FLTK.Widgets.Inputs is procedure Undo (This : in out Input) is - Result : Interfaces.C.int := fl_input_undo (This.Void_Ptr); + Ignore : constant Interfaces.C.int := fl_input_undo (This.Void_Ptr); begin null; end Undo; @@ -618,7 +618,7 @@ package body FLTK.Widgets.Inputs is (This : in Input) return Input_Kind is - C_Val : Interfaces.C.int := fl_input_get_input_type (This.Void_Ptr); + C_Val : constant Interfaces.C.int := fl_input_get_input_type (This.Void_Ptr); begin for V in Input_Kind loop if Input_Kind_Values (V) = C_Val then @@ -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; @@ -657,7 +657,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input; To : in Natural) is - Result : Interfaces.C.int := fl_input_set_mark + Ignore : constant Interfaces.C.int := fl_input_set_mark (This.Void_Ptr, Interfaces.C.int (To)); begin @@ -688,7 +688,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input; To : in Natural) is - Result : Interfaces.C.int := fl_input_set_position + Ignore : constant Interfaces.C.int := fl_input_set_position (This.Void_Ptr, Interfaces.C.int (To)); begin @@ -712,7 +712,7 @@ package body FLTK.Widgets.Inputs is Place : in Natural; Mark : in Natural) is - Result : Interfaces.C.int := fl_input_set_position2 + Ignore : constant Interfaces.C.int := fl_input_set_position2 (This.Void_Ptr, Interfaces.C.int (Place), Interfaces.C.int (Mark)); @@ -751,7 +751,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input; Str : in String) is - Result : Interfaces.C.int := fl_input_insert + Ignore : constant Interfaces.C.int := fl_input_insert (This.Void_Ptr, Interfaces.C.To_C (Str, False), Str'Length); @@ -777,7 +777,7 @@ package body FLTK.Widgets.Inputs is From, To : in Natural; New_Text : in String) is - Result : Interfaces.C.int := fl_input_replace + Ignore : constant Interfaces.C.int := fl_input_replace (This.Void_Ptr, Interfaces.C.int (From), Interfaces.C.int (To), @@ -807,7 +807,7 @@ package body FLTK.Widgets.Inputs is (This : in Input) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_input_get_value (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_input_get_value (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -822,7 +822,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input; To : in String) is - Result : Interfaces.C.int := fl_input_set_value + Ignore : constant Interfaces.C.int := fl_input_set_value (This.Void_Ptr, Interfaces.C.To_C (To), To'Length); begin null; diff --git a/body/fltk-widgets-menus-choices.adb b/body/fltk-widgets-menus-choices.adb index 80168f9..ac4564c 100644 --- a/body/fltk-widgets-menus-choices.adb +++ b/body/fltk-widgets-menus-choices.adb @@ -7,8 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C, - System; + Interfaces.C; use type diff --git a/body/fltk-widgets-menus-menu_bars-systemwide.adb b/body/fltk-widgets-menus-menu_bars-systemwide.adb index e96772e..88792bb 100644 --- a/body/fltk-widgets-menus-menu_bars-systemwide.adb +++ b/body/fltk-widgets-menus-menu_bars-systemwide.adb @@ -308,7 +308,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is (This : in out System_Menu_Bar; Text : in String) is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add + Ignore : constant Interfaces.C.int := fl_sys_menu_bar_add (This.Void_Ptr, Interfaces.C.To_C (Text)); begin This.Adjust_Item_Store; @@ -320,7 +320,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Text : in String) return Index is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add + Added_Spot : constant Interfaces.C.int := fl_sys_menu_bar_add (This.Void_Ptr, Interfaces.C.To_C (Text)); begin This.Adjust_Item_Store; @@ -335,12 +335,12 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add2 + Ignore : constant 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), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Add; @@ -354,12 +354,12 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add2 + Added_Spot : constant 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), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -373,12 +373,12 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Shortcut : in String; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add3 + Ignore : constant Interfaces.C.int := fl_sys_menu_bar_add3 (This.Void_Ptr, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Add; @@ -392,12 +392,12 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add3 + Added_Spot : constant Interfaces.C.int := fl_sys_menu_bar_add3 (This.Void_Ptr, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -412,13 +412,13 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_insert + Ignore : constant Interfaces.C.int := fl_sys_menu_bar_insert (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), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Insert; @@ -433,13 +433,13 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_insert + Added_Spot : constant Interfaces.C.int := fl_sys_menu_bar_insert (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), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -454,13 +454,13 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Shortcut : in String; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_insert2 + Ignore : constant Interfaces.C.int := fl_sys_menu_bar_insert2 (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Insert; @@ -475,13 +475,13 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_sys_menu_bar_insert2 + Added_Spot : constant Interfaces.C.int := fl_sys_menu_bar_insert2 (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -522,7 +522,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is (This : in out System_Menu_Bar; Place : in Index) is - Result : Interfaces.C.int := fl_sys_menu_bar_clear_submenu + Result : constant Interfaces.C.int := fl_sys_menu_bar_clear_submenu (This.Void_Ptr, Interfaces.C.int (Place) - 1); 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; @@ -593,7 +593,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Place : in Index) return Menu_Flag is begin - return Menu_Flag (fl_sys_menu_bar_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1)); + return Cint_To_MFlag + (fl_sys_menu_bar_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1)); end Get_Flags; @@ -605,7 +606,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is fl_sys_menu_bar_set_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1, - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); end Set_Flags; diff --git a/body/fltk-widgets-menus-menu_buttons.adb b/body/fltk-widgets-menus-menu_buttons.adb index 3c4614c..c305320 100644 --- a/body/fltk-widgets-menus-menu_buttons.adb +++ b/body/fltk-widgets-menus-menu_buttons.adb @@ -90,22 +90,6 @@ package body FLTK.Widgets.Menus.Menu_Buttons is -- Destructors -- ------------------- - -- More magic - procedure menu_button_extra_final_hook - (Ada_Obj : in Storage.Integer_Address); - pragma Export (C, menu_button_extra_final_hook, "menu_button_extra_final_hook"); - - procedure menu_button_extra_final_hook - (Ada_Obj : in Storage.Integer_Address) - is - My_Menu_Button : Menu_Button; - for My_Menu_Button'Address use Storage.To_Address (Ada_Obj); - pragma Import (Ada, My_Menu_Button); - begin - Extra_Final (My_Menu_Button); - end menu_button_extra_final_hook; - - procedure Extra_Final (This : in out Menu_Button) is begin @@ -218,7 +202,7 @@ package body FLTK.Widgets.Menus.Menu_Buttons is (This : in Menu_Button) return Popup_Buttons is - Result : Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); begin return Popup_Buttons'Val (Result); exception @@ -241,7 +225,7 @@ package body FLTK.Widgets.Menus.Menu_Buttons is return Extended_Index is use type Interfaces.C.int; - Ptr : Storage.Integer_Address := fl_menu_button_popup (This.Void_Ptr); + Ptr : constant Storage.Integer_Address := fl_menu_button_popup (This.Void_Ptr); begin return Extended_Index (fl_menu_find_index2 (This.Void_Ptr, Ptr) + 1); end Popup; diff --git a/body/fltk-widgets-menus.adb b/body/fltk-widgets-menus.adb index 3344efd..1295d76 100644 --- a/body/fltk-widgets-menus.adb +++ b/body/fltk-widgets-menus.adb @@ -415,7 +415,7 @@ package body FLTK.Widgets.Menus is procedure Adjust_Item_Store (This : in out Menu) is - Target : Natural := This.Number_Of_Items; + Target : constant Natural := This.Number_Of_Items; begin while Natural (This.My_Items.Length) > Target loop Free_Item (This.My_Items.Reference (This.My_Items.Last_Index)); @@ -446,9 +446,9 @@ package body FLTK.Widgets.Menus is procedure Item_Hook (C_Obj, User_Data : in Storage.Integer_Address) is - Ada_Ptr : Storage.Integer_Address := fl_widget_get_user_data (C_Obj); + Ada_Ptr : constant Storage.Integer_Address := fl_widget_get_user_data (C_Obj); Ada_Widget : access Widget'Class; - Action : Widget_Callback := Callback_Convert.To_Access (User_Data); + Action : constant Widget_Callback := Callback_Convert.To_Access (User_Data); begin pragma Assert (Ada_Ptr /= Null_Pointer); Ada_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Ada_Ptr)); @@ -568,7 +568,7 @@ package body FLTK.Widgets.Menus is (This : in out Menu; Text : in String) is - Added_Spot : Interfaces.C.int := fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); + Ignore : constant Interfaces.C.int := fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); begin This.Adjust_Item_Store; end Add; @@ -579,7 +579,8 @@ package body FLTK.Widgets.Menus is Text : in String) return Index is - Added_Spot : Interfaces.C.int := fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); + Added_Spot : constant Interfaces.C.int := + fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -593,12 +594,12 @@ package body FLTK.Widgets.Menus is Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_menu_add2 + Ignore : constant 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), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Add; @@ -612,12 +613,12 @@ package body FLTK.Widgets.Menus is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_menu_add2 + Added_Spot : constant 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), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -631,12 +632,12 @@ package body FLTK.Widgets.Menus is Shortcut : in String; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_menu_add3 + Ignore : constant Interfaces.C.int := fl_menu_add3 (This.Void_Ptr, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Add; @@ -650,12 +651,12 @@ package body FLTK.Widgets.Menus is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_menu_add3 + Added_Spot : constant Interfaces.C.int := fl_menu_add3 (This.Void_Ptr, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -670,13 +671,13 @@ package body FLTK.Widgets.Menus is Shortcut : in Key_Combo := No_Key; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_menu_insert + Ignore : constant Interfaces.C.int := fl_menu_insert (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), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Insert; @@ -691,13 +692,13 @@ package body FLTK.Widgets.Menus is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_menu_insert + Added_Spot : constant Interfaces.C.int := fl_menu_insert (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), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -712,13 +713,13 @@ package body FLTK.Widgets.Menus is Shortcut : in String; Flags : in Menu_Flag := Flag_Normal) is - Added_Spot : Interfaces.C.int := fl_menu_insert2 + Ignore : constant Interfaces.C.int := fl_menu_insert2 (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; end Insert; @@ -733,13 +734,13 @@ package body FLTK.Widgets.Menus is Flags : in Menu_Flag := Flag_Normal) return Index is - Added_Spot : Interfaces.C.int := fl_menu_insert2 + Added_Spot : constant Interfaces.C.int := fl_menu_insert2 (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), Interfaces.C.To_C (Shortcut), Callback_Convert.To_Address (Action), - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); begin This.Adjust_Item_Store; return Index (Added_Spot + 1); @@ -750,7 +751,8 @@ package body FLTK.Widgets.Menus is (This : in out Menu; Items : in FLTK.Menu_Items.Menu_Item_Array) is - Pointers : aliased array (Items'First .. Items'Last + 1) of Storage.Integer_Address; + Pointers : aliased array + (Items'First .. Integer'Max (Items'First, Items'Last + 1)) of Storage.Integer_Address; pragma Convention (C, Pointers); begin for Place in Pointers'First .. Pointers'Last - 1 loop @@ -796,7 +798,7 @@ package body FLTK.Widgets.Menus is (This : in out Menu; Place : in Index) is - Result : Interfaces.C.int := fl_menu_clear_submenu + Result : constant Interfaces.C.int := fl_menu_clear_submenu (This.Void_Ptr, Interfaces.C.int (Place) - 1); begin @@ -866,7 +868,7 @@ package body FLTK.Widgets.Menus is Name : in String) return FLTK.Menu_Items.Menu_Item_Reference is - Place : Extended_Index := This.Find_Index (Name); + Place : constant Extended_Index := This.Find_Index (Name); begin if Place = No_Index then raise No_Reference_Error; @@ -880,7 +882,7 @@ package body FLTK.Widgets.Menus is Action : in Widget_Callback) return FLTK.Menu_Items.Menu_Item_Reference is - Place : Extended_Index := This.Find_Index (Action); + Place : constant Extended_Index := This.Find_Index (Action); begin if Place = No_Index then raise No_Reference_Error; @@ -894,7 +896,8 @@ package body FLTK.Widgets.Menus is Name : in String) return Extended_Index is - Result : Interfaces.C.int := fl_menu_find_index (This.Void_Ptr, Interfaces.C.To_C (Name)); + Result : constant Interfaces.C.int := + fl_menu_find_index (This.Void_Ptr, Interfaces.C.To_C (Name)); begin return Extended_Index (Result + 1); end Find_Index; @@ -905,7 +908,8 @@ package body FLTK.Widgets.Menus is Item : in FLTK.Menu_Items.Menu_Item) return Extended_Index is - Result : Interfaces.C.int := fl_menu_find_index2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); + Result : constant Interfaces.C.int := + fl_menu_find_index2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); begin return Extended_Index (Result + 1); end Find_Index; @@ -931,7 +935,7 @@ package body FLTK.Widgets.Menus is is Buffer : Interfaces.C.char_array := (0 .. Interfaces.C.size_t (Item_Path_Max) => Interfaces.C.nul); - Result : Interfaces.C.int := fl_menu_item_pathname + Result : constant Interfaces.C.int := fl_menu_item_pathname (This.Void_Ptr, Buffer, Interfaces.C.int (Item_Path_Max), @@ -959,7 +963,7 @@ package body FLTK.Widgets.Menus is is Buffer : Interfaces.C.char_array := (0 .. Interfaces.C.size_t (Item_Path_Max) => Interfaces.C.nul); - Result : Interfaces.C.int := fl_menu_item_pathname + Result : constant Interfaces.C.int := fl_menu_item_pathname (This.Void_Ptr, Buffer, Interfaces.C.int (Item_Path_Max), @@ -999,7 +1003,7 @@ package body FLTK.Widgets.Menus is (This : in Menu) return Menu_Iterators.Reversible_Iterator'Class is begin - return It : Iterator := (My_Container => This'Unrestricted_Access); + return It : constant Iterator := (My_Container => This'Unrestricted_Access); end Iterate; @@ -1007,7 +1011,7 @@ package body FLTK.Widgets.Menus is (Object : in Iterator) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Object.My_Container, My_Index => 1); end First; @@ -1018,7 +1022,7 @@ package body FLTK.Widgets.Menus is Place : in Cursor) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Place.My_Container, My_Index => Place.My_Index + 1); end Next; @@ -1028,7 +1032,7 @@ package body FLTK.Widgets.Menus is (Object : in Iterator) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Object.My_Container, My_Index => Object.My_Container.Number_Of_Items); end Last; @@ -1039,7 +1043,7 @@ package body FLTK.Widgets.Menus is Place : in Cursor) return Cursor is begin - return Cu : Cursor := + return Cu : constant Cursor := (My_Container => Place.My_Container, My_Index => Place.My_Index - 1); end Previous; @@ -1053,7 +1057,7 @@ package body FLTK.Widgets.Menus is (This : in Menu) return FLTK.Menu_Items.Menu_Item_Reference is - Place : Extended_Index := This.Chosen_Index; + Place : constant Extended_Index := This.Chosen_Index; begin if Place = No_Index then raise No_Reference_Error; @@ -1066,7 +1070,7 @@ package body FLTK.Widgets.Menus is (This : in Menu) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_menu_text (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_menu_text (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1145,7 +1149,7 @@ package body FLTK.Widgets.Menus is Place : in Index) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_menu_text2 + Result : constant Interfaces.C.Strings.chars_ptr := fl_menu_text2 (This.Void_Ptr, Interfaces.C.int (Place) - 1); begin @@ -1177,7 +1181,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; @@ -1186,7 +1190,7 @@ package body FLTK.Widgets.Menus is Place : in Index) return Menu_Flag is begin - return Menu_Flag (fl_menu_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1)); + return Cint_To_MFlag (fl_menu_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1)); end Get_Flags; @@ -1198,7 +1202,7 @@ package body FLTK.Widgets.Menus is fl_menu_set_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1, - Interfaces.C.int (Flags)); + MFlag_To_Cint (Flags)); end Set_Flags; @@ -1226,7 +1230,7 @@ package body FLTK.Widgets.Menus is (This : in Menu) return Font_Kind is - Result : Interfaces.C.int := fl_menu_get_textfont (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_menu_get_textfont (This.Void_Ptr); begin return Font_Kind'Val (Result); exception @@ -1248,7 +1252,7 @@ package body FLTK.Widgets.Menus is (This : in Menu) return Font_Size is - Result : Interfaces.C.int := fl_menu_get_textsize (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_menu_get_textsize (This.Void_Ptr); begin return Font_Size (Result); exception @@ -1274,7 +1278,7 @@ package body FLTK.Widgets.Menus is (This : in Menu) return Box_Kind is - Result : Interfaces.C.int := fl_menu_get_down_box (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_menu_get_down_box (This.Void_Ptr); begin return Box_Kind'Val (Result); exception @@ -1323,7 +1327,7 @@ package body FLTK.Widgets.Menus is return Extended_Index is C_Title : aliased Interfaces.C.char_array := Interfaces.C.To_C (Title); - Ptr : Storage.Integer_Address := fl_menu_popup + Ptr : constant Storage.Integer_Address := fl_menu_popup (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y), @@ -1342,7 +1346,7 @@ package body FLTK.Widgets.Menus is Initial : in Extended_Index := No_Index) return Extended_Index is - Ptr : Storage.Integer_Address := fl_menu_pulldown + Ptr : constant Storage.Integer_Address := fl_menu_pulldown (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y), @@ -1371,7 +1375,7 @@ package body FLTK.Widgets.Menus is Require_Alt : in Boolean := False) return access FLTK.Menu_Items.Menu_Item'Class is - Tentative_Result : Storage.Integer_Address := fl_menu_find_shortcut + Tentative_Result : constant Storage.Integer_Address := fl_menu_find_shortcut (This.Void_Ptr, Null_Pointer, Boolean'Pos (Require_Alt)); @@ -1392,7 +1396,7 @@ package body FLTK.Widgets.Menus is return access FLTK.Menu_Items.Menu_Item'Class is C_Place : Interfaces.C.int; - Tentative_Result : Storage.Integer_Address := fl_menu_find_shortcut + Tentative_Result : constant Storage.Integer_Address := fl_menu_find_shortcut (This.Void_Ptr, Storage.To_Integer (C_Place'Address), Boolean'Pos (Require_Alt)); @@ -1412,7 +1416,7 @@ package body FLTK.Widgets.Menus is (This : in out Menu) return access FLTK.Menu_Items.Menu_Item'Class is - Tentative_Pick : Storage.Integer_Address := fl_menu_test_shortcut (This.Void_Ptr); + Tentative_Pick : constant Storage.Integer_Address := fl_menu_test_shortcut (This.Void_Ptr); begin if Tentative_Pick = Null_Pointer then return null; diff --git a/body/fltk-widgets-positioners.adb b/body/fltk-widgets-positioners.adb index 91e948e..29246cd 100644 --- a/body/fltk-widgets-positioners.adb +++ b/body/fltk-widgets-positioners.adb @@ -289,7 +289,7 @@ package body FLTK.Widgets.Positioners is (This : in out Positioner; X, Y : in Long_Float) is - Result : Interfaces.C.int := fl_positioner_set_value + Result : constant Interfaces.C.int := fl_positioner_set_value (This.Void_Ptr, Interfaces.C.double (X), Interfaces.C.double (Y)); @@ -307,7 +307,7 @@ package body FLTK.Widgets.Positioners is X, Y : in Long_Float) return Boolean is - Result : Interfaces.C.int := fl_positioner_set_value + Result : constant Interfaces.C.int := fl_positioner_set_value (This.Void_Ptr, Interfaces.C.double (X), Interfaces.C.double (Y)); @@ -387,7 +387,7 @@ package body FLTK.Widgets.Positioners is (This : in out Positioner; Value : in Long_Float) is - Result : Interfaces.C.int := fl_positioner_set_xvalue + Result : constant Interfaces.C.int := fl_positioner_set_xvalue (This.Void_Ptr, Interfaces.C.double (Value)); begin @@ -404,7 +404,7 @@ package body FLTK.Widgets.Positioners is Value : in Long_Float) return Boolean is - Result : Interfaces.C.int := fl_positioner_set_xvalue + Result : constant Interfaces.C.int := fl_positioner_set_xvalue (This.Void_Ptr, Interfaces.C.double (Value)); begin @@ -483,7 +483,7 @@ package body FLTK.Widgets.Positioners is (This : in out Positioner; Value : in Long_Float) is - Result : Interfaces.C.int := fl_positioner_set_yvalue + Result : constant Interfaces.C.int := fl_positioner_set_yvalue (This.Void_Ptr, Interfaces.C.double (Value)); begin @@ -500,7 +500,7 @@ package body FLTK.Widgets.Positioners is Value : in Long_Float) return Boolean is - Result : Interfaces.C.int := fl_positioner_set_yvalue + Result : constant Interfaces.C.int := fl_positioner_set_yvalue (This.Void_Ptr, Interfaces.C.double (Value)); begin @@ -551,7 +551,7 @@ package body FLTK.Widgets.Positioners is X, Y, W, H : in Integer) return Event_Outcome is - Result : Interfaces.C.int := fl_positioner_handle2 + Result : constant Interfaces.C.int := fl_positioner_handle2 (This.Void_Ptr, Event_Kind'Pos (Event), Interfaces.C.int (X), diff --git a/body/fltk-widgets-progress_bars.adb b/body/fltk-widgets-progress_bars.adb index 8dc24ee..d04c275 100644 --- a/body/fltk-widgets-progress_bars.adb +++ b/body/fltk-widgets-progress_bars.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Progress_Bars is diff --git a/body/fltk-widgets-valuators-adjusters.adb b/body/fltk-widgets-valuators-adjusters.adb index 2ffad15..d740da5 100644 --- a/body/fltk-widgets-valuators-adjusters.adb +++ b/body/fltk-widgets-valuators-adjusters.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; use type diff --git a/body/fltk-widgets-valuators-counters-simple.adb b/body/fltk-widgets-valuators-counters-simple.adb index 9f41321..cd9a8f4 100644 --- a/body/fltk-widgets-valuators-counters-simple.adb +++ b/body/fltk-widgets-valuators-counters-simple.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Valuators.Counters.Simple is diff --git a/body/fltk-widgets-valuators-counters.adb b/body/fltk-widgets-valuators-counters.adb index 1c5426f..f05df69 100644 --- a/body/fltk-widgets-valuators-counters.adb +++ b/body/fltk-widgets-valuators-counters.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Valuators.Counters is @@ -331,7 +330,7 @@ package body FLTK.Widgets.Valuators.Counters is (This : in out Counter) return Counter_Kind is - Result : Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); begin return Counter_Kind'Val (Result); exception diff --git a/body/fltk-widgets-valuators-dials-fill.adb b/body/fltk-widgets-valuators-dials-fill.adb index 44f87fe..a1d1066 100644 --- a/body/fltk-widgets-valuators-dials-fill.adb +++ b/body/fltk-widgets-valuators-dials-fill.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Valuators.Dials.Fill is diff --git a/body/fltk-widgets-valuators-dials-line.adb b/body/fltk-widgets-valuators-dials-line.adb index 707b85d..8f6914c 100644 --- a/body/fltk-widgets-valuators-dials-line.adb +++ b/body/fltk-widgets-valuators-dials-line.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Valuators.Dials.Line is diff --git a/body/fltk-widgets-valuators-dials.adb b/body/fltk-widgets-valuators-dials.adb index 9e2d885..43d943f 100644 --- a/body/fltk-widgets-valuators-dials.adb +++ b/body/fltk-widgets-valuators-dials.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Valuators.Dials is @@ -284,7 +283,7 @@ package body FLTK.Widgets.Valuators.Dials is X, Y, W, H : in Integer) return Event_Outcome is - Result : Interfaces.C.int := fl_dial_handle2 + Result : constant Interfaces.C.int := fl_dial_handle2 (This.Void_Ptr, Event_Kind'Pos (Event), Interfaces.C.int (X), @@ -308,7 +307,7 @@ package body FLTK.Widgets.Valuators.Dials is (This : in Dial) return Dial_Kind is - Result : Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); begin return Dial_Kind'Val (Result); exception diff --git a/body/fltk-widgets-valuators-rollers.adb b/body/fltk-widgets-valuators-rollers.adb index c04e274..45939fb 100644 --- a/body/fltk-widgets-valuators-rollers.adb +++ b/body/fltk-widgets-valuators-rollers.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Valuators.Rollers is diff --git a/body/fltk-widgets-valuators-sliders-fill.adb b/body/fltk-widgets-valuators-sliders-fill.adb index 2cb4c18..c9b0d82 100644 --- a/body/fltk-widgets-valuators-sliders-fill.adb +++ b/body/fltk-widgets-valuators-sliders-fill.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Valuators.Sliders.Fill is diff --git a/body/fltk-widgets-valuators-sliders-horizontal.adb b/body/fltk-widgets-valuators-sliders-horizontal.adb index c774a3b..1fb5114 100644 --- a/body/fltk-widgets-valuators-sliders-horizontal.adb +++ b/body/fltk-widgets-valuators-sliders-horizontal.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Valuators.Sliders.Horizontal is diff --git a/body/fltk-widgets-valuators-sliders-horizontal_fill.adb b/body/fltk-widgets-valuators-sliders-horizontal_fill.adb index 6a91d4b..2ecf088 100644 --- a/body/fltk-widgets-valuators-sliders-horizontal_fill.adb +++ b/body/fltk-widgets-valuators-sliders-horizontal_fill.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Valuators.Sliders.Horizontal_Fill is diff --git a/body/fltk-widgets-valuators-sliders-horizontal_nice.adb b/body/fltk-widgets-valuators-sliders-horizontal_nice.adb index e12113a..5efb3ca 100644 --- a/body/fltk-widgets-valuators-sliders-horizontal_nice.adb +++ b/body/fltk-widgets-valuators-sliders-horizontal_nice.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Valuators.Sliders.Horizontal_Nice is diff --git a/body/fltk-widgets-valuators-sliders-nice.adb b/body/fltk-widgets-valuators-sliders-nice.adb index 995a585..4b24754 100644 --- a/body/fltk-widgets-valuators-sliders-nice.adb +++ b/body/fltk-widgets-valuators-sliders-nice.adb @@ -6,8 +6,7 @@ with - FLTK.Widgets.Groups, - Interfaces.C.Strings; + FLTK.Widgets.Groups; package body FLTK.Widgets.Valuators.Sliders.Nice is diff --git a/body/fltk-widgets-valuators-sliders-scrollbars.adb b/body/fltk-widgets-valuators-sliders-scrollbars.adb index f08ccaf..660970a 100644 --- a/body/fltk-widgets-valuators-sliders-scrollbars.adb +++ b/body/fltk-widgets-valuators-sliders-scrollbars.adb @@ -90,22 +90,6 @@ package body FLTK.Widgets.Valuators.Sliders.Scrollbars is -- Destructors -- ------------------- - -- End of the line - procedure scrollbar_extra_final_hook - (Ada_Obj : in Storage.Integer_Address); - pragma Export (C, scrollbar_extra_final_hook, "scrollbar_extra_final_hook"); - - procedure scrollbar_extra_final_hook - (Ada_Obj : in Storage.Integer_Address) - is - My_Scrollbar : Scrollbar; - for My_Scrollbar'Address use Storage.To_Address (Ada_Obj); - pragma Import (Ada, My_Scrollbar); - begin - Extra_Final (My_Scrollbar); - end scrollbar_extra_final_hook; - - procedure Extra_Final (This : in out Scrollbar) is begin diff --git a/body/fltk-widgets-valuators-sliders-value-horizontal.adb b/body/fltk-widgets-valuators-sliders-value-horizontal.adb index a126b4c..9e3d946 100644 --- a/body/fltk-widgets-valuators-sliders-value-horizontal.adb +++ b/body/fltk-widgets-valuators-sliders-value-horizontal.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Valuators.Sliders.Value.Horizontal is diff --git a/body/fltk-widgets-valuators-sliders-value.adb b/body/fltk-widgets-valuators-sliders-value.adb index 17e9591..28a932e 100644 --- a/body/fltk-widgets-valuators-sliders-value.adb +++ b/body/fltk-widgets-valuators-sliders-value.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Valuators.Sliders.Value is diff --git a/body/fltk-widgets-valuators-sliders.adb b/body/fltk-widgets-valuators-sliders.adb index 00153dc..b670ba2 100644 --- a/body/fltk-widgets-valuators-sliders.adb +++ b/body/fltk-widgets-valuators-sliders.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; package body FLTK.Widgets.Valuators.Sliders is @@ -367,7 +367,7 @@ package body FLTK.Widgets.Valuators.Sliders is (This : in Slider) return Slider_Kind is - Result : Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); begin return Slider_Kind'Val (Result); exception diff --git a/body/fltk-widgets-valuators-value_inputs.adb b/body/fltk-widgets-valuators-value_inputs.adb index 929d117..1909c1c 100644 --- a/body/fltk-widgets-valuators-value_inputs.adb +++ b/body/fltk-widgets-valuators-value_inputs.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; use type @@ -173,17 +173,9 @@ package body FLTK.Widgets.Valuators.Value_Inputs is -- Destructors -- ------------------- - -- Making a long distance telephone call - procedure fl_text_input_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_text_input_extra_final, "fl_text_input_extra_final"); - pragma Inline (fl_text_input_extra_final); - - procedure Extra_Final (This : in out Value_Input) is begin - fl_text_input_extra_final (Storage.To_Integer (This.My_Input'Address)); Extra_Final (Valuator (This)); end Extra_Final; @@ -317,7 +309,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-widgets-valuators-value_outputs.adb b/body/fltk-widgets-valuators-value_outputs.adb index 471e58d..82259a6 100644 --- a/body/fltk-widgets-valuators-value_outputs.adb +++ b/body/fltk-widgets-valuators-value_outputs.adb @@ -7,7 +7,7 @@ with FLTK.Widgets.Groups, - Interfaces.C.Strings; + Interfaces.C; use type diff --git a/body/fltk-widgets-valuators.adb b/body/fltk-widgets-valuators.adb index 69aa150..c762fe4 100644 --- a/body/fltk-widgets-valuators.adb +++ b/body/fltk-widgets-valuators.adb @@ -210,7 +210,7 @@ package body FLTK.Widgets.Valuators is declare -- God this whole Format method is sketchy as hell. -- ...what? This is the area to declare things and that needed declaring. - String_Result : String := Ada_Obj.Format; + String_Result : constant String := Ada_Obj.Format; begin if String_Result'Length <= FLTK.Buffer_Size then Interfaces.C.Strings.Update (Buffer, 0, Interfaces.C.To_C (String_Result), False); @@ -321,7 +321,7 @@ package body FLTK.Widgets.Valuators is is Buffer : Interfaces.C.char_array := (1 .. Interfaces.C.size_t (FLTK.Buffer_Size) => Interfaces.C.To_C (Character'Val (0))); - Result : Interfaces.C.int := fl_valuator_format (This.Void_Ptr, Buffer); + Result : constant Interfaces.C.int := fl_valuator_format (This.Void_Ptr, Buffer); begin return Interfaces.C.To_Ada (Buffer (1 .. Interfaces.C.size_t (Result)), False); end Format; diff --git a/body/fltk-widgets.adb b/body/fltk-widgets.adb index 8bc5c86..f4409e4 100644 --- a/body/fltk-widgets.adb +++ b/body/fltk-widgets.adb @@ -8,9 +8,7 @@ with Ada.Assertions, Interfaces.C.Strings, - System.Address_To_Access_Conversions, - FLTK.Widgets.Groups.Windows, - FLTK.Images; + FLTK.Widgets.Groups.Windows; use type @@ -26,33 +24,6 @@ package body FLTK.Widgets is package Chk renames Ada.Assertions; - function "+" - (Left, Right : in Callback_Flag) - return Callback_Flag is - begin - return - (Changed => Left.Changed or Right.Changed, - Interact => Left.Interact or Right.Interact, - Release => Left.Release or Right.Release, - Enter_Key => Left.Enter_Key or Right.Enter_Key); - end "+"; - - - function "+" - (Left, Right : in Damage_Mask) - return Damage_Mask is - begin - return - (Child => Left.Child or Right.Child, - Expose => Left.Expose or Right.Expose, - Scroll => Left.Scroll or Right.Scroll, - Overlay => Left.Overlay or Right.Overlay, - User_1 => Left.User_1 or Right.User_1, - User_2 => Left.User_2 or Right.User_2, - Full => Left.Full or Right.Full); - end "+"; - - package Group_Convert is new System.Address_To_Access_Conversions (FLTK.Widgets.Groups.Group'Class); @@ -628,7 +599,7 @@ package body FLTK.Widgets is procedure Callback_Hook (W, U : in Storage.Integer_Address) is - Ada_Widget : access Widget'Class := + Ada_Widget : constant access Widget'Class := Widget_Convert.To_Pointer (Storage.To_Address (U)); begin Ada_Widget.Callback.all (Ada_Widget.all); @@ -638,7 +609,7 @@ package body FLTK.Widgets is procedure Draw_Hook (U : in Storage.Integer_Address) is - Ada_Widget : access Widget'Class := + Ada_Widget : constant access Widget'Class := Widget_Convert.To_Pointer (Storage.To_Address (U)); begin Ada_Widget.Draw; @@ -650,7 +621,7 @@ package body FLTK.Widgets is E : in Interfaces.C.int) return Interfaces.C.int is - Ada_Widget : access Widget'Class := + Ada_Widget : constant access Widget'Class := Widget_Convert.To_Pointer (Storage.To_Address (U)); begin return Event_Outcome'Pos (Ada_Widget.Handle (Event_Kind'Val (E))); @@ -666,10 +637,13 @@ package body FLTK.Widgets is procedure Extra_Final (This : in out Widget) is - Maybe_Parent : access FLTK.Widgets.Groups.Group'Class := This.Parent; + Maybe_Parent : access FLTK.Widgets.Groups.Group'Class; begin - if Maybe_Parent /= null then - Maybe_Parent.Remove (This); + if This.Needs_Dealloc then + Maybe_Parent := This.Parent; + if Maybe_Parent /= null then + Maybe_Parent.Remove (This); + end if; end if; end Extra_Final; @@ -1050,13 +1024,13 @@ package body FLTK.Widgets is begin if Parent_Ptr /= Null_Pointer then Parent_Ptr := fl_widget_get_user_data (Parent_Ptr); - pragma Assert (Parent_Ptr /= Null_Pointer); + -- Can't assert user data being not null here because fl_ask is a bitch, + -- so have to fall back on saying that if it's null then you get nothing. + -- Any widget created by users of this binding will have appropriate back + -- reference to the corresponding Ada object in the user data anyway. Actual_Parent := Group_Convert.To_Pointer (Storage.To_Address (Parent_Ptr)); end if; return Actual_Parent; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Widget returned by Fl_Widget::parent has no user_data reference back to Ada"; end Parent; @@ -1163,7 +1137,7 @@ package body FLTK.Widgets is (This : in Widget) return Box_Kind is - Result : Interfaces.C.int := fl_widget_get_box (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_widget_get_box (This.Void_Ptr); begin return Box_Kind'Val (Result); exception @@ -1185,7 +1159,7 @@ package body FLTK.Widgets is (This : in Widget) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_widget_tooltip (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_widget_tooltip (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1212,7 +1186,7 @@ package body FLTK.Widgets is (This : in Widget) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_widget_get_label (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_widget_get_label (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1292,7 +1266,7 @@ package body FLTK.Widgets is (This : in Widget) return Label_Kind is - Result : Interfaces.C.int := fl_widget_get_labeltype (This.Void_Ptr); + Result : constant Interfaces.C.int := fl_widget_get_labeltype (This.Void_Ptr); begin return Label_Kind'Val (Result); exception @@ -1690,7 +1664,7 @@ package body FLTK.Widgets is for my_handle'Address use This.Handle_Ptr; pragma Import (Ada, my_handle); - Result : Interfaces.C.int := my_handle (This.Void_Ptr, Event_Kind'Pos (Event)); + Result : constant Interfaces.C.int := my_handle (This.Void_Ptr, Event_Kind'Pos (Event)); begin return Event_Outcome'Val (Result); exception diff --git a/body/fltk.adb b/body/fltk.adb index 4dfdf8f..49d9048 100644 --- a/body/fltk.adb +++ b/body/fltk.adb @@ -11,33 +11,148 @@ with use type Interfaces.C.int, - Interfaces.C.unsigned_long; + Interfaces.C.unsigned, + Interfaces.C.unsigned_char; package body FLTK is ------------------------ + -- Constants From C -- + ------------------------ + + -- Color -- + + fl_enum_num_red : constant Interfaces.C.int; + 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, "fl_enum_num_green"); + + fl_enum_num_blue : constant Interfaces.C.int; + 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, "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"); + + + + + ------------------------ -- Functions From C -- ------------------------ -- Enumerations.H -- + -- Color -- + + function fl_enum_rgb_color2 + (L : in Interfaces.C.unsigned_char) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_rgb_color2, "fl_enum_rgb_color2"); + pragma Inline (fl_enum_rgb_color2); + function fl_enum_rgb_color (R, G, B : in Interfaces.C.unsigned_char) return Interfaces.C.unsigned; pragma Import (C, fl_enum_rgb_color, "fl_enum_rgb_color"); pragma Inline (fl_enum_rgb_color); + function fl_enum_color_cube + (R, G, B : in Interfaces.C.int) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_color_cube, "fl_enum_color_cube"); + pragma Inline (fl_enum_color_cube); + + function fl_enum_gray_ramp + (L : in Interfaces.C.int) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_gray_ramp, "fl_enum_gray_ramp"); + pragma Inline (fl_enum_gray_ramp); + + function fl_enum_darker + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_darker, "fl_enum_darker"); + pragma Inline (fl_enum_darker); + + function fl_enum_lighter + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_lighter, "fl_enum_lighter"); + pragma Inline (fl_enum_lighter); + function fl_enum_contrast (F, B : in Interfaces.C.unsigned) return Interfaces.C.unsigned; pragma Import (C, fl_enum_contrast, "fl_enum_contrast"); pragma Inline (fl_enum_contrast); + function fl_enum_inactive + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_inactive, "fl_enum_inactive"); + pragma Inline (fl_enum_inactive); + + function fl_enum_color_average + (T1, T2 : in Interfaces.C.unsigned; + W : in Interfaces.C.C_float) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_color_average, "fl_enum_color_average"); + pragma Inline (fl_enum_color_average); + + + + + -- Box Types -- + + function fl_enum_box + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_enum_box, "fl_enum_box"); + pragma Inline (fl_enum_box); + + function fl_enum_frame + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_enum_frame, "fl_enum_frame"); + pragma Inline (fl_enum_frame); + + function fl_enum_down + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_enum_down, "fl_enum_down"); + pragma Inline (fl_enum_down); + + -- Fl.H -- + -- Versioning -- function fl_abi_check @@ -64,21 +179,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 @@ -98,7 +198,7 @@ package body FLTK is function fl_wait2 (S : in Interfaces.C.double) - return Interfaces.C.int; + return Interfaces.C.double; pragma Import (C, fl_wait2, "fl_wait2"); pragma Inline (fl_wait2); @@ -129,6 +229,26 @@ package body FLTK is -- Color -- function RGB_Color + (Light : in Greyscale) + return Color is + begin + case Light is + when 'A' .. 'W' => return Color (fl_enum_rgb_color2 + ((Greyscale'Pos (Light) - Greyscale'Pos (Greyscale'First)) * 11)); + when 'X' => return Color (fl_enum_rgb_color2 (255)); + end case; + end RGB_Color; + + + function RGB_Color + (Light : in Color_Component) + return Color is + begin + return Color (fl_enum_rgb_color2 (Interfaces.C.unsigned_char (Light))); + end RGB_Color; + + + function RGB_Color (R, G, B : in Color_Component) return Color is begin @@ -139,6 +259,50 @@ package body FLTK is end RGB_Color; + function Color_Cube + (R, G, B : in Color_Component) + return Color is + begin + return Color (fl_enum_color_cube + (Interfaces.C.int (Float'Rounding (Float (R) * Float (fl_enum_num_red - 1) / 255.0)), + Interfaces.C.int (Float'Rounding (Float (G) * Float (fl_enum_num_green - 1) / 255.0)), + Interfaces.C.int (Float'Rounding (Float (B) * Float (fl_enum_num_blue - 1) / 255.0)))); + end Color_Cube; + + + function Grey_Ramp + (Light : in Greyscale) + return Color is + begin + return Color (fl_enum_gray_ramp (Greyscale'Pos (Light) - Greyscale'Pos (Greyscale'First))); + end Grey_Ramp; + + + function Grey_Ramp + (Light : in Color_Component) + return Color is + begin + return Color (fl_enum_gray_ramp (Interfaces.C.int + (Float'Rounding (Float (Light) * Float (fl_enum_num_gray - 1) / 255.0)))); + end Grey_Ramp; + + + function Darker + (Tone : in Color) + return Color is + begin + return Color (fl_enum_darker (Interfaces.C.unsigned (Tone))); + end Darker; + + + function Lighter + (Tone : in Color) + return Color is + begin + return Color (fl_enum_lighter (Interfaces.C.unsigned (Tone))); + end Lighter; + + function Contrast (Fore, Back : in Color) return Color is @@ -149,6 +313,26 @@ package body FLTK is end Contrast; + function Inactive + (Tone : in Color) + return Color is + begin + return Color (fl_enum_inactive (Interfaces.C.unsigned (Tone))); + end Inactive; + + + function Color_Average + (Tone1, Tone2 : in Color; + Weight : in Blend := 0.5) + return Color is + begin + return Color (fl_enum_color_average + (Interfaces.C.unsigned (Tone1), + Interfaces.C.unsigned (Tone2), + Interfaces.C.C_float (Weight))); + end Color_Average; + + -- Alignment -- @@ -165,7 +349,7 @@ package body FLTK is (Left, Right : in Alignment) return Alignment is begin - return Left and (not Right); + return Left and not Right; end "-"; @@ -283,14 +467,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 @@ -303,14 +487,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); @@ -319,14 +503,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); @@ -335,42 +519,177 @@ 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; + -- Box Types -- + + function Filled + (Box : in Box_Kind) + return Box_Kind + is + Result : constant Interfaces.C.int := fl_enum_box (Box_Kind'Pos (Box)); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_box in Enumerations.H returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Filled; + + + function Frame + (Box : in Box_Kind) + return Box_Kind + is + Result : constant Interfaces.C.int := fl_enum_frame (Box_Kind'Pos (Box)); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_frame in Enumerations.H returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Frame; + + + function Down + (Box : in Box_Kind) + return Box_Kind + is + Result : constant Interfaces.C.int := fl_enum_down (Box_Kind'Pos (Box)); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_down in Enumerations.H returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Down; + + + + + -- Callback Flags -- + + type Callback_Bitmask is mod 2 ** Interfaces.C.unsigned_char'Size; + + function CFlag_To_Bits is new + Ada.Unchecked_Conversion (Callback_Flag, Callback_Bitmask); + + function Bits_To_CFlag is new + Ada.Unchecked_Conversion (Callback_Bitmask, Callback_Flag); + + + function "+" + (Left, Right : in Callback_Flag) + return Callback_Flag is + begin + return Bits_To_CFlag (CFlag_To_Bits (Left) or CFlag_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in Callback_Flag) + return Callback_Flag is + begin + return Bits_To_CFlag (CFlag_To_Bits (Left) and not CFlag_To_Bits (Right)); + end "-"; + + + + -- Menu Flags -- + type Menu_Bitmask is mod 2 ** Interfaces.C.int'Size; + + function MFlag_To_Bits is new + Ada.Unchecked_Conversion (Menu_Flag, Menu_Bitmask); + + function Bits_To_MFlag is new + Ada.Unchecked_Conversion (Menu_Bitmask, Menu_Flag); + + function "+" (Left, Right : in Menu_Flag) return Menu_Flag is begin - return Left or Right; + return Bits_To_MFlag (MFlag_To_Bits (Left) or MFlag_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in Menu_Flag) + return Menu_Flag is + begin + return Bits_To_MFlag (MFlag_To_Bits (Left) and not MFlag_To_Bits (Right)); + end "-"; + + + + + -- Damage Bits -- + + type Damage_Bitmask is mod 2 ** Interfaces.C.unsigned_char'Size; + + function Damage_To_Bits is new + Ada.Unchecked_Conversion (Damage_Mask, Damage_Bitmask); + + function Bits_To_Damage is new + Ada.Unchecked_Conversion (Damage_Bitmask, Damage_Mask); + + + function "+" + (Left, Right : in Damage_Mask) + return Damage_Mask is + begin + return Bits_To_Damage (Damage_To_Bits (Left) or Damage_To_Bits (Right)); end "+"; + function "-" + (Left, Right : in Damage_Mask) + return Damage_Mask is + begin + return Bits_To_Damage (Damage_To_Bits (Left) and not Damage_To_Bits (Right)); + end "-"; + + -- Versioning -- @@ -406,26 +725,16 @@ 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 begin @@ -449,9 +758,9 @@ package body FLTK is function Wait (Seconds : in Long_Float) - return Integer is + return Long_Float is begin - return Integer (fl_wait2 (Interfaces.C.double (Seconds))); + return Long_Float (fl_wait2 (Interfaces.C.double (Seconds))); end Wait; |