diff options
382 files changed, 17970 insertions, 6143 deletions
diff --git a/body/c_fl.cpp b/body/c_fl.cpp index ec5f7e5..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,84 +52,174 @@ size_t c_pointer_size() { +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_rgb_color(unsigned char r, unsigned char g, unsigned char b) { - return fl_rgb_color(r, g, 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); +} + +int fl_abi_version() { + return Fl::abi_version(); } -void fl_set_damage(int v) { - Fl::damage(v); +int fl_api_version() { + return Fl::api_version(); } -void fl_flush() { - Fl::flush(); +double fl_version() { + return Fl::version(); } -void fl_redraw() { - Fl::redraw(); + + + +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 9f79979..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,7 +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); @@ -49,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_ask.cpp b/body/c_fl_ask.cpp index 20af2e3..30dd480 100644 --- a/body/c_fl_ask.cpp +++ b/body/c_fl_ask.cpp @@ -5,6 +5,7 @@ #include <FL/fl_ask.H> +#include <FL/fl_show_colormap.H> #include <FL/Fl_File_Chooser.H> #include <FL/Fl_Color_Chooser.H> #include "c_fl_ask.h" @@ -90,10 +91,16 @@ int fl_ask_color_chooser(const char * n, double & r, double & g, double & b, int return fl_color_chooser(n, r, g, b, m); } -int fl_ask_color_chooser2(const char * n, uchar & r, uchar & g, uchar & b, int m) { +int fl_ask_color_chooser2(const char * n, + unsigned char & r, unsigned char & g, unsigned char & b, int m) +{ return fl_color_chooser(n, r, g, b, m); } +unsigned int fl_ask_show_colormap(unsigned int h) { + return static_cast<unsigned int>(fl_show_colormap(static_cast<Fl_Color>(h))); +} + char * fl_ask_dir_chooser(const char * m, const char * d, int r) { return fl_dir_chooser(m, d, r); } diff --git a/body/c_fl_ask.h b/body/c_fl_ask.h index f68bc85..4c18391 100644 --- a/body/c_fl_ask.h +++ b/body/c_fl_ask.h @@ -30,7 +30,9 @@ extern "C" const char * fl_ask_password(const char * m, const char * d); extern "C" int fl_ask_color_chooser(const char * n, double & r, double & g, double & b, int m); -extern "C" int fl_ask_color_chooser2(const char * n, uchar & r, uchar & g, uchar & b, int m); +extern "C" int fl_ask_color_chooser2(const char * n, + unsigned char & r, unsigned char & g, unsigned char & b, int m); +extern "C" unsigned int fl_ask_show_colormap(unsigned int h); extern "C" char * fl_ask_dir_chooser(const char * m, const char * d, int r); extern "C" char * fl_ask_file_chooser(const char * m, const char * p, const char * d, int r); extern "C" void fl_ask_file_chooser_callback(void(*cb)(const char *)); diff --git a/body/c_fl_bitmap.cpp b/body/c_fl_bitmap.cpp index 01077b2..a54b579 100644 --- a/body/c_fl_bitmap.cpp +++ b/body/c_fl_bitmap.cpp @@ -39,6 +39,13 @@ void fl_bitmap_uncache(BITMAP b) { +const void * fl_bitmap_data(BITMAP b) { + return static_cast<const void*>(static_cast<Fl_Bitmap*>(b)->array); +} + + + + void fl_bitmap_draw2(BITMAP b, int x, int y) { static_cast<Fl_Bitmap*>(b)->draw(x, y); } diff --git a/body/c_fl_bitmap.h b/body/c_fl_bitmap.h index f5f6e15..088486c 100644 --- a/body/c_fl_bitmap.h +++ b/body/c_fl_bitmap.h @@ -20,6 +20,9 @@ extern "C" BITMAP fl_bitmap_copy2(BITMAP b); extern "C" void fl_bitmap_uncache(BITMAP b); +extern "C" const void * fl_bitmap_data(BITMAP b); + + extern "C" void fl_bitmap_draw2(BITMAP b, int x, int y); extern "C" void fl_bitmap_draw(BITMAP b, int x, int y, int w, int h, int cx, int cy); 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_draw.cpp b/body/c_fl_draw.cpp index 488a73f..25d7796 100644 --- a/body/c_fl_draw.cpp +++ b/body/c_fl_draw.cpp @@ -216,6 +216,10 @@ void fl_draw_draw_image_mono2(void * func, void * data, int x, int y, int w, int fl_draw_image_mono(reinterpret_cast<Fl_Draw_Image_Cb>(func), data, x, y, w, h, d); } +int fl_draw_draw_pixmap(void * data, int x, int y, unsigned int h) { + return fl_draw_pixmap(static_cast<char * const *>(data), x, y, static_cast<Fl_Color>(h)); +} + void * fl_draw_read_image(void * data, int x, int y, int w, int h, int alpha) { return fl_read_image(static_cast<uchar*>(data), x, y, w, h, alpha); } @@ -260,8 +264,8 @@ void fl_draw_draw_box(int bk, int x, int y, int w, int h, unsigned int c) { fl_draw_box((Fl_Boxtype)bk, x, y, w, h, (Fl_Color)c); } -void fl_draw_draw_symbol(const char *label, int x, int y, int w, int h, unsigned int c) { - fl_draw_symbol(label, x, y, w, h, (Fl_Color)c); +int fl_draw_draw_symbol(const char *label, int x, int y, int w, int h, unsigned int c) { + return fl_draw_symbol(label, x, y, w, h, (Fl_Color)c); } void fl_draw_measure(const char * str, int &w, int &h, int draw_symbols) { @@ -280,6 +284,12 @@ void fl_draw_text_extents(const char * t, int n, int &dx, int &dy, int &w, int & fl_text_extents(t, n, dx, dy, w, h); } +const char * fl_draw_expand_text(const char * str, char * &buf, int maxbuf, + double maxw, int &n, double &width, int wrap, int symbol) +{ + return fl_expand_text(str, buf, maxbuf, maxw, n, width, wrap, symbol); +} + double fl_draw_width(const char *txt, int n) { return fl_width(txt, n); } diff --git a/body/c_fl_draw.h b/body/c_fl_draw.h index d719903..cd1a16d 100644 --- a/body/c_fl_draw.h +++ b/body/c_fl_draw.h @@ -68,6 +68,7 @@ extern "C" void fl_draw_draw_image(void * data, int x, int y, int w, int h, int extern "C" void fl_draw_draw_image2(void * func, void * data, int x, int y, int w, int h, int d); extern "C" void fl_draw_draw_image_mono(void * data, int x, int y, int w, int h, int d, int l); extern "C" void fl_draw_draw_image_mono2(void * func, void * data, int x, int y, int w, int h, int d); +extern "C" int fl_draw_draw_pixmap(void * data, int x, int y, unsigned int h); extern "C" void * fl_draw_read_image(void * data, int x, int y, int w, int h, int alpha); @@ -80,11 +81,13 @@ extern "C" void fl_draw_draw_text3(const char *str, int x, int y, int w, int h, extern "C" void fl_draw_draw_text4(int angle, const char *str, int n, int x, int y); extern "C" void fl_draw_rtl_draw(const char *str, int n, int x, int y); extern "C" void fl_draw_draw_box(int bk, int x, int y, int w, int h, unsigned int c); -extern "C" void fl_draw_draw_symbol(const char *label, int x, int y, int w, int h, unsigned int c); +extern "C" int fl_draw_draw_symbol(const char *label, int x, int y, int w, int h, unsigned int c); extern "C" void fl_draw_measure(const char * str, int &w, int &h, int draw_symbols); extern "C" void fl_draw_scroll(int x, int y, int w, int h, int dx, int dy, void * func, void * data); extern "C" void fl_draw_text_extents(const char * t, int n, int &dx, int &dy, int &w, int &h); +extern "C" const char * fl_draw_expand_text(const char * str, char * &buf, int maxbuf, + double maxw, int &n, double &width, int wrap, int symbol); extern "C" double fl_draw_width(const char *txt, int n); extern "C" double fl_draw_width2(unsigned long c); 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_image.cpp b/body/c_fl_image.cpp index 328c187..cf24c59 100644 --- a/body/c_fl_image.cpp +++ b/body/c_fl_image.cpp @@ -10,22 +10,34 @@ -class My_Image : public Fl_Image { - public: - using Fl_Image::Fl_Image; - friend void fl_image_draw_empty(IMAGE i, int x, int y); +// Enums, macros, and constants + +const int fl_image_err_no_image = Fl_Image::ERR_NO_IMAGE; +const int fl_image_err_file_access = Fl_Image::ERR_FILE_ACCESS; +const int fl_image_err_format = Fl_Image::ERR_FORMAT; + + + + +// Non-friend protected access + +class Friend_Image : Fl_Image { +public: + using Fl_Image::draw_empty; }; +// Flattened C API + IMAGE new_fl_image(int w, int h, int d) { - My_Image *i = new My_Image(w, h, d); + Fl_Image *i = new Fl_Image(w, h, d); return i; } void free_fl_image(IMAGE i) { - delete static_cast<My_Image*>(i); + delete static_cast<Fl_Image*>(i); } @@ -69,16 +81,7 @@ void fl_image_inactive(IMAGE i) { } int fl_image_fail(IMAGE i) { - switch (static_cast<Fl_Image*>(i)->fail()) { - case Fl_Image::ERR_NO_IMAGE: - return 1; - case Fl_Image::ERR_FILE_ACCESS: - return 2; - case Fl_Image::ERR_FORMAT: - return 3; - default: - return 0; - } + return static_cast<Fl_Image*>(i)->fail(); } void fl_image_uncache(IMAGE i) { @@ -105,10 +108,6 @@ int fl_image_ld(IMAGE i) { return static_cast<Fl_Image*>(i)->ld(); } -int fl_image_count(IMAGE i) { - return static_cast<Fl_Image*>(i)->count(); -} - @@ -116,12 +115,8 @@ const void * fl_image_data(IMAGE i) { return static_cast<Fl_Image*>(i)->data(); } -char fl_image_get_pixel(char *c, int off) { - return c[off]; -} - -void fl_image_set_pixel(char *c, int off, char val) { - c[off] = val; +int fl_image_count(IMAGE i) { + return static_cast<Fl_Image*>(i)->count(); } @@ -137,6 +132,7 @@ void fl_image_draw2(IMAGE i, int x, int y, int w, int h, int cx, int cy) { } void fl_image_draw_empty(IMAGE i, int x, int y) { - static_cast<My_Image*>(i)->draw_empty(x, y); + (static_cast<Fl_Image*>(i)->*(&Friend_Image::draw_empty))(x, y); } + diff --git a/body/c_fl_image.h b/body/c_fl_image.h index ee96b7a..24ef65c 100644 --- a/body/c_fl_image.h +++ b/body/c_fl_image.h @@ -8,6 +8,11 @@ #define FL_IMAGE_GUARD +extern "C" const int fl_image_err_no_image; +extern "C" const int fl_image_err_file_access; +extern "C" const int fl_image_err_format; + + typedef void* IMAGE; @@ -34,12 +39,10 @@ extern "C" int fl_image_w(IMAGE i); extern "C" int fl_image_h(IMAGE i); extern "C" int fl_image_d(IMAGE i); extern "C" int fl_image_ld(IMAGE i); -extern "C" int fl_image_count(IMAGE i); extern "C" const void * fl_image_data(IMAGE i); -extern "C" char fl_image_get_pixel(char *c, int off); -extern "C" void fl_image_set_pixel(char *c, int off, char val); +extern "C" int fl_image_count(IMAGE i); extern "C" void fl_image_draw(IMAGE i, int x, int y); 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_pixmap.cpp b/body/c_fl_pixmap.cpp index 6ebcb56..14b5a74 100644 --- a/body/c_fl_pixmap.cpp +++ b/body/c_fl_pixmap.cpp @@ -10,10 +10,18 @@ +PIXMAP new_fl_pixmap(void * d) { + Fl_Pixmap *p = new Fl_Pixmap(static_cast<char**>(d)); + return p; +} + void free_fl_pixmap(PIXMAP b) { delete static_cast<Fl_Pixmap*>(b); } + + + PIXMAP fl_pixmap_copy(PIXMAP b, int w, int h) { // virtual so disable dispatch return static_cast<Fl_Pixmap*>(b)->Fl_Pixmap::copy(w, h); diff --git a/body/c_fl_pixmap.h b/body/c_fl_pixmap.h index ceba284..868a3a2 100644 --- a/body/c_fl_pixmap.h +++ b/body/c_fl_pixmap.h @@ -11,7 +11,10 @@ typedef void* PIXMAP; +extern "C" PIXMAP new_fl_pixmap(void * d); extern "C" void free_fl_pixmap(PIXMAP b); + + extern "C" PIXMAP fl_pixmap_copy(PIXMAP b, int w, int h); extern "C" PIXMAP fl_pixmap_copy2(PIXMAP b); diff --git a/body/c_fl_png_image.cpp b/body/c_fl_png_image.cpp index a4a6d71..ae77476 100644 --- a/body/c_fl_png_image.cpp +++ b/body/c_fl_png_image.cpp @@ -24,3 +24,4 @@ void free_fl_png_image(PNGIMAGE p) { delete static_cast<Fl_PNG_Image*>(p); } + diff --git a/body/c_fl_pnm_image.cpp b/body/c_fl_pnm_image.cpp index 1550998..e5f7f17 100644 --- a/body/c_fl_pnm_image.cpp +++ b/body/c_fl_pnm_image.cpp @@ -19,3 +19,4 @@ void free_fl_pnm_image(PNMIMAGE p) { delete static_cast<Fl_PNM_Image*>(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_rgb_image.cpp b/body/c_fl_rgb_image.cpp index 65afbf9..fc39594 100644 --- a/body/c_fl_rgb_image.cpp +++ b/body/c_fl_rgb_image.cpp @@ -66,6 +66,13 @@ void fl_rgb_image_uncache(RGBIMAGE i) { +const void * fl_rgb_image_data(RGBIMAGE i) { + return static_cast<const void*>(static_cast<Fl_RGB_Image*>(i)->array); +} + + + + void fl_rgb_image_draw2(RGBIMAGE i, int x, int y) { static_cast<Fl_RGB_Image*>(i)->draw(x, y); } diff --git a/body/c_fl_rgb_image.h b/body/c_fl_rgb_image.h index a09b58e..2d42993 100644 --- a/body/c_fl_rgb_image.h +++ b/body/c_fl_rgb_image.h @@ -27,6 +27,9 @@ extern "C" void fl_rgb_image_desaturate(RGBIMAGE i); extern "C" void fl_rgb_image_uncache(RGBIMAGE i); +extern "C" const void * fl_rgb_image_data(RGBIMAGE i); + + extern "C" void fl_rgb_image_draw2(RGBIMAGE i, int x, int y); extern "C" void fl_rgb_image_draw(RGBIMAGE i, int x, int y, int w, int h, int cx, int cy); 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 3707b52..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); -} - @@ -33,6 +29,16 @@ extern "C" int widget_handle_hook(void * ud, int e); +// Non-friend protected access + +class Friend_Scroll : Fl_Scroll { +public: + using Fl_Scroll::bbox; +}; + + + + // Attaching all relevant hooks and friends class My_Scroll : public Fl_Scroll { @@ -65,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); + } } @@ -108,6 +118,83 @@ void fl_scroll_set_size(SCROLL s, int t) { +void fl_scroll_resize(SCROLL s, int x, int y, int w, int h) { + static_cast<Fl_Scroll*>(s)->resize(x, y, w, h); +} + +void fl_scroll_recalc_scrollbars(SCROLL s, + int &cb_x, int &cb_y, int &cb_w, int &cb_h, + int &ib_x, int &ib_y, int &ib_w, int &ib_h, + int &ic_x, int &ic_y, int &ic_w, int &ic_h, + int &chneed, int &cvneed, + int &hs_x, int &hs_y, int &hs_w, int &hs_h, + int &hs_size, int &hs_total, int &hs_first, int &hs_pos, + int &vs_x, int &vs_y, int &vs_w, int &vs_h, + int &vs_size, int &vs_total, int &vs_first, int &vs_pos, + int &ssize) +{ +#if FLTK_ABI_VERSION >= 10303 + Fl_Scroll::ScrollInfo my_info; + static_cast<Fl_Scroll*>(s)->recalc_scrollbars(my_info); + + cb_x = my_info.child.l; + cb_y = my_info.child.t; + cb_w = my_info.child.r - my_info.child.l; + cb_h = my_info.child.b - my_info.child.t; + + ib_x = my_info.innerbox.x; + ib_y = my_info.innerbox.y; + ib_w = my_info.innerbox.w; + ib_h = my_info.innerbox.h; + + ic_x = my_info.innerchild.x; + ic_y = my_info.innerchild.y; + ic_w = my_info.innerchild.w; + ic_h = my_info.innerchild.h; + + chneed = my_info.hneeded; + cvneed = my_info.vneeded; + + hs_x = my_info.hscroll.x; + hs_y = my_info.hscroll.y; + hs_w = my_info.hscroll.w; + hs_h = my_info.hscroll.h; + hs_size = my_info.hscroll.size; + hs_total = my_info.hscroll.total; + hs_first = my_info.hscroll.first; + hs_pos = my_info.hscroll.pos; + + vs_x = my_info.vscroll.x; + vs_y = my_info.vscroll.y; + vs_w = my_info.vscroll.w; + vs_h = my_info.vscroll.h; + vs_size = my_info.vscroll.size; + vs_total = my_info.vscroll.total; + vs_first = my_info.vscroll.first; + vs_pos = my_info.vscroll.pos; + + ssize = my_info.scrollsize; +#else + (void)(s); + (void)(cb_x); (void)(cb_y); (void)(cb_w); (void)(cb_h); + (void)(ib_x); (void)(ib_y); (void)(ib_w); (void)(ib_h); + (void)(ic_x); (void)(ic_y); (void)(ic_w); (void)(ic_h); + (void)(chneed); (void)(cvneed); + (void)(hs_x); (void)(hs_y); (void)(hs_w); (void)(hs_h); + (void)(hs_size); (void)(hs_total); (void)(hs_first); (void)(hs_pos); + (void)(vs_x); (void)(vs_y); (void)(vs_w); (void)(vs_h); + (void)(vs_size); (void)(vs_total); (void)(vs_first); (void)(vs_pos); + (void)(ssize); +#endif +} + + + + +void fl_scroll_bbox(SCROLL s, int &x, int &y, int &w, int &h) { + (static_cast<Fl_Scroll*>(s)->*(&Friend_Scroll::bbox))(x, y, w, h); +} + void fl_scroll_draw(SCROLL s) { static_cast<My_Scroll*>(s)->Fl_Scroll::draw(); } diff --git a/body/c_fl_scroll.h b/body/c_fl_scroll.h index 60cf9a0..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; @@ -32,6 +31,20 @@ extern "C" int fl_scroll_get_size(SCROLL s); extern "C" void fl_scroll_set_size(SCROLL s, int t); +extern "C" void fl_scroll_resize(SCROLL s, int x, int y, int w, int h); +extern "C" void fl_scroll_recalc_scrollbars(SCROLL s, + int &cb_x, int &cb_y, int &cb_w, int &cb_h, + int &ib_x, int &ib_y, int &ib_w, int &ib_h, + int &ic_x, int &ic_y, int &ic_w, int &ic_h, + int &chneed, int &cvneed, + int &hs_x, int &hs_y, int &hs_w, int &hs_h, + int &hs_size, int &hs_total, int &hs_first, int &hs_pos, + int &vs_x, int &vs_y, int &vs_w, int &vs_h, + int &vs_size, int &vs_total, int &vs_first, int &vs_pos, + int &ssize); + + +extern "C" void fl_scroll_bbox(SCROLL s, int &x, int &y, int &w, int &h); extern "C" void fl_scroll_draw(SCROLL s); extern "C" int fl_scroll_handle(SCROLL s, int e); 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 b7b83e2..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); + } } @@ -199,7 +204,7 @@ void fl_table_do_callback(TABLE t, int x, int r, int c) { static_cast<Fl_Table*>(t)->do_callback(static_cast<Fl_Table::TableContext>(x), r, c); } -void fl_table_when(TABLE t, unsigned int w) { +void fl_table_when(TABLE t, unsigned char w) { static_cast<Fl_Table*>(t)->when(static_cast<Fl_When>(w)); } diff --git a/body/c_fl_table.h b/body/c_fl_table.h index a291301..d93ef4f 100644 --- a/body/c_fl_table.h +++ b/body/c_fl_table.h @@ -51,7 +51,7 @@ extern "C" int fl_table_callback_col(TABLE t); extern "C" int fl_table_callback_row(TABLE t); extern "C" int fl_table_callback_context(TABLE t); extern "C" void fl_table_do_callback(TABLE t, int x, int r, int c); -extern "C" void fl_table_when(TABLE t, unsigned int w); +extern "C" void fl_table_when(TABLE t, unsigned char w); extern "C" void fl_table_scroll_cb(void * s, 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 654d6ce..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" @@ -20,6 +21,58 @@ extern "C" int widget_handle_hook(void * ud, int e); +// Non-friend protected access + +class Friend_Text_Display : Fl_Text_Display { +public: + using Fl_Text_Display::buffer_modified_cb; + using Fl_Text_Display::buffer_predelete_cb; + + using Fl_Text_Display::find_line_end; + using Fl_Text_Display::find_x; + using Fl_Text_Display::position_to_line; + using Fl_Text_Display::position_to_linecol; + using Fl_Text_Display::xy_to_position; + using Fl_Text_Display::xy_to_rowcol; + + using Fl_Text_Display::wrap_uses_character; + using Fl_Text_Display::wrapped_line_counter; + + using Fl_Text_Display::calc_last_char; + using Fl_Text_Display::calc_line_starts; + using Fl_Text_Display::offset_line_starts; + + using Fl_Text_Display::absolute_top_line_number; + using Fl_Text_Display::get_absolute_top_line_number; + using Fl_Text_Display::maintain_absolute_top_line_number; + using Fl_Text_Display::maintaining_absolute_top_line_number; + using Fl_Text_Display::reset_absolute_top_line_number; + + using Fl_Text_Display::empty_vlines; + using Fl_Text_Display::longest_vline; + using Fl_Text_Display::vline_length; + + using Fl_Text_Display::measure_proportional_character; + using Fl_Text_Display::measure_vline; + using Fl_Text_Display::string_width; + + using Fl_Text_Display::scroll_; + using Fl_Text_Display::update_h_scrollbar; + using Fl_Text_Display::update_v_scrollbar; + + using Fl_Text_Display::clear_rect; + using Fl_Text_Display::display_insert; + using Fl_Text_Display::draw_cursor; + using Fl_Text_Display::draw_line_numbers; + using Fl_Text_Display::draw_range; + using Fl_Text_Display::draw_string; + using Fl_Text_Display::draw_text; + using Fl_Text_Display::draw_vline; +}; + + + + // Attaching all relevant hooks and friends class My_Text_Display : public Fl_Text_Display { @@ -52,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); + } } @@ -68,6 +125,16 @@ void fl_text_display_set_buffer(TEXTDISPLAY td, TEXTBUFFER tb) { static_cast<Fl_Text_Display*>(td)->buffer(static_cast<Fl_Text_Buffer*>(tb)); } +void fl_text_display_buffer_modified_cb(int p, int i, int d, int r, + const char * t, TEXTDISPLAY td) +{ + Friend_Text_Display::buffer_modified_cb(p, i, d, r, t, static_cast<Fl_Text_Display*>(td)); +} + +void fl_text_display_buffer_predelete_cb(int p, int d, TEXTDISPLAY td) { + Friend_Text_Display::buffer_predelete_cb(p, d, static_cast<Fl_Text_Display*>(td)); +} + @@ -87,6 +154,10 @@ void fl_text_display_highlight_data2(TEXTDISPLAY td, TEXTBUFFER tb, void * st, i len, us, reinterpret_cast<Fl_Text_Display::Unfinished_Style_Cb>(cb), a); } +int fl_text_display_position_style(TEXTDISPLAY td, int s, int l, int i) { + return static_cast<Fl_Text_Display*>(td)->position_style(s, l, i); +} + @@ -106,6 +177,32 @@ int fl_text_display_position_to_xy(TEXTDISPLAY td, int p, int * x, int * y) { return static_cast<Fl_Text_Display*>(td)->position_to_xy(p, x, y); } +void fl_text_display_find_line_end(TEXTDISPLAY td, int sp, int spils, int &le, int &nls) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::find_line_end)) + (sp, spils!=0, &le, &nls); +} + +int fl_text_display_find_x(TEXTDISPLAY td, const char * str, int l, int s, int x) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::find_x))(str, l, s, x); +} + +int fl_text_display_position_to_line(TEXTDISPLAY td, int p, int &ln) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::position_to_line))(p, &ln); +} + +int fl_text_display_position_to_linecol(TEXTDISPLAY td, int p, int &ln, int &c) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::position_to_linecol)) + (p, &ln, &c); +} + +int fl_text_display_xy_to_position(TEXTDISPLAY td, int x, int y, int k) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::xy_to_position))(x, y, k); +} + +void fl_text_display_xy_to_rowcol(TEXTDISPLAY td, int x, int y, int &r, int &c, int k) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::xy_to_rowcol))(x, y, &r, &c, k); +} + @@ -198,10 +295,34 @@ void fl_text_display_previous_word(TEXTDISPLAY td) { static_cast<Fl_Text_Display*>(td)->previous_word(); } + + + void fl_text_display_wrap_mode(TEXTDISPLAY td, int w, int m) { static_cast<Fl_Text_Display*>(td)->wrap_mode(w, m); } +int fl_text_display_wrapped_row(TEXTDISPLAY td, int r) { + return static_cast<Fl_Text_Display*>(td)->wrapped_row(r); +} + +int fl_text_display_wrapped_column(TEXTDISPLAY td, int r, int c) { + return static_cast<Fl_Text_Display*>(td)->wrapped_column(r, c); +} + +int fl_text_display_wrap_uses_character(TEXTDISPLAY td, int lep) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::wrap_uses_character))(lep); +} + +void fl_text_display_wrapped_line_counter(TEXTDISPLAY td, void * buf, int startPos, + int maxPos, int maxLines, int spils, int sbo, int &retPos, int &retLines, int &retLineStart, + int &retLineEnd, int cllmnl) +{ + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::wrapped_line_counter)) + (static_cast<Fl_Text_Buffer*>(buf), startPos, maxPos, maxLines, spils!=0, sbo, + &retPos, &retLines, &retLineStart, &retLineEnd, cllmnl!=0); +} + @@ -225,6 +346,59 @@ int fl_text_display_rewind_lines(TEXTDISPLAY td, int s, int l) { return static_cast<Fl_Text_Display*>(td)->rewind_lines(s, l); } +void fl_text_display_calc_last_char(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::calc_last_char))(); +} + +void fl_text_display_calc_line_starts(TEXTDISPLAY td, int s, int f) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::calc_line_starts))(s, f); +} + +void fl_text_display_offset_line_starts(TEXTDISPLAY td, int t) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::offset_line_starts))(t); +} + + + + +void fl_text_display_absolute_top_line_number(TEXTDISPLAY td, int c) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::absolute_top_line_number))(c); +} + +int fl_text_display_get_absolute_top_line_number(TEXTDISPLAY td) { + return (static_cast<Fl_Text_Display*>(td)->* + (&Friend_Text_Display::get_absolute_top_line_number))(); +} + +void fl_text_display_maintain_absolute_top_line_number(TEXTDISPLAY td, int s) { + (static_cast<Fl_Text_Display*>(td)->* + (&Friend_Text_Display::maintain_absolute_top_line_number))(s); +} + +int fl_text_display_maintaining_absolute_top_line_number(TEXTDISPLAY td) { + return (static_cast<Fl_Text_Display*>(td)->* + (&Friend_Text_Display::maintaining_absolute_top_line_number))(); +} + +void fl_text_display_reset_absolute_top_line_number(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::reset_absolute_top_line_number))(); +} + + + + +int fl_text_display_empty_vlines(TEXTDISPLAY td) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::empty_vlines))(); +} + +int fl_text_display_longest_vline(TEXTDISPLAY td) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::longest_vline))(); +} + +int fl_text_display_vline_length(TEXTDISPLAY td, int l) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::vline_length))(l); +} + @@ -276,6 +450,32 @@ void fl_text_display_set_linenumber_width(TEXTDISPLAY td, int w) { static_cast<Fl_Text_Display*>(td)->linenumber_width(w); } +const char * fl_text_display_get_linenumber_format(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->linenumber_format(); +} + +void fl_text_display_set_linenumber_format(TEXTDISPLAY td, const char * v) { + static_cast<Fl_Text_Display*>(td)->linenumber_format(v); +} + + + + +double fl_text_display_measure_proportional_character(TEXTDISPLAY td, const char * str, + int xpix, int pos) +{ + return (static_cast<Fl_Text_Display*>(td)->* + (&Friend_Text_Display::measure_proportional_character))(str, xpix, pos); +} + +int fl_text_display_measure_vline(TEXTDISPLAY td, int line) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::measure_vline))(line); +} + +double fl_text_display_string_width(TEXTDISPLAY td, const char * str, int len, int s) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::string_width))(str, len, s); +} + @@ -298,8 +498,12 @@ int fl_text_display_move_up(TEXTDISPLAY td) { -void fl_text_display_scroll(TEXTDISPLAY td, int l) { - static_cast<Fl_Text_Display*>(td)->scroll(l, 1); +void fl_text_display_scroll(TEXTDISPLAY td, int l, int c) { + static_cast<Fl_Text_Display*>(td)->scroll(l, c); +} + +int fl_text_display_scroll2(TEXTDISPLAY td, int l, int p) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::scroll_))(l, p); } unsigned int fl_text_display_get_scrollbar_align(TEXTDISPLAY td) { @@ -318,20 +522,80 @@ void fl_text_display_set_scrollbar_width(TEXTDISPLAY td, int w) { static_cast<Fl_Text_Display*>(td)->scrollbar_width(w); } +void fl_text_display_update_h_scrollbar(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::update_h_scrollbar))(); +} +void fl_text_display_update_v_scrollbar(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::update_v_scrollbar))(); +} -void fl_text_display_redisplay_range(TEXTDISPLAY td, int s, int f) { - static_cast<Fl_Text_Display*>(td)->redisplay_range(s,f); + + +int fl_text_display_get_shortcut(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->shortcut(); } +void fl_text_display_set_shortcut(TEXTDISPLAY td, int s) { + static_cast<Fl_Text_Display*>(td)->shortcut(s); +} + + + + +void fl_text_display_resize(TEXTDISPLAY td, int x, int y, int w, int h) { + static_cast<Fl_Text_Display*>(td)->resize(x, y, w, h); +} + + +void fl_text_display_clear_rect(TEXTDISPLAY td, int s, int x, int y, int w, int h) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::clear_rect))(s, x, y, w, h); +} + +void fl_text_display_display_insert(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::display_insert))(); +} + +void fl_text_display_redisplay_range(TEXTDISPLAY td, int s, int f) { + static_cast<Fl_Text_Display*>(td)->redisplay_range(s,f); +} void fl_text_display_draw(TEXTDISPLAY td) { static_cast<My_Text_Display*>(td)->Fl_Text_Display::draw(); } +void fl_text_display_draw_cursor(TEXTDISPLAY td, int x, int y) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_cursor))(x, y); +} + +void fl_text_display_draw_line_numbers(TEXTDISPLAY td, int c) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_line_numbers))(c!=0); +} + +void fl_text_display_draw_range(TEXTDISPLAY td, int s, int f) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_range))(s, f); +} + +void fl_text_display_draw_string(TEXTDISPLAY td, int s, int x, int y, int r, + const char * str, int n) +{ + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_string))(s, x, y, r, str, n); +} + +void fl_text_display_draw_text(TEXTDISPLAY td, int x, int y, int w, int h) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_text))(x, y, w, h); +} + +void fl_text_display_draw_vline(TEXTDISPLAY td, int line, int left, int right, + int lchar, int rchar) +{ + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_vline)) + (line, left, right, lchar, rchar); +} + int fl_text_display_handle(TEXTDISPLAY td, int e) { return static_cast<My_Text_Display*>(td)->Fl_Text_Display::handle(e); } diff --git a/body/c_fl_text_display.h b/body/c_fl_text_display.h index ece9a6a..5a39ae1 100644 --- a/body/c_fl_text_display.h +++ b/body/c_fl_text_display.h @@ -19,17 +19,27 @@ extern "C" void free_fl_text_display(TEXTDISPLAY td); extern "C" TEXTBUFFER fl_text_display_get_buffer(TEXTDISPLAY td); extern "C" void fl_text_display_set_buffer(TEXTDISPLAY td, TEXTBUFFER tb); +extern "C" void fl_text_display_buffer_modified_cb(int p, int i, int d, int r, + const char * t, TEXTDISPLAY td); +extern "C" void fl_text_display_buffer_predelete_cb(int p, int d, TEXTDISPLAY td); extern "C" void fl_text_display_highlight_data(TEXTDISPLAY td, TEXTBUFFER tb, void * st, int len); extern "C" void fl_text_display_highlight_data2(TEXTDISPLAY td, TEXTBUFFER tb, void * st, int len, char us, void * cb, void * a); +extern "C" int fl_text_display_position_style(TEXTDISPLAY td, int s, int l, int i); extern "C" double fl_text_display_col_to_x(TEXTDISPLAY td, double c); extern "C" double fl_text_display_x_to_col(TEXTDISPLAY td, double x); extern "C" int fl_text_display_in_selection(TEXTDISPLAY td, int x, int y); extern "C" int fl_text_display_position_to_xy(TEXTDISPLAY td, int p, int * x, int * y); +extern "C" void fl_text_display_find_line_end(TEXTDISPLAY td, int sp, int spils, int &le, int &nls); +extern "C" int fl_text_display_find_x(TEXTDISPLAY td, const char * str, int l, int s, int x); +extern "C" int fl_text_display_position_to_line(TEXTDISPLAY td, int p, int &ln); +extern "C" int fl_text_display_position_to_linecol(TEXTDISPLAY td, int p, int &ln, int &c); +extern "C" int fl_text_display_xy_to_position(TEXTDISPLAY td, int x, int y, int k); +extern "C" void fl_text_display_xy_to_rowcol(TEXTDISPLAY td, int x, int y, int &r, int &c, int k); extern "C" unsigned int fl_text_display_get_cursor_color(TEXTDISPLAY td); @@ -58,7 +68,15 @@ extern "C" int fl_text_display_word_start(TEXTDISPLAY td, int p); extern "C" int fl_text_display_word_end(TEXTDISPLAY td, int p); extern "C" void fl_text_display_next_word(TEXTDISPLAY td); extern "C" void fl_text_display_previous_word(TEXTDISPLAY td); + + extern "C" void fl_text_display_wrap_mode(TEXTDISPLAY td, int w, int m); +extern "C" int fl_text_display_wrapped_row(TEXTDISPLAY td, int r); +extern "C" int fl_text_display_wrapped_column(TEXTDISPLAY td, int r, int c); +extern "C" int fl_text_display_wrap_uses_character(TEXTDISPLAY td, int lep); +extern "C" void fl_text_display_wrapped_line_counter(TEXTDISPLAY td, void * buf, int startPos, + int maxPos, int maxLines, int spils, int sbo, int &retPos, int &retLines, int &retLineStart, + int &retLineEnd, int cllmnl); extern "C" int fl_text_display_line_start(TEXTDISPLAY td, int s); @@ -66,6 +84,21 @@ extern "C" int fl_text_display_line_end(TEXTDISPLAY td, int s, int p); extern "C" int fl_text_display_count_lines(TEXTDISPLAY td, int s, int f, int p); extern "C" int fl_text_display_skip_lines(TEXTDISPLAY td, int s, int l, int p); extern "C" int fl_text_display_rewind_lines(TEXTDISPLAY td, int s, int l); +extern "C" void fl_text_display_calc_last_char(TEXTDISPLAY td); +extern "C" void fl_text_display_calc_line_starts(TEXTDISPLAY td, int s, int f); +extern "C" void fl_text_display_offset_line_starts(TEXTDISPLAY td, int t); + + +extern "C" void fl_text_display_absolute_top_line_number(TEXTDISPLAY td, int c); +extern "C" int fl_text_display_get_absolute_top_line_number(TEXTDISPLAY td); +extern "C" void fl_text_display_maintain_absolute_top_line_number(TEXTDISPLAY td, int s); +extern "C" int fl_text_display_maintaining_absolute_top_line_number(TEXTDISPLAY td); +extern "C" void fl_text_display_reset_absolute_top_line_number(TEXTDISPLAY td); + + +extern "C" int fl_text_display_empty_vlines(TEXTDISPLAY td); +extern "C" int fl_text_display_longest_vline(TEXTDISPLAY td); +extern "C" int fl_text_display_vline_length(TEXTDISPLAY td, int l); extern "C" unsigned int fl_text_display_get_linenumber_align(TEXTDISPLAY td); @@ -80,6 +113,14 @@ extern "C" int fl_text_display_get_linenumber_size(TEXTDISPLAY td); extern "C" void fl_text_display_set_linenumber_size(TEXTDISPLAY td, int s); extern "C" int fl_text_display_get_linenumber_width(TEXTDISPLAY td); extern "C" void fl_text_display_set_linenumber_width(TEXTDISPLAY td, int w); +extern "C" const char * fl_text_display_get_linenumber_format(TEXTDISPLAY td); +extern "C" void fl_text_display_set_linenumber_format(TEXTDISPLAY td, const char * v); + + +extern "C" double fl_text_display_measure_proportional_character(TEXTDISPLAY td, const char * str, + int xpix, int pos); +extern "C" int fl_text_display_measure_vline(TEXTDISPLAY td, int line); +extern "C" double fl_text_display_string_width(TEXTDISPLAY td, const char * str, int len, int s); extern "C" int fl_text_display_move_down(TEXTDISPLAY td); @@ -88,17 +129,35 @@ extern "C" int fl_text_display_move_right(TEXTDISPLAY td); extern "C" int fl_text_display_move_up(TEXTDISPLAY td); -extern "C" void fl_text_display_scroll(TEXTDISPLAY td, int l); +extern "C" void fl_text_display_scroll(TEXTDISPLAY td, int l, int c); +extern "C" int fl_text_display_scroll2(TEXTDISPLAY td, int l, int p); extern "C" unsigned int fl_text_display_get_scrollbar_align(TEXTDISPLAY td); extern "C" void fl_text_display_set_scrollbar_align(TEXTDISPLAY td, unsigned int a); extern "C" int fl_text_display_get_scrollbar_width(TEXTDISPLAY td); extern "C" void fl_text_display_set_scrollbar_width(TEXTDISPLAY td, int w); +extern "C" void fl_text_display_update_h_scrollbar(TEXTDISPLAY td); +extern "C" void fl_text_display_update_v_scrollbar(TEXTDISPLAY td); -extern "C" void fl_text_display_redisplay_range(TEXTDISPLAY td, int s, int f); +extern "C" int fl_text_display_get_shortcut(TEXTDISPLAY td); +extern "C" void fl_text_display_set_shortcut(TEXTDISPLAY td, int s); +extern "C" void fl_text_display_resize(TEXTDISPLAY td, int x, int y, int w, int h); + + +extern "C" void fl_text_display_clear_rect(TEXTDISPLAY td, int s, int x, int y, int w, int h); +extern "C" void fl_text_display_display_insert(TEXTDISPLAY td); +extern "C" void fl_text_display_redisplay_range(TEXTDISPLAY td, int s, int f); extern "C" void fl_text_display_draw(TEXTDISPLAY td); +extern "C" void fl_text_display_draw_cursor(TEXTDISPLAY td, int x, int y); +extern "C" void fl_text_display_draw_line_numbers(TEXTDISPLAY td, int c); +extern "C" void fl_text_display_draw_range(TEXTDISPLAY td, int s, int f); +extern "C" void fl_text_display_draw_string(TEXTDISPLAY td, int s, int x, int y, int r, + const char * str, int n); +extern "C" void fl_text_display_draw_text(TEXTDISPLAY td, int x, int y, int w, int h); +extern "C" void fl_text_display_draw_vline(TEXTDISPLAY td, int line, int left, int right, + int lchar, int rchar); extern "C" int fl_text_display_handle(TEXTDISPLAY td, int e); diff --git a/body/c_fl_text_editor.cpp b/body/c_fl_text_editor.cpp index 6138cb2..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); + } } @@ -355,9 +360,6 @@ void fl_text_editor_set_insert_mode(TEXTEDITOR te, int i) { static_cast<Fl_Text_Editor*>(te)->insert_mode(i); } - - - int fl_text_editor_get_tab_nav(TEXTEDITOR te) { #if FLTK_ABI_VERSION >= 10304 return static_cast<Fl_Text_Editor*>(te)->tab_nav(); diff --git a/body/c_fl_text_editor.h b/body/c_fl_text_editor.h index 3f57921..b34681c 100644 --- a/body/c_fl_text_editor.h +++ b/body/c_fl_text_editor.h @@ -99,8 +99,6 @@ extern "C" void fl_text_editor_set_default_key_function(TEXTEDITOR te, void * f) extern "C" int fl_text_editor_get_insert_mode(TEXTEDITOR te); extern "C" void fl_text_editor_set_insert_mode(TEXTEDITOR te, int i); - - extern "C" int fl_text_editor_get_tab_nav(TEXTEDITOR te); extern "C" void fl_text_editor_set_tab_nav(TEXTEDITOR te, int t); 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 6eda9e3..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" @@ -23,8 +24,10 @@ extern "C" int widget_handle_hook(void * ud, int e); class Friend_Widget : Fl_Widget { public: - // probably expand this later when doing a pass for protected methods + using Fl_Widget::draw_backdrop; using Fl_Widget::draw_box; + using Fl_Widget::draw_focus; + using Fl_Widget::draw_label; }; @@ -63,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); + } } @@ -131,6 +138,9 @@ void fl_widget_clear_output(WIDGET w) { static_cast<Fl_Widget*>(w)->clear_output(); } + + + int fl_widget_visible(WIDGET w) { return static_cast<Fl_Widget*>(w)->visible(); } @@ -147,6 +157,14 @@ void fl_widget_clear_visible(WIDGET w) { static_cast<Fl_Widget*>(w)->clear_visible(); } +void fl_widget_show(WIDGET w) { + static_cast<Fl_Widget*>(w)->show(); +} + +void fl_widget_hide(WIDGET w) { + static_cast<Fl_Widget*>(w)->hide(); +} + @@ -154,10 +172,18 @@ int fl_widget_get_visible_focus(WIDGET w) { return static_cast<Fl_Widget*>(w)->visible_focus(); } +void fl_widget_set_visible_focus2(WIDGET w) { + static_cast<Fl_Widget*>(w)->set_visible_focus(); +} + void fl_widget_set_visible_focus(WIDGET w, int f) { static_cast<Fl_Widget*>(w)->visible_focus(f); } +void fl_widget_clear_visible_focus(WIDGET w) { + static_cast<Fl_Widget*>(w)->clear_visible_focus(); +} + int fl_widget_take_focus(WIDGET w) { return static_cast<Fl_Widget*>(w)->take_focus(); } @@ -185,6 +211,10 @@ void fl_widget_set_selection_color(WIDGET w, unsigned int c) { static_cast<Fl_Widget*>(w)->selection_color(c); } +void fl_widget_set_colors(WIDGET w, unsigned int b, unsigned int s) { + static_cast<Fl_Widget*>(w)->color(b, s); +} + @@ -293,11 +323,15 @@ void fl_widget_set_callback(WIDGET w, void * cb) { static_cast<Fl_Widget*>(w)->callback(reinterpret_cast<Fl_Callback_p>(cb)); } -unsigned int fl_widget_get_when(WIDGET w) { +void fl_widget_default_callback(WIDGET w, void * ud) { + Fl_Widget::default_callback(static_cast<Fl_Widget*>(w), ud); +} + +unsigned char fl_widget_get_when(WIDGET w) { return static_cast<Fl_Widget*>(w)->when(); } -void fl_widget_set_when(WIDGET w, unsigned int c) { +void fl_widget_set_when(WIDGET w, unsigned char c) { static_cast<Fl_Widget*>(w)->when(c); } @@ -324,6 +358,10 @@ void fl_widget_size(WIDGET w, int d, int h) { static_cast<Fl_Widget*>(w)->size(d, h); } +void fl_widget_resize(WIDGET o, int x, int y, int w, int h) { + static_cast<Fl_Widget*>(o)->resize(x, y, w, h); +} + void fl_widget_position(WIDGET w, int x, int y) { static_cast<Fl_Widget*>(w)->position(x, y); } @@ -353,24 +391,20 @@ void fl_widget_set_type(WIDGET w, unsigned char t) { -int fl_widget_damage(WIDGET w) { +unsigned char fl_widget_damage(WIDGET w) { return static_cast<Fl_Widget*>(w)->damage(); } -void fl_widget_set_damage(WIDGET w, int t) { - if (t != 0) { - static_cast<Fl_Widget*>(w)->damage(0xff); - } else { - static_cast<Fl_Widget*>(w)->damage(0x00); - } +void fl_widget_set_damage(WIDGET w, unsigned char m) { + static_cast<Fl_Widget*>(w)->damage(m); } -void fl_widget_set_damage2(WIDGET w, int t, int x, int y, int d, int h) { - if (t != 0) { - static_cast<Fl_Widget*>(w)->damage(0xff,x,y,d,h); - } else { - static_cast<Fl_Widget*>(w)->damage(0x00,x,y,d,h); - } +void fl_widget_set_damage2(WIDGET w, unsigned char m, int x, int y, int d, int h) { + static_cast<Fl_Widget*>(w)->damage(m, x, y, d, h); +} + +void fl_widget_clear_damage(WIDGET w, unsigned char m) { + static_cast<Fl_Widget*>(w)->clear_damage(m); } void fl_widget_draw(WIDGET w) { @@ -381,8 +415,48 @@ void fl_widget_draw(WIDGET w) { // and makes uniform the implementation of the Ada Widget Draw subprogram. } -void fl_widget_draw_label(WIDGET w, int x, int y, int d, int h, unsigned int a) { - static_cast<Fl_Widget*>(w)->draw_label(x,y,d,h,a); +void fl_widget_draw_label(WIDGET w) { + void (Fl_Widget::*mydraw)(void) const = &Friend_Widget::draw_label; + (static_cast<Fl_Widget*>(w)->*mydraw)(); +} + +void fl_widget_draw_label2(WIDGET o, int x, int y, int w, int h) { + void (Fl_Widget::*mydraw)(int,int,int,int) const = &Friend_Widget::draw_label; + (static_cast<Fl_Widget*>(o)->*mydraw)(x, y, w, h); +} + +void fl_widget_draw_label3(WIDGET w, int x, int y, int d, int h, unsigned int a) { + static_cast<Fl_Widget*>(w)->draw_label(x, y, d, h, a); +} + +void fl_widget_draw_backdrop(WIDGET w) { + (static_cast<Fl_Widget*>(w)->*(&Friend_Widget::draw_backdrop))(); +} + +void fl_widget_draw_box(WIDGET w) { + void (Fl_Widget::*mydraw)(void) const = &Friend_Widget::draw_box; + (static_cast<Fl_Widget*>(w)->*mydraw)(); +} + +void fl_widget_draw_box2(WIDGET w, int k, unsigned int h) { + void (Fl_Widget::*mydraw)(Fl_Boxtype,Fl_Color) const = &Friend_Widget::draw_box; + (static_cast<Fl_Widget*>(w)->*mydraw)(static_cast<Fl_Boxtype>(k), static_cast<Fl_Color>(h)); +} + +void fl_widget_draw_box3(WIDGET o, int k, int x, int y, int w, int h, unsigned int c) { + void (Fl_Widget::*mydraw)(Fl_Boxtype,int,int,int,int,Fl_Color) const = &Friend_Widget::draw_box; + (static_cast<Fl_Widget*>(o)->*mydraw) + (static_cast<Fl_Boxtype>(k), x, y, w, h, static_cast<Fl_Color>(c)); +} + +void fl_widget_draw_focus(WIDGET w) { + void (Fl_Widget::*mydraw)(void) = &Friend_Widget::draw_focus; + (static_cast<Fl_Widget*>(w)->*mydraw)(); +} + +void fl_widget_draw_focus2(WIDGET o, int k, int x, int y, int w, int h) { + void (Fl_Widget::*mydraw)(Fl_Boxtype,int,int,int,int) const = &Friend_Widget::draw_focus; + (static_cast<Fl_Widget*>(o)->*mydraw)(static_cast<Fl_Boxtype>(k), x, y, w, h); } void fl_widget_redraw(WIDGET w) { @@ -398,3 +472,10 @@ int fl_widget_handle(WIDGET w, int e) { } + + +int fl_widget_use_accents_menu(WIDGET w) { + return static_cast<Fl_Widget*>(w)->use_accents_menu(); +} + + diff --git a/body/c_fl_widget.h b/body/c_fl_widget.h index 9634ba4..2ac2630 100644 --- a/body/c_fl_widget.h +++ b/body/c_fl_widget.h @@ -33,14 +33,20 @@ extern "C" void fl_widget_clear_changed(WIDGET w); extern "C" int fl_widget_output(WIDGET w); extern "C" void fl_widget_set_output(WIDGET w); extern "C" void fl_widget_clear_output(WIDGET w); + + extern "C" int fl_widget_visible(WIDGET w); extern "C" int fl_widget_visible_r(WIDGET w); extern "C" void fl_widget_set_visible(WIDGET w); extern "C" void fl_widget_clear_visible(WIDGET w); +extern "C" void fl_widget_show(WIDGET w); +extern "C" void fl_widget_hide(WIDGET w); extern "C" int fl_widget_get_visible_focus(WIDGET w); +extern "C" void fl_widget_set_visible_focus2(WIDGET w); extern "C" void fl_widget_set_visible_focus(WIDGET w, int f); +extern "C" void fl_widget_clear_visible_focus(WIDGET w); extern "C" int fl_widget_take_focus(WIDGET w); extern "C" int fl_widget_takesevents(WIDGET w); @@ -49,6 +55,7 @@ extern "C" unsigned int fl_widget_get_color(WIDGET w); extern "C" void fl_widget_set_color(WIDGET w, unsigned int b); extern "C" unsigned int fl_widget_get_selection_color(WIDGET w); extern "C" void fl_widget_set_selection_color(WIDGET w, unsigned int c); +extern "C" void fl_widget_set_colors(WIDGET w, unsigned int b, unsigned int s); extern "C" void * fl_widget_get_parent(WIDGET w); @@ -81,8 +88,9 @@ extern "C" void fl_widget_measure_label(WIDGET w, int &d, int &h); extern "C" void fl_widget_set_callback(WIDGET w, void * cb); -extern "C" unsigned int fl_widget_get_when(WIDGET w); -extern "C" void fl_widget_set_when(WIDGET w, unsigned int c); +extern "C" void fl_widget_default_callback(WIDGET w, void * ud); +extern "C" unsigned char fl_widget_get_when(WIDGET w); +extern "C" void fl_widget_set_when(WIDGET w, unsigned char c); extern "C" int fl_widget_get_x(WIDGET w); @@ -90,6 +98,7 @@ extern "C" int fl_widget_get_y(WIDGET w); extern "C" int fl_widget_get_w(WIDGET w); extern "C" int fl_widget_get_h(WIDGET w); extern "C" void fl_widget_size(WIDGET w, int d, int h); +extern "C" void fl_widget_resize(WIDGET o, int x, int y, int w, int h); extern "C" void fl_widget_position(WIDGET w, int x, int y); @@ -101,16 +110,28 @@ extern "C" unsigned char fl_widget_get_type(WIDGET w); extern "C" void fl_widget_set_type(WIDGET w, unsigned char t); -extern "C" int fl_widget_damage(WIDGET w); -extern "C" void fl_widget_set_damage(WIDGET w, int t); -extern "C" void fl_widget_set_damage2(WIDGET w, int t, int x, int y, int d, int h); +extern "C" unsigned char fl_widget_damage(WIDGET w); +extern "C" void fl_widget_set_damage(WIDGET w, unsigned char m); +extern "C" void fl_widget_set_damage2(WIDGET w, unsigned char m, int x, int y, int d, int h); +extern "C" void fl_widget_clear_damage(WIDGET w, unsigned char m); extern "C" void fl_widget_draw(WIDGET w); -extern "C" void fl_widget_draw_label(WIDGET w, int x, int y, int d, int h, unsigned int a); +extern "C" void fl_widget_draw_label(WIDGET w); +extern "C" void fl_widget_draw_label2(WIDGET o, int x, int y, int w, int h); +extern "C" void fl_widget_draw_label3(WIDGET w, int x, int y, int d, int h, unsigned int a); +extern "C" void fl_widget_draw_backdrop(WIDGET w); +extern "C" void fl_widget_draw_box(WIDGET w); +extern "C" void fl_widget_draw_box2(WIDGET w, int k, unsigned int h); +extern "C" void fl_widget_draw_box3(WIDGET o, int k, int x, int y, int w, int h, unsigned int c); +extern "C" void fl_widget_draw_focus(WIDGET w); +extern "C" void fl_widget_draw_focus2(WIDGET o, int k, int x, int y, int w, int h); extern "C" void fl_widget_redraw(WIDGET w); extern "C" void fl_widget_redraw_label(WIDGET w); extern "C" int fl_widget_handle(WIDGET w, int e); +extern "C" int fl_widget_use_accents_menu(WIDGET w); + + #endif diff --git a/body/c_fl_window.cpp b/body/c_fl_window.cpp index 806e66f..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" @@ -19,6 +20,17 @@ extern "C" int widget_handle_hook(void * ud, int e); +// Non-friend protected access + +class Friend_Window : Fl_Window { +public: + using Fl_Window::flush; + using Fl_Window::force_position; +}; + + + + // Attaching all relevant hooks and friends class My_Window : public Fl_Window { @@ -56,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); + } } @@ -92,10 +108,6 @@ void fl_window_make_current(WINDOW n) { static_cast<Fl_Window*>(n)->make_current(); } -void fl_window_free_position(WINDOW n) { - static_cast<Fl_Window*>(n)->free_position(); -} - @@ -126,10 +138,18 @@ void fl_window_set_icon(WINDOW n, void * img) { static_cast<Fl_Window*>(n)->icon(static_cast<Fl_RGB_Image*>(img)); } +void fl_window_icons(WINDOW n, void * imgs, int count) { + static_cast<Fl_Window*>(n)->icons(static_cast<const Fl_RGB_Image**>(imgs), count); +} + void fl_window_default_icon(void * img) { Fl_Window::default_icon(static_cast<Fl_RGB_Image*>(img)); } +void fl_window_default_icons(void * imgs, int count) { + Fl_Window::default_icons(static_cast<const Fl_RGB_Image**>(imgs), count); +} + const char * fl_window_get_iconlabel(WINDOW n) { return static_cast<Fl_Window*>(n)->iconlabel(); } @@ -161,6 +181,10 @@ void fl_window_set_border(WINDOW n, int b) { static_cast<Fl_Window*>(n)->border(b); } +void fl_window_clear_border(WINDOW n) { + static_cast<Fl_Window*>(n)->clear_border(); +} + unsigned int fl_window_get_override(WINDOW n) { return static_cast<Fl_Window*>(n)->override(); } @@ -196,7 +220,7 @@ const char * fl_window_get_label(WINDOW n) { return static_cast<Fl_Window*>(n)->label(); } -void fl_window_set_label(WINDOW n, char* text) { +void fl_window_copy_label(WINDOW n, char* text) { static_cast<Fl_Window*>(n)->copy_label(text); } @@ -208,16 +232,30 @@ void fl_window_hotspot2(WINDOW n, void * i, int s) { static_cast<Fl_Window*>(n)->hotspot(static_cast<Fl_Widget*>(i),s); } +void fl_window_shape(WINDOW n, void * p) { + static_cast<Fl_Window*>(n)->shape(static_cast<Fl_Image*>(p)); +} + + + + void fl_window_size_range(WINDOW n, int lw, int lh, int hw, int hh, int dw, int dh, int a) { static_cast<Fl_Window*>(n)->size_range(lw, lh, hw, hh, dw, dh, a); } -void fl_window_shape(WINDOW n, void * p) { - static_cast<Fl_Window*>(n)->shape(static_cast<Fl_Image*>(p)); +void fl_window_resize(WINDOW n, int x, int y, int w, int h) { + static_cast<Fl_Window*>(n)->resize(x, y, w, h); } +int fl_window_get_force_position(WINDOW n) { + int (Fl_Window::*myforce)() const = &Friend_Window::force_position; + return (static_cast<Fl_Window*>(n)->*myforce)(); +} - +void fl_window_set_force_position(WINDOW n, int s) { + void (Fl_Window::*myforce)(int) = &Friend_Window::force_position; + (static_cast<Fl_Window*>(n)->*myforce)(s); +} int fl_window_get_x_root(WINDOW n) { return static_cast<Fl_Window*>(n)->x_root(); @@ -238,10 +276,41 @@ int fl_window_get_decorated_h(WINDOW n) { +const char * fl_window_get_xclass(WINDOW n) { + return static_cast<Fl_Window*>(n)->xclass(); +} + +void fl_window_set_xclass(WINDOW n, const char * c) { + static_cast<Fl_Window*>(n)->xclass(c); +} + +const char * fl_window_get_default_xclass() { + return Fl_Window::default_xclass(); +} + +void fl_window_set_default_xclass(const char * c) { + Fl_Window::default_xclass(c); +} + +unsigned int fl_window_menu_window(WINDOW n) { + return static_cast<Fl_Window*>(n)->menu_window(); +} + +unsigned int fl_window_tooltip_window(WINDOW n) { + return static_cast<Fl_Window*>(n)->tooltip_window(); +} + + + + void fl_window_draw(WINDOW n) { static_cast<My_Window*>(n)->Fl_Window::draw(); } +void fl_window_flush(WINDOW n) { + (static_cast<Fl_Window*>(n)->*(&Friend_Window::flush))(); +} + int fl_window_handle(WINDOW n, int e) { return static_cast<My_Window*>(n)->Fl_Window::handle(e); } diff --git a/body/c_fl_window.h b/body/c_fl_window.h index ed6ebdd..337cf77 100644 --- a/body/c_fl_window.h +++ b/body/c_fl_window.h @@ -23,7 +23,6 @@ extern "C" int fl_window_shown(WINDOW n); extern "C" void fl_window_wait_for_expose(WINDOW n); extern "C" void fl_window_iconize(WINDOW n); extern "C" void fl_window_make_current(WINDOW n); -extern "C" void fl_window_free_position(WINDOW n); extern "C" unsigned int fl_window_fullscreen_active(WINDOW n); @@ -34,7 +33,9 @@ extern "C" void fl_window_fullscreen_screens(WINDOW n, int t, int b, int l, int extern "C" void fl_window_set_icon(WINDOW n, void * img); +extern "C" void fl_window_icons(WINDOW n, void * imgs, int count); extern "C" void fl_window_default_icon(void * img); +extern "C" void fl_window_default_icons(void * imgs, int count); extern "C" const char * fl_window_get_iconlabel(WINDOW n); extern "C" void fl_window_set_iconlabel(WINDOW n, const char * s); extern "C" void fl_window_set_cursor(WINDOW n, int c); @@ -44,30 +45,43 @@ extern "C" void fl_window_set_default_cursor(WINDOW n, int c); extern "C" unsigned int fl_window_get_border(WINDOW n); extern "C" void fl_window_set_border(WINDOW n, int b); +extern "C" void fl_window_clear_border(WINDOW n); extern "C" unsigned int fl_window_get_override(WINDOW n); extern "C" void fl_window_set_override(WINDOW n); extern "C" unsigned int fl_window_modal(WINDOW n); extern "C" unsigned int fl_window_non_modal(WINDOW n); -extern "C" void fl_window_clear_modal_states(WINDOW n); extern "C" void fl_window_set_modal(WINDOW n); extern "C" void fl_window_set_non_modal(WINDOW n); +extern "C" void fl_window_clear_modal_states(WINDOW n); extern "C" const char * fl_window_get_label(WINDOW n); -extern "C" void fl_window_set_label(WINDOW n, char* text); +extern "C" void fl_window_copy_label(WINDOW n, char* text); extern "C" void fl_window_hotspot(WINDOW n, int x, int y, int s); extern "C" void fl_window_hotspot2(WINDOW n, void * i, int s); -extern "C" void fl_window_size_range(WINDOW n, int lw, int lh, int hw, int hh, int dw, int dh, int a); extern "C" void fl_window_shape(WINDOW n, void * p); +extern "C" void fl_window_size_range(WINDOW n, int lw, int lh, int hw, int hh, int dw, int dh, int a); +extern "C" void fl_window_resize(WINDOW n, int x, int y, int w, int h); +extern "C" int fl_window_get_force_position(WINDOW n); +extern "C" void fl_window_set_force_position(WINDOW n, int s); extern "C" int fl_window_get_x_root(WINDOW n); extern "C" int fl_window_get_y_root(WINDOW n); extern "C" int fl_window_get_decorated_w(WINDOW n); extern "C" int fl_window_get_decorated_h(WINDOW n); +extern "C" const char * fl_window_get_xclass(WINDOW n); +extern "C" void fl_window_set_xclass(WINDOW n, const char * c); +extern "C" const char * fl_window_get_default_xclass(); +extern "C" void fl_window_set_default_xclass(const char * c); +extern "C" unsigned int fl_window_menu_window(WINDOW n); +extern "C" unsigned int fl_window_tooltip_window(WINDOW n); + + extern "C" void fl_window_draw(WINDOW n); +extern "C" void fl_window_flush(WINDOW n); extern "C" int fl_window_handle(WINDOW n, int e); 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 231b875..b19c182 100644 --- a/body/fltk-show_argv.ads +++ b/body/fltk-args_marshal.ads @@ -6,14 +6,25 @@ 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) + -- Dispatch marshalls the data, calls the function, then does cleanup + type Show_With_Args_Func is access procedure (CObj : in Storage.Integer_Address; Argc : in Interfaces.C.int; @@ -30,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 bd09fac..8d4f900 100644 --- a/body/fltk-asks.adb +++ b/body/fltk-asks.adb @@ -27,6 +27,8 @@ package body FLTK.Asks is -- Functions From C -- ------------------------ + -- Static Attributes -- + function fl_ask_get_cancel return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_ask_get_cancel, "fl_ask_get_cancel"); @@ -80,6 +82,8 @@ package body FLTK.Asks is + -- Simple Messages -- + procedure fl_ask_alert (M : in Interfaces.C.char_array); pragma Import (C, fl_ask_alert, "fl_ask_alert"); @@ -124,6 +128,8 @@ package body FLTK.Asks is + -- Choosers -- + function fl_ask_color_chooser (N : in Interfaces.C.char_array; R, G, B : in out Interfaces.C.double; @@ -140,6 +146,12 @@ package body FLTK.Asks is pragma Import (C, fl_ask_color_chooser2, "fl_ask_color_chooser2"); pragma Inline (fl_ask_color_chooser2); + function fl_ask_show_colormap + (H : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_ask_show_colormap, "fl_ask_show_colormap"); + pragma Inline (fl_ask_show_colormap); + function fl_ask_dir_chooser (M, D : in Interfaces.C.char_array; R : in Interfaces.C.int) @@ -167,6 +179,8 @@ package body FLTK.Asks is + -- Settings -- + function fl_ask_get_message_hotspot return Interfaces.C.int; pragma Import (C, fl_ask_get_message_hotspot, "fl_ask_get_message_hotspot"); @@ -220,9 +234,9 @@ package body FLTK.Asks is - --------------- - -- Cleanup -- - --------------- + ------------------- + -- Destructors -- + ------------------- procedure Finalize (This : in out Dialog_String_Final_Controller) @@ -240,9 +254,26 @@ package body FLTK.Asks is - ------------------ - -- Attributes -- - ------------------ + -------------------- + -- 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 -- + ----------------------- + + -- Static Attributes -- function Get_Cancel_String return String is @@ -326,9 +357,7 @@ package body FLTK.Asks is - ---------------------- - -- Common Dialogs -- - ---------------------- + -- Simple Messages -- procedure Alert (Message : String) is @@ -348,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; @@ -363,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; @@ -379,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; @@ -393,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, @@ -402,7 +443,9 @@ package body FLTK.Asks is pragma Assert (Result in -3 .. 2); return Extended_Choice_Result'Val (Result mod 6); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_choice_n returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Extended_Choice; @@ -411,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), @@ -420,7 +463,9 @@ package body FLTK.Asks is pragma Assert (Result in -3 .. 2); return Extended_Choice_Result'Val (Result mod 6); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_choice_n returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Extended_Choice; @@ -430,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), @@ -439,7 +484,9 @@ package body FLTK.Asks is pragma Assert (Result in -3 .. 2); return Extended_Choice_Result'Val (Result mod 6); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_choice_n returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Extended_Choice; @@ -448,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 @@ -473,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 @@ -488,6 +535,8 @@ package body FLTK.Asks is + -- Choosers -- + function Color_Chooser (Title : in String; R, G, B : in out RGB_Float; @@ -498,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 @@ -512,7 +561,9 @@ package body FLTK.Asks is return Cancel; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_color_chooser returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Color_Chooser; @@ -526,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 @@ -540,16 +591,26 @@ package body FLTK.Asks is return Cancel; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_color_chooser returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Color_Chooser; + function Show_Colormap + (Old_Hue : in Color) + return Color is + begin + return Color (fl_ask_show_colormap (Interfaces.C.unsigned (Old_Hue))); + end Show_Colormap; + + function Dir_Chooser (Message, Default : in String; 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)); @@ -568,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), @@ -601,6 +662,8 @@ package body FLTK.Asks is + -- Settings -- + function Get_Message_Hotspot return Boolean is begin @@ -644,16 +707,23 @@ package body FLTK.Asks is end Set_Message_Title_Default; - - 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)); end FLTK.Asks; + 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-graphics.adb b/body/fltk-devices-graphics.adb index f97cebe..7c5d160 100644 --- a/body/fltk-devices-graphics.adb +++ b/body/fltk-devices-graphics.adb @@ -12,6 +12,12 @@ with package body FLTK.Devices.Graphics is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Color -- + function fl_graphics_driver_color (G : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -21,6 +27,8 @@ package body FLTK.Devices.Graphics is + -- Text -- + function fl_graphics_driver_descent (G : in Storage.Integer_Address) return Interfaces.C.int; @@ -69,6 +77,8 @@ package body FLTK.Devices.Graphics is + -- Images -- + procedure fl_graphics_driver_draw_scaled (G, I : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int); @@ -78,6 +88,12 @@ package body FLTK.Devices.Graphics is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Color -- + function Get_Color (This : in Graphics_Driver) return Color is @@ -88,6 +104,8 @@ package body FLTK.Devices.Graphics is + -- Text -- + function Get_Text_Descent (This : in Graphics_Driver) return Integer is @@ -152,6 +170,8 @@ package body FLTK.Devices.Graphics is + -- Images -- + procedure Draw_Scaled_Image (This : in Graphics_Driver; Img : in FLTK.Images.Image'Class; @@ -169,3 +189,4 @@ package body FLTK.Devices.Graphics is end FLTK.Devices.Graphics; + diff --git a/body/fltk-devices-surface-copy.adb b/body/fltk-devices-surface-copy.adb index 7bb1c66..234ef5b 100644 --- a/body/fltk-devices-surface-copy.adb +++ b/body/fltk-devices-surface-copy.adb @@ -12,6 +12,12 @@ with package body FLTK.Devices.Surface.Copy is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_copy_surface (W, H : in Interfaces.C.int) return Storage.Integer_Address; @@ -26,6 +32,8 @@ package body FLTK.Devices.Surface.Copy is + -- Dimensions -- + function fl_copy_surface_get_w (S : in Storage.Integer_Address) return Interfaces.C.int; @@ -41,6 +49,8 @@ package body FLTK.Devices.Surface.Copy is + -- Drawing -- + procedure fl_copy_surface_draw (S, W : in Storage.Integer_Address; OX, OY : in Interfaces.C.int); @@ -57,6 +67,8 @@ package body FLTK.Devices.Surface.Copy is + -- Surfaces -- + procedure fl_copy_surface_set_current (S : in Storage.Integer_Address); pragma Import (C, fl_copy_surface_set_current, "fl_copy_surface_set_current"); @@ -65,6 +77,10 @@ package body FLTK.Devices.Surface.Copy is + ------------------- + -- Destructors -- + ------------------- + procedure Finalize (This : in out Copy_Surface) is begin @@ -77,6 +93,10 @@ package body FLTK.Devices.Surface.Copy is + -------------------- + -- Constructors -- + -------------------- + package body Forge is function Create @@ -97,6 +117,12 @@ package body FLTK.Devices.Surface.Copy is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Dimensions -- + function Get_W (This : in Copy_Surface) return Integer is @@ -115,6 +141,8 @@ package body FLTK.Devices.Surface.Copy is + -- Drawing -- + procedure Draw_Widget (This : in out Copy_Surface; Item : in FLTK.Widgets.Widget'Class; @@ -143,6 +171,8 @@ package body FLTK.Devices.Surface.Copy is + -- Surfaces -- + procedure Set_Current (This : in out Copy_Surface) is begin diff --git a/body/fltk-devices-surface-display.adb b/body/fltk-devices-surface-display.adb index ad35012..8316180 100644 --- a/body/fltk-devices-surface-display.adb +++ b/body/fltk-devices-surface-display.adb @@ -11,6 +11,8 @@ package body FLTK.Devices.Surface.Display is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_display_device (G : in Storage.Integer_Address) return Storage.Integer_Address; @@ -25,6 +27,8 @@ package body FLTK.Devices.Surface.Display is + -- Displays -- + function fl_display_device_display_device return Storage.Integer_Address; pragma Import (C, fl_display_device_display_device, "fl_display_device_display_device"); @@ -33,6 +37,8 @@ package body FLTK.Devices.Surface.Display is + -- Drivers -- + function fl_surface_device_get_driver (S : in Storage.Integer_Address) return Storage.Integer_Address; @@ -93,6 +99,8 @@ package body FLTK.Devices.Surface.Display is -- API Subprograms -- ----------------------- + -- Displays -- + function Get_Platform_Display return Display_Device_Reference is begin diff --git a/body/fltk-devices-surface-image.adb b/body/fltk-devices-surface-image.adb index e9e7de4..f52387f 100644 --- a/body/fltk-devices-surface-image.adb +++ b/body/fltk-devices-surface-image.adb @@ -12,6 +12,12 @@ with package body FLTK.Devices.Surface.Image is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_image_surface (W, H, R : in Interfaces.C.int) return Storage.Integer_Address; @@ -26,6 +32,8 @@ package body FLTK.Devices.Surface.Image is + -- Drawing -- + procedure fl_image_surface_draw (S, I : in Storage.Integer_Address; OX, OY : in Interfaces.C.int); @@ -42,6 +50,8 @@ package body FLTK.Devices.Surface.Image is + -- Images -- + function fl_image_surface_image (S : in Storage.Integer_Address) return Storage.Integer_Address; @@ -57,6 +67,8 @@ package body FLTK.Devices.Surface.Image is + -- Surfaces -- + procedure fl_image_surface_set_current (S : in Storage.Integer_Address); pragma Import (C, fl_image_surface_set_current, "fl_image_surface_set_current"); @@ -65,6 +77,10 @@ package body FLTK.Devices.Surface.Image is + ------------------- + -- Destructors -- + ------------------- + procedure Finalize (This : in out Image_Surface) is begin @@ -77,6 +93,10 @@ package body FLTK.Devices.Surface.Image is + -------------------- + -- Constructors -- + -------------------- + package body Forge is function Create @@ -98,6 +118,12 @@ package body FLTK.Devices.Surface.Image is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Resolution -- + function Is_Highres (This : in Image_Surface) return Boolean is @@ -108,6 +134,8 @@ package body FLTK.Devices.Surface.Image is + -- Drawing -- + procedure Draw_Widget (This : in out Image_Surface; Item : in FLTK.Widgets.Widget'Class; @@ -136,6 +164,8 @@ package body FLTK.Devices.Surface.Image is + -- Images -- + function Get_Image (This : in Image_Surface) return FLTK.Images.RGB.RGB_Image is @@ -158,6 +188,8 @@ package body FLTK.Devices.Surface.Image is + -- Surfaces -- + procedure Set_Current (This : in out Image_Surface) is begin diff --git a/body/fltk-devices-surface-paged-postscript.adb b/body/fltk-devices-surface-paged-postscript.adb index fa9f66d..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 @@ -26,6 +26,8 @@ package body FLTK.Devices.Surface.Paged.Postscript is -- Functions From C -- ------------------------ + -- Files -- + function fopen (Name, Mode : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -39,6 +41,8 @@ package body FLTK.Devices.Surface.Paged.Postscript is + -- Allocation -- + function new_fl_postscript_file_device return Storage.Integer_Address; pragma Import (C, new_fl_postscript_file_device, "new_fl_postscript_file_device"); @@ -52,6 +56,8 @@ package body FLTK.Devices.Surface.Paged.Postscript is + -- Static Attributes -- + function fl_postscript_file_device_get_file_chooser_title return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_postscript_file_device_get_file_chooser_title, @@ -67,15 +73,20 @@ package body FLTK.Devices.Surface.Paged.Postscript is - 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); + -- 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); + + -- Job Control -- + function fl_postscript_file_device_start_job (D : in Storage.Integer_Address; C : in Interfaces.C.int) @@ -125,6 +136,8 @@ package body FLTK.Devices.Surface.Paged.Postscript is + -- Spacing and Orientation -- + procedure fl_postscript_file_device_margins (D : in Storage.Integer_Address; L, T, R, B : out Interfaces.C.int); @@ -301,6 +314,8 @@ package body FLTK.Devices.Surface.Paged.Postscript is -- API Subprograms -- ----------------------- + -- Driver -- + function Get_Postscript_Driver (This : in out Postscript_File_Device) return FLTK.Devices.Graphics.Graphics_Driver_Reference is @@ -311,6 +326,8 @@ package body FLTK.Devices.Surface.Paged.Postscript is + -- Job Control -- + procedure Start_Job (This : in out Postscript_File_Device; Count : in Natural := 0) is @@ -346,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), @@ -355,7 +372,9 @@ package body FLTK.Devices.Surface.Paged.Postscript is begin pragma Assert (Code = 0); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_PostScript_File_Device::start_job returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Start_Job; @@ -365,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), @@ -377,7 +396,9 @@ package body FLTK.Devices.Surface.Paged.Postscript is when others => pragma Assert (Code = 0); end case; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_PostScript_File_Device::start_job returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Start_Job; @@ -408,6 +429,8 @@ package body FLTK.Devices.Surface.Paged.Postscript is + -- Spacing and Orientation -- + procedure Get_Margins (This : in Postscript_File_Device; Left, Top, Right, Bottom : out Integer) is diff --git a/body/fltk-devices-surface-paged-printers.adb b/body/fltk-devices-surface-paged-printers.adb index 3e605c8..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 @@ -20,6 +20,8 @@ package body FLTK.Devices.Surface.Paged.Printers is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_printer return Storage.Integer_Address; pragma Import (C, new_fl_printer, "new_fl_printer"); @@ -33,6 +35,8 @@ package body FLTK.Devices.Surface.Paged.Printers is + -- Static Attributes -- + function fl_printer_get_dialog_title return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_printer_get_dialog_title, "fl_printer_get_dialog_title"); @@ -226,6 +230,8 @@ package body FLTK.Devices.Surface.Paged.Printers is + -- Job Control -- + function fl_printer_start_job (D : in Storage.Integer_Address; C : in Interfaces.C.int) @@ -261,6 +267,8 @@ package body FLTK.Devices.Surface.Paged.Printers is + -- Spacing and Orientation -- + procedure fl_printer_margins (D : in Storage.Integer_Address; L, T, R, B : out Interfaces.C.int); @@ -312,6 +320,8 @@ package body FLTK.Devices.Surface.Paged.Printers is + -- Printing -- + procedure fl_printer_print_widget (D, I : in Storage.Integer_Address; DX, DY : in Interfaces.C.int); @@ -327,6 +337,8 @@ package body FLTK.Devices.Surface.Paged.Printers is + -- Printer -- + procedure fl_printer_set_current (D : in Storage.Integer_Address); pragma Import (C, fl_printer_set_current, "fl_printer_set_current"); @@ -713,6 +725,8 @@ package body FLTK.Devices.Surface.Paged.Printers is -- API Subprograms -- ----------------------- + -- Driver -- + function Get_Original_Driver (This : in out Printer) return FLTK.Devices.Graphics.Graphics_Driver_Reference is @@ -723,6 +737,8 @@ package body FLTK.Devices.Surface.Paged.Printers is + -- Job Control -- + procedure Start_Job (This : in out Printer; Count : in Natural := 0) is @@ -778,6 +794,8 @@ package body FLTK.Devices.Surface.Paged.Printers is + -- Spacing and Orientation -- + procedure Get_Margins (This : in Printer; Left, Top, Right, Bottom : out Integer) is @@ -869,6 +887,8 @@ package body FLTK.Devices.Surface.Paged.Printers is + -- Printing -- + procedure Print_Widget (This : in out Printer; Item : in FLTK.Widgets.Widget'Class; @@ -902,6 +922,8 @@ package body FLTK.Devices.Surface.Paged.Printers is + -- Printer -- + procedure Set_Current (This : in out Printer) is begin diff --git a/body/fltk-devices-surface-paged.adb b/body/fltk-devices-surface-paged.adb index 829974a..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 @@ -54,6 +53,8 @@ package body FLTK.Devices.Surface.Paged is -- Functions From C -- ------------------------ + -- Static Attributes -- + procedure fl_paged_device_get_page_format (Index : in Interfaces.C.int; Name : out Interfaces.C.Strings.chars_ptr; @@ -65,6 +66,8 @@ package body FLTK.Devices.Surface.Paged is + -- Allocation -- + function new_fl_paged_device return Storage.Integer_Address; pragma Import (C, new_fl_paged_device, "new_fl_paged_device"); @@ -78,6 +81,8 @@ package body FLTK.Devices.Surface.Paged is + -- Job Control -- + function fl_paged_device_start_job (D : in Storage.Integer_Address; C : in Interfaces.C.int) @@ -113,6 +118,8 @@ package body FLTK.Devices.Surface.Paged is + -- Spacing and Orientation -- + procedure fl_paged_device_margins (D : in Storage.Integer_Address; L, T, R, B : out Interfaces.C.int); @@ -164,6 +171,8 @@ package body FLTK.Devices.Surface.Paged is + -- Printing -- + procedure fl_paged_device_print_widget (D, I : in Storage.Integer_Address; DX, DY : in Interfaces.C.int); @@ -211,7 +220,7 @@ package body FLTK.Devices.Surface.Paged is return Media; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Constraint_Error; end To_Page_Format; @@ -243,7 +252,7 @@ package body FLTK.Devices.Surface.Paged is return Orientation; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Constraint_Error; end To_Page_Layout; @@ -267,6 +276,10 @@ package body FLTK.Devices.Surface.Paged is Data (Index).My_Height := Natural (C_Height); end loop; end return; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Paged_Device::NO_PAGE_FORMATS has inconsistent value of " & + Interfaces.C.int'Image (fl_no_page_formats); end Get_Page_Formats; @@ -343,6 +356,8 @@ package body FLTK.Devices.Surface.Paged is -- API Subprograms -- ----------------------- + -- Job Control -- + procedure Start_Job (This : in out Paged_Device; Count : in Natural := 0) is @@ -398,6 +413,8 @@ package body FLTK.Devices.Surface.Paged is + -- Spacing and Orientation -- + procedure Get_Margins (This : in Paged_Device; Left, Top, Right, Bottom : out Integer) is @@ -489,6 +506,8 @@ package body FLTK.Devices.Surface.Paged is + -- Printing -- + procedure Print_Widget (This : in out Paged_Device; Item : in FLTK.Widgets.Widget'Class; diff --git a/body/fltk-devices-surface.adb b/body/fltk-devices-surface.adb index a6ef6cc..b438f68 100644 --- a/body/fltk-devices-surface.adb +++ b/body/fltk-devices-surface.adb @@ -11,6 +11,8 @@ package body FLTK.Devices.Surface is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_surface_device (G : in Storage.Integer_Address) return Storage.Integer_Address; @@ -25,6 +27,8 @@ package body FLTK.Devices.Surface is + -- Surfaces -- + procedure fl_surface_device_set_current (S : in Storage.Integer_Address); pragma Import (C, fl_surface_device_set_current, "fl_surface_device_set_current"); @@ -38,6 +42,8 @@ package body FLTK.Devices.Surface is + -- Drivers -- + function fl_surface_device_get_driver (S : in Storage.Integer_Address) return Storage.Integer_Address; @@ -112,6 +118,8 @@ package body FLTK.Devices.Surface is -- API Subprograms -- ----------------------- + -- Surfaces -- + function Get_Current return Surface_Device_Reference is begin @@ -136,6 +144,8 @@ package body FLTK.Devices.Surface is + -- Drivers -- + function Has_Driver (This : in Surface_Device) return Boolean is diff --git a/body/fltk-draw.adb b/body/fltk-draw.adb index 8e98a7f..38ccb80 100644 --- a/body/fltk-draw.adb +++ b/body/fltk-draw.adb @@ -8,12 +8,13 @@ with Ada.Assertions, Ada.Unchecked_Deallocation, + FLTK.Pixmap_Marshal, + Interfaces.C.Pointers, Interfaces.C.Strings; use type - Interfaces.C.int, - Interfaces.C.size_t; + Interfaces.C.int; package body FLTK.Draw is @@ -21,6 +22,13 @@ package body FLTK.Draw is package Chk renames Ada.Assertions; + -- Oh no... Anyway, this is just used for Expand_Text. + package Char_Pointers is new Interfaces.C.Pointers + (Index => Interfaces.C.size_t, + Element => Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + @@ -28,9 +36,7 @@ package body FLTK.Draw is -- Functions From C -- ------------------------ - procedure fl_draw_reset_spot; - pragma Import (C, fl_draw_reset_spot, "fl_draw_reset_spot"); - pragma Inline (fl_draw_reset_spot); + -- No Documentation -- procedure fl_draw_set_spot (F, S : in Interfaces.C.int; @@ -47,6 +53,8 @@ package body FLTK.Draw is + -- Utility -- + function fl_draw_can_do_alpha_blending return Interfaces.C.int; pragma Import (C, fl_draw_can_do_alpha_blending, "fl_draw_can_do_alpha_blending"); @@ -61,6 +69,8 @@ package body FLTK.Draw is + -- Charset Conversion -- + function fl_draw_latin1_to_local (T : in Interfaces.C.char_array; N : in Interfaces.C.int) @@ -92,6 +102,8 @@ package body FLTK.Draw is + -- Clipping -- + function fl_draw_clip_box (X, Y, W, H : in Interfaces.C.int; BX, BY, BW, BH : out Interfaces.C.int) @@ -105,29 +117,15 @@ package body FLTK.Draw is pragma Import (C, fl_draw_not_clipped, "fl_draw_not_clipped"); pragma Inline (fl_draw_not_clipped); - procedure fl_draw_pop_clip; - pragma Import (C, fl_draw_pop_clip, "fl_draw_pop_clip"); - pragma Inline (fl_draw_pop_clip); - procedure fl_draw_push_clip (X, Y, W, H : in Interfaces.C.int); pragma Import (C, fl_draw_push_clip, "fl_draw_push_clip"); pragma Inline (fl_draw_push_clip); - procedure fl_draw_push_no_clip; - pragma Import (C, fl_draw_push_no_clip, "fl_draw_push_no_clip"); - pragma Inline (fl_draw_push_no_clip); - - procedure fl_draw_restore_clip; - pragma Import (C, fl_draw_restore_clip, "fl_draw_restore_clip"); - pragma Inline (fl_draw_restore_clip); - - procedure fl_draw_overlay_clear; - pragma Import (C, fl_draw_overlay_clear, "fl_draw_overlay_clear"); - pragma Inline (fl_draw_overlay_clear); + -- Overlay -- procedure fl_draw_overlay_rect (X, Y, W, H : in Interfaces.C.int); @@ -137,6 +135,8 @@ package body FLTK.Draw is + -- Settings -- + function fl_draw_get_color return Interfaces.C.unsigned; pragma Import (C, fl_draw_get_color, "fl_draw_get_color"); @@ -206,19 +206,13 @@ package body FLTK.Draw is + -- Matrix Operations -- + procedure fl_draw_mult_matrix (A, B, C, D, X, Y : in Interfaces.C.double); pragma Import (C, fl_draw_mult_matrix, "fl_draw_mult_matrix"); pragma Inline (fl_draw_mult_matrix); - procedure fl_draw_pop_matrix; - pragma Import (C, fl_draw_pop_matrix, "fl_draw_pop_matrix"); - pragma Inline (fl_draw_pop_matrix); - - procedure fl_draw_push_matrix; - pragma Import (C, fl_draw_push_matrix, "fl_draw_push_matrix"); - pragma Inline (fl_draw_push_matrix); - procedure fl_draw_rotate (D : in Interfaces.C.double); pragma Import (C, fl_draw_rotate, "fl_draw_rotate"); @@ -276,6 +270,8 @@ package body FLTK.Draw is + -- Image Drawing -- + procedure fl_draw_draw_image (Buf : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int; @@ -302,6 +298,14 @@ package body FLTK.Draw is pragma Import (C, fl_draw_draw_image_mono2, "fl_draw_draw_image_mono2"); pragma Inline (fl_draw_draw_image_mono2); + function fl_draw_draw_pixmap + (Data : in Storage.Integer_Address; + X, Y : in Interfaces.C.int; + H : in Interfaces.C.unsigned) + return Interfaces.C.int; + pragma Import (C, fl_draw_draw_pixmap, "fl_draw_draw_pixmap"); + pragma Inline (fl_draw_draw_pixmap); + function fl_draw_read_image (Buf : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int; @@ -313,6 +317,8 @@ package body FLTK.Draw is + -- Special Drawing -- + function fl_draw_add_symbol (Name : in Interfaces.C.char_array; Drawit : in Storage.Integer_Address; @@ -395,6 +401,19 @@ package body FLTK.Draw is pragma Import (C, fl_draw_text_extents, "fl_draw_text_extents"); pragma Inline (fl_draw_text_extents); + -- This function in particular is such bullshit. + function fl_draw_expand_text + (Str : in Interfaces.C.char_array; + Buf : out Interfaces.C.Strings.chars_ptr; + Max_Buf : in Interfaces.C.int; + Max_W : in Interfaces.C.double; + N : out Interfaces.C.int; + Width : out Interfaces.C.double; + Wrap, Sym : in Interfaces.C.int) + return Char_Pointers.Pointer; + pragma Import (C, fl_draw_expand_text, "fl_draw_expand_text"); + pragma Inline (fl_draw_expand_text); + function fl_draw_width (Str : in Interfaces.C.char_array; N : in Interfaces.C.int) @@ -411,28 +430,7 @@ package body FLTK.Draw is - procedure fl_draw_begin_complex_polygon; - pragma Import (C, fl_draw_begin_complex_polygon, "fl_draw_begin_complex_polygon"); - pragma Inline (fl_draw_begin_complex_polygon); - - procedure fl_draw_begin_line; - pragma Import (C, fl_draw_begin_line, "fl_draw_begin_line"); - pragma Inline (fl_draw_begin_line); - - procedure fl_draw_begin_loop; - pragma Import (C, fl_draw_begin_loop, "fl_draw_begin_loop"); - pragma Inline (fl_draw_begin_loop); - - procedure fl_draw_begin_points; - pragma Import (C, fl_draw_begin_points, "fl_draw_begin_points"); - pragma Inline (fl_draw_begin_points); - - procedure fl_draw_begin_polygon; - pragma Import (C, fl_draw_begin_polygon, "fl_draw_begin_polygon"); - pragma Inline (fl_draw_begin_polygon); - - - + -- Manual Drawing -- procedure fl_draw_arc (X, Y, R, Start, Finish : in Interfaces.C.double); @@ -471,10 +469,6 @@ package body FLTK.Draw is pragma Import (C, fl_draw_frame, "fl_draw_frame"); pragma Inline (fl_draw_frame); - procedure fl_draw_gap; - pragma Import (C, fl_draw_gap, "fl_draw_gap"); - pragma Inline (fl_draw_gap); - procedure fl_draw_line (X0, Y0 : in Interfaces.C.int; X1, Y1 : in Interfaces.C.int); @@ -590,38 +584,11 @@ package body FLTK.Draw is - procedure fl_draw_end_complex_polygon; - pragma Import (C, fl_draw_end_complex_polygon, "fl_draw_end_complex_polygon"); - pragma Inline (fl_draw_end_complex_polygon); - - procedure fl_draw_end_line; - pragma Import (C, fl_draw_end_line, "fl_draw_end_line"); - pragma Inline (fl_draw_end_line); - - procedure fl_draw_end_loop; - pragma Import (C, fl_draw_end_loop, "fl_draw_end_loop"); - pragma Inline (fl_draw_end_loop); - - procedure fl_draw_end_points; - pragma Import (C, fl_draw_end_points, "fl_draw_end_points"); - pragma Inline (fl_draw_end_points); - - procedure fl_draw_end_polygon; - pragma Import (C, fl_draw_end_polygon, "fl_draw_end_polygon"); - pragma Inline (fl_draw_end_polygon); - - - + ----------------------- + -- API Subprograms -- + ----------------------- - ------------------------ -- No Documentation -- - ------------------------ - - procedure Reset_Spot is - begin - fl_draw_reset_spot; - end Reset_Spot; - procedure Set_Spot (X, Y, W, H : in Integer; @@ -669,14 +636,12 @@ package body FLTK.Draw is - --------------- -- Utility -- - --------------- 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; @@ -685,7 +650,9 @@ package body FLTK.Draw is return False; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_can_do_alpha_blending returned unexpected value of " & + Interfaces.C.int'Image (Result); end Can_Do_Alpha_Blending; @@ -694,15 +661,13 @@ 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; - -------------------------- -- Charset Conversion -- - -------------------------- function Latin1_To_Local (From : in String) @@ -742,9 +707,7 @@ package body FLTK.Draw is - ---------------- -- Clipping -- - ---------------- function Clip_Box (X, Y, W, H : in Integer; @@ -752,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), @@ -779,12 +742,6 @@ package body FLTK.Draw is end Clip_Intersects; - procedure Pop_Clip is - begin - fl_draw_pop_clip; - end Pop_Clip; - - procedure Push_Clip (X, Y, W, H : in Integer) is begin @@ -796,29 +753,9 @@ package body FLTK.Draw is end Push_Clip; - procedure Push_No_Clip is - begin - fl_draw_push_no_clip; - end Push_No_Clip; - - procedure Restore_Clip is - begin - fl_draw_restore_clip; - end Restore_Clip; - - - - --------------- -- Overlay -- - --------------- - - procedure Overlay_Clear is - begin - fl_draw_overlay_clear; - end Overlay_Clear; - procedure Overlay_Rect (X, Y, W, H : in Integer) is @@ -833,9 +770,7 @@ package body FLTK.Draw is - ---------------- -- Settings -- - ---------------- function Get_Color return Color is @@ -958,9 +893,7 @@ package body FLTK.Draw is - ------------------------- -- Matrix Operations -- - ------------------------- procedure Mult_Matrix (A, B, C, D, X, Y : in Long_Float) is @@ -975,18 +908,6 @@ package body FLTK.Draw is end Mult_Matrix; - procedure Pop_Matrix is - begin - fl_draw_pop_matrix; - end Pop_Matrix; - - - procedure Push_Matrix is - begin - fl_draw_push_matrix; - end Push_Matrix; - - procedure Rotate (Angle : in Long_Float) is begin @@ -1079,20 +1000,18 @@ package body FLTK.Draw is - --------------------- -- Image Drawing -- - --------------------- procedure Draw_Image (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); @@ -1105,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), @@ -1118,11 +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 + (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 @@ -1150,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); @@ -1168,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), @@ -1181,11 +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 + (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 @@ -1209,41 +1144,73 @@ package body FLTK.Draw is end Draw_Image_Mono; + procedure Draw_Pixmap + (Values : in FLTK.Images.Pixmaps.Header; + Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; + Pixels : in FLTK.Images.Pixmaps.Pixmap_Data; + X, Y : in Integer; + Tone : in Color := Grey0_Color) + is + C_Data : Pixmap_Marshal.chars_ptr_array_access := + Pixmap_Marshal.Marshal_Data (Values, Colors, Pixels); + 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 (Tone)); + begin + pragma Assert (Result /= 0); + Pixmap_Marshal.Free_Recursive (C_Data); + exception + when Chk.Assertion_Error => + Pixmap_Marshal.Free_Recursive (C_Data); + raise Draw_Error with "fl_draw_pixmap could not decode supplied XPM pixmap data"; + end Draw_Pixmap; + + function Read_Image (X, Y, W, H : in Integer; 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; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_read_image returned unexpected address value that did not " & + "correspond to supplied address value"; end Read_Image; - ----------------------- -- Special Drawing -- - ----------------------- procedure Add_Symbol (Text : in String; 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)); @@ -1254,7 +1221,9 @@ package body FLTK.Draw is pragma Assert (Ret_Val = 1); end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_add_symbol returned unexpected int value of " & + Interfaces.C.int'Image (Ret_Val); end Add_Symbol; procedure Draw_Text @@ -1310,6 +1279,12 @@ package body FLTK.Draw is procedure Draw_Text_Hook (Ptr : in Storage.Integer_Address; + N, X0, Y0 : in Interfaces.C.int); + + pragma Convention (C, Draw_Text_Hook); + + procedure Draw_Text_Hook + (Ptr : in Storage.Integer_Address; N, X0, Y0 : in Interfaces.C.int) is Data : String (1 .. Integer (N)); @@ -1319,7 +1294,6 @@ package body FLTK.Draw is Text_Func_Ptr (Integer (X0), Integer (Y0), Data); end Draw_Text_Hook; - procedure Draw_Text (X, Y, W, H : in Integer; Text : in String; @@ -1409,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), @@ -1423,7 +1397,9 @@ package body FLTK.Draw is pragma Assert (Ret_Val = 1); end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_draw_symbol returned unexpected int value of " & + Interfaces.C.int'Image (Ret_Val); end Draw_Symbol; @@ -1446,13 +1422,23 @@ package body FLTK.Draw is procedure Scroll_Hook - (Ptr : in Area_Draw_Function; - X, Y, W, H : in Interfaces.C.int) is + (Ptr : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + + pragma Convention (C, Scroll_Hook); + + procedure Scroll_Hook + (Ptr : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int) + is + procedure my_area_draw + (X, Y, W, H : in Integer); + for my_area_draw'Address use Storage.To_Address (Ptr); + pragma Import (Ada, my_area_draw); begin - Ptr.all (Integer (X), Integer (Y), Integer (W), Integer (H)); + my_area_draw (Integer (X), Integer (Y), Integer (W), Integer (H)); end Scroll_Hook; - procedure Scroll (X, Y, W, H : in Integer; DX, DY : in Integer; @@ -1490,6 +1476,32 @@ package body FLTK.Draw is end Text_Extents; + function Expand_Text + (Text : in String; + Max_Width : in Long_Float; + Width : out Long_Float; + Last : out Natural; + Wrap : in Boolean; + Symbols : in Boolean := False) + return String + is + Buffer : Interfaces.C.Strings.chars_ptr; + Length : Interfaces.C.int; + Temp : Interfaces.C.char_array := Interfaces.C.To_C (Text); + Result : constant Char_Pointers.Pointer := fl_draw_expand_text + (Temp, Buffer, 0, + Interfaces.C.double (Max_Width), + Length, + Interfaces.C.double (Width), + Boolean'Pos (Wrap), + Boolean'Pos (Symbols)); + use type Char_Pointers.Pointer; + begin + Last := Natural (Result - Temp (Temp'First)'Unchecked_Access); + return Interfaces.C.Strings.Value (Buffer, Interfaces.C.size_t (Length)); + end Expand_Text; + + function Width (Text : in String) return Long_Float is @@ -1524,35 +1536,7 @@ package body FLTK.Draw is - ---------------------- -- Manual Drawing -- - ---------------------- - - procedure Begin_Complex_Polygon is - begin - fl_draw_begin_complex_polygon; - end Begin_Complex_Polygon; - - procedure Begin_Line is - begin - fl_draw_begin_line; - end Begin_Line; - - procedure Begin_Loop is - begin - fl_draw_begin_loop; - end Begin_Loop; - - procedure Begin_Points is - begin - fl_draw_begin_points; - end Begin_Points; - - procedure Begin_Polygon is - begin - fl_draw_begin_polygon; - end Begin_Polygon; - procedure Arc (X, Y, R, Start, Finish : in Long_Float) is @@ -1634,12 +1618,6 @@ package body FLTK.Draw is end Frame; - procedure Gap is - begin - fl_draw_gap; - end Gap; - - procedure Line (X0, Y0 : in Integer; X1, Y1 : in Integer) is @@ -1866,32 +1844,6 @@ package body FLTK.Draw is end Why_Ecks_Line; - procedure End_Complex_Polygon is - begin - fl_draw_end_complex_polygon; - end End_Complex_Polygon; - - procedure End_Line is - begin - fl_draw_end_line; - end End_Line; - - procedure End_Loop is - begin - fl_draw_end_loop; - end End_Loop; - - procedure End_Points is - begin - fl_draw_end_points; - end End_Points; - - procedure End_Polygon is - begin - fl_draw_end_polygon; - end End_Polygon; - - end FLTK.Draw; diff --git a/body/fltk-environment.adb b/body/fltk-environment.adb index 22cf676..c510e26 100644 --- a/body/fltk-environment.adb +++ b/body/fltk-environment.adb @@ -43,6 +43,8 @@ package body FLTK.Environment is -- Functions From C -- ------------------------ + -- Static -- + function fl_preferences_new_uuid return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_preferences_new_uuid, "fl_preferences_new_uuid"); @@ -51,6 +53,8 @@ package body FLTK.Environment is + -- Allocation -- + function new_fl_pref_database_path (P, V, A : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -77,6 +81,8 @@ package body FLTK.Environment is + -- More Allocation -- + function new_fl_pref_group_copy (D : in Storage.Integer_Address) return Storage.Integer_Address; @@ -111,15 +117,17 @@ package body FLTK.Environment is + -- Disk Activity -- + procedure fl_preferences_flush (E : in Storage.Integer_Address); pragma Import (C, fl_preferences_flush, "fl_preferences_flush"); 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); @@ -127,6 +135,8 @@ package body FLTK.Environment is + -- Deletion -- + function fl_preferences_deleteentry (E : in Storage.Integer_Address; K : in Interfaces.C.char_array) @@ -162,6 +172,8 @@ package body FLTK.Environment is + -- Key Values -- + function fl_preferences_entries (E : in Storage.Integer_Address) return Interfaces.C.int; @@ -192,6 +204,8 @@ package body FLTK.Environment is + -- Groups -- + function fl_preferences_groups (P : in Storage.Integer_Address) return Interfaces.C.int; @@ -215,6 +229,8 @@ package body FLTK.Environment is + -- Names -- + function fl_preferences_name (P : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -230,6 +246,8 @@ package body FLTK.Environment is + -- Retrieval -- + function fl_preferences_get_int (E : in Storage.Integer_Address; K : in Interfaces.C.char_array; @@ -267,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); @@ -303,6 +321,8 @@ package body FLTK.Environment is + -- Storage -- + function fl_preferences_set_int (E : in Storage.Integer_Address; K : in Interfaces.C.char_array; @@ -392,15 +412,15 @@ package body FLTK.Environment is return User; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Constraint_Error; end To_Scope; - ----------------------------------- - -- Controlled Type Subprograms -- - ----------------------------------- + ------------------- + -- Destructors -- + ------------------- procedure Finalize (This : in out Database) is @@ -427,20 +447,9 @@ package body FLTK.Environment is - ----------------------- - -- Preferences API -- - ----------------------- - - function New_UUID - return String - is - Text : Interfaces.C.Strings.chars_ptr := fl_preferences_new_uuid; - begin - return Interfaces.C.Strings.Value (Text); - end New_UUID; - - - + -------------------- + -- Constructors -- + -------------------- package body Forge is @@ -534,6 +543,25 @@ package body FLTK.Environment is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Static -- + + function New_UUID + return String + is + Text : constant Interfaces.C.Strings.chars_ptr := fl_preferences_new_uuid; + begin + return Interfaces.C.Strings.Value (Text); + end New_UUID; + + + + + -- Disk Activity -- + procedure Flush (This : in Database) is begin @@ -561,6 +589,8 @@ package body FLTK.Environment is + -- Deletion -- + procedure Delete_Entry (This : in out Pref_Group; Key : in String) is @@ -610,6 +640,8 @@ package body FLTK.Environment is + -- Key Values -- + function Number_Of_Entries (This : in Pref_Group) return Natural is @@ -623,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? @@ -655,6 +687,8 @@ package body FLTK.Environment is + -- Groups -- + function Number_Of_Groups (This : in Pref_Group) return Natural is @@ -668,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? @@ -691,11 +725,13 @@ package body FLTK.Environment is + -- Names -- + function At_Name (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 ""; @@ -709,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 ""; @@ -721,6 +757,8 @@ package body FLTK.Environment is + -- Retrieval -- + function Get (This : in Pref_Group; Key : in String) @@ -745,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, @@ -781,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, @@ -817,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, @@ -834,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, @@ -846,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; @@ -859,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, @@ -868,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; @@ -882,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, @@ -904,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, @@ -916,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; @@ -941,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; @@ -967,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; @@ -975,6 +1013,8 @@ package body FLTK.Environment is + -- Storage -- + procedure Set (This : in out Pref_Group; Key : in String; @@ -1087,3 +1127,4 @@ package body FLTK.Environment is end FLTK.Environment; + diff --git a/body/fltk-errors.adb b/body/fltk-errors.adb index ef31002..32cf2d5 100644 --- a/body/fltk-errors.adb +++ b/body/fltk-errors.adb @@ -12,6 +12,10 @@ with package body FLTK.Errors is + ------------------------ + -- Functions From C -- + ------------------------ + procedure fl_error_default_warning (M : in Interfaces.C.char_array); pragma Import (C, fl_error_default_warning, "fl_error_default_warning"); @@ -34,6 +38,10 @@ package body FLTK.Errors is + ------------- + -- Hooks -- + ------------- + procedure Warning_Hook (C_Mess : in Interfaces.C.Strings.chars_ptr); pragma Export (C, Warning_Hook, "error_warning_hook"); @@ -69,6 +77,10 @@ package body FLTK.Errors is + ----------------------- + -- API Subprograms -- + ----------------------- + procedure Default_Warning (Message : in String) is begin diff --git a/body/fltk-event.adb b/body/fltk-event.adb deleted file mode 100644 index 4521fc2..0000000 --- a/body/fltk-event.adb +++ /dev/null @@ -1,696 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Ada.Assertions, - Interfaces.C.Strings; - -use type - - Interfaces.C.int, - Interfaces.C.Strings.chars_ptr; - - -package body FLTK.Event is - - - package Chk renames Ada.Assertions; - - - - - ------------------------ - -- Functions From C -- - ------------------------ - - procedure fl_event_add_handler - (F : in Storage.Integer_Address); - pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); - pragma Inline (fl_event_add_handler); - - procedure fl_event_set_event_dispatch - (F : in Storage.Integer_Address); - pragma Import (C, fl_event_set_event_dispatch, "fl_event_set_event_dispatch"); - pragma Inline (fl_event_set_event_dispatch); - - -- actually handle_ but can't have an underscore on the end of an identifier - function fl_event_handle - (E : in Interfaces.C.int; - W : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_event_handle, "fl_event_handle"); - pragma Inline (fl_event_handle); - - - - - function fl_event_get_grab - return Storage.Integer_Address; - pragma Import (C, fl_event_get_grab, "fl_event_get_grab"); - pragma Inline (fl_event_get_grab); - - procedure fl_event_set_grab - (T : in Storage.Integer_Address); - pragma Import (C, fl_event_set_grab, "fl_event_set_grab"); - pragma Inline (fl_event_set_grab); - - function fl_event_get_pushed - return Storage.Integer_Address; - pragma Import (C, fl_event_get_pushed, "fl_event_get_pushed"); - pragma Inline (fl_event_get_pushed); - - procedure fl_event_set_pushed - (T : in Storage.Integer_Address); - pragma Import (C, fl_event_set_pushed, "fl_event_set_pushed"); - pragma Inline (fl_event_set_pushed); - - function fl_event_get_belowmouse - return Storage.Integer_Address; - pragma Import (C, fl_event_get_belowmouse, "fl_event_get_belowmouse"); - pragma Inline (fl_event_get_belowmouse); - - procedure fl_event_set_belowmouse - (T : in Storage.Integer_Address); - pragma Import (C, fl_event_set_belowmouse, "fl_event_set_belowmouse"); - pragma Inline (fl_event_set_belowmouse); - - function fl_event_get_focus - return Storage.Integer_Address; - pragma Import (C, fl_event_get_focus, "fl_event_get_focus"); - pragma Inline (fl_event_get_focus); - - procedure fl_event_set_focus - (To : in Storage.Integer_Address); - pragma Import (C, fl_event_set_focus, "fl_event_set_focus"); - pragma Inline (fl_event_set_focus); - - - - - function fl_event_compose - (D : out Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_compose, "fl_event_compose"); - pragma Inline (fl_event_compose); - - procedure fl_event_compose_reset; - pragma Import (C, fl_event_compose_reset, "fl_event_compose_reset"); - pragma Inline (fl_event_compose_reset); - - function fl_event_text - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_event_text, "fl_event_text"); - pragma Inline (fl_event_text); - - function fl_event_length - return Interfaces.C.int; - pragma Import (C, fl_event_length, "fl_event_length"); - pragma Inline (fl_event_length); - - - - - function fl_event_get - return Interfaces.C.int; - pragma Import (C, fl_event_get, "fl_event_get"); - pragma Inline (fl_event_get); - - function fl_event_state - return Interfaces.C.int; - pragma Import (C, fl_event_state, "fl_event_state"); - pragma Inline (fl_event_state); - - function fl_event_check_state - (S : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_check_state, "fl_event_check_state"); - pragma Inline (fl_event_check_state); - - - - - function fl_event_x - return Interfaces.C.int; - pragma Import (C, fl_event_x, "fl_event_x"); - pragma Inline (fl_event_x); - - function fl_event_x_root - return Interfaces.C.int; - pragma Import (C, fl_event_x_root, "fl_event_x_root"); - pragma Inline (fl_event_x_root); - - function fl_event_y - return Interfaces.C.int; - pragma Import (C, fl_event_y, "fl_event_y"); - pragma Inline (fl_event_y); - - function fl_event_y_root - return Interfaces.C.int; - pragma Import (C, fl_event_y_root, "fl_event_y_root"); - pragma Inline (fl_event_y_root); - - function fl_event_dx - return Interfaces.C.int; - pragma Import (C, fl_event_dx, "fl_event_dx"); - pragma Inline (fl_event_dx); - - function fl_event_dy - return Interfaces.C.int; - pragma Import (C, fl_event_dy, "fl_event_dy"); - pragma Inline (fl_event_dy); - - procedure fl_event_get_mouse - (X, Y : out Interfaces.C.int); - pragma Import (C, fl_event_get_mouse, "fl_event_get_mouse"); - pragma Inline (fl_event_get_mouse); - - function fl_event_is_click - return Interfaces.C.int; - pragma Import (C, fl_event_is_click, "fl_event_is_click"); - pragma Inline (fl_event_is_click); - - function fl_event_is_clicks - return Interfaces.C.int; - pragma Import (C, fl_event_is_clicks, "fl_event_is_clicks"); - pragma Inline (fl_event_is_clicks); - - procedure fl_event_set_clicks - (C : in Interfaces.C.int); - pragma Import (C, fl_event_set_clicks, "fl_event_set_clicks"); - pragma Inline (fl_event_set_clicks); - - function fl_event_button - return Interfaces.C.int; - pragma Import (C, fl_event_button, "fl_event_button"); - pragma Inline (fl_event_button); - - function fl_event_button1 - return Interfaces.C.int; - pragma Import (C, fl_event_button1, "fl_event_button1"); - pragma Inline (fl_event_button1); - - function fl_event_button2 - return Interfaces.C.int; - pragma Import (C, fl_event_button2, "fl_event_button2"); - pragma Inline (fl_event_button2); - - function fl_event_button3 - return Interfaces.C.int; - pragma Import (C, fl_event_button3, "fl_event_button3"); - pragma Inline (fl_event_button3); - - function fl_event_inside - (X, Y, W, H : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_inside, "fl_event_inside"); - pragma Inline (fl_event_inside); - - - - - function fl_event_key - return Interfaces.C.int; - pragma Import (C, fl_event_key, "fl_event_key"); - pragma Inline (fl_event_key); - - function fl_event_original_key - return Interfaces.C.int; - pragma Import (C, fl_event_original_key, "fl_event_original_key"); - pragma Inline (fl_event_original_key); - - function fl_event_key_during - (K : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_key_during, "fl_event_key_during"); - pragma Inline (fl_event_key_during); - - function fl_event_get_key - (K : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_get_key, "fl_event_get_key"); - pragma Inline (fl_event_get_key); - - function fl_event_ctrl - return Interfaces.C.int; - pragma Import (C, fl_event_ctrl, "fl_event_ctrl"); - pragma Inline (fl_event_ctrl); - - function fl_event_alt - return Interfaces.C.int; - pragma Import (C, fl_event_alt, "fl_event_alt"); - pragma Inline (fl_event_alt); - - function fl_event_command - return Interfaces.C.int; - pragma Import (C, fl_event_command, "fl_event_command"); - pragma Inline (fl_event_command); - - function fl_event_shift - return Interfaces.C.int; - pragma Import (C, fl_event_shift, "fl_event_shift"); - pragma Inline (fl_event_shift); - - - - - function Event_Handler_Hook - (Num : in Interfaces.C.int) - return Interfaces.C.int - is - Ret_Val : Event_Outcome; - begin - for Func of reverse Handlers loop - Ret_Val := Func (Event_Kind'Val (Num)); - if Ret_Val /= Not_Handled then - return Event_Outcome'Pos (Ret_Val); - end if; - end loop; - return Event_Outcome'Pos (Not_Handled); - end Event_Handler_Hook; - - - -- function Dispatch_Hook - -- (Num : in Interfaces.C.int; - -- Ptr : in Storage.Integer_Address) - -- return Interfaces.C.int - -- is - -- Ret_Val : Event_Outcome; - -- Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; - -- begin - -- if Ptr /= Null_Pointer then - -- Actual_Window := Window_Convert.To_Pointer - -- (Storage.To_Address (fl_widget_get_user_data (Ptr))); - -- end if; - -- if Current_Dispatch = null then - -- Ret_Val := Default_Dispatch (Event_Kind'Val (Num), Actual_Window); - -- else - -- Ret_Val := Current_Dispatch (Event_Kind'Val (Num), Actual_Window); - -- end if; - -- return Event_Outcome'Pos (Ret_Val); - -- end Dispatch_Hook; - - - - - procedure Add_Handler - (Func : in Event_Handler) is - begin - Handlers.Append (Func); - end Add_Handler; - - - procedure Remove_Handler - (Func : in Event_Handler) is - begin - for I in reverse Handlers.First_Index .. Handlers.Last_Index loop - if Handlers (I) = Func then - Handlers.Delete (I); - return; - end if; - end loop; - end Remove_Handler; - - - -- function Get_Dispatch - -- return Event_Dispatch is - -- begin - -- if Current_Dispatch = null then - -- return Default_Dispatch'Access; - -- else - -- return Current_Dispatch; - -- end if; - -- end Get_Dispatch; - - - -- procedure Set_Dispatch - -- (Func : in Event_Dispatch) is - -- begin - -- Current_Dispatch := Func; - -- end Set_Dispatch; - - - -- function Default_Dispatch - -- (Event : in Event_Kind; - -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) - -- return Event_Outcome is - -- begin - -- if Win = null then - -- return Event_Outcome'Val (fl_event_handle - -- (Event_Kind'Pos (Event), Null_Pointer)); - -- else - -- return Event_Outcome'Val (fl_event_handle - -- (Event_Kind'Pos (Event), - -- Wrapper (Win.all).Void_Ptr)); - -- end if; - -- end Default_Dispatch; - - - - - function Get_Grab - return access FLTK.Widgets.Groups.Windows.Window'Class - is - Grab_Ptr : Storage.Integer_Address := fl_event_get_grab; - Actual_Grab : access FLTK.Widgets.Groups.Windows.Window'Class; - begin - if Grab_Ptr /= Null_Pointer then - Grab_Ptr := fl_widget_get_user_data (Grab_Ptr); - pragma Assert (Grab_Ptr /= Null_Pointer); - Actual_Grab := Window_Convert.To_Pointer (Storage.To_Address (Grab_Ptr)); - end if; - return Actual_Grab; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end Get_Grab; - - - procedure Set_Grab - (To : in FLTK.Widgets.Groups.Windows.Window'Class) is - begin - fl_event_set_grab (Wrapper (To).Void_Ptr); - end Set_Grab; - - - procedure Release_Grab is - begin - fl_event_set_grab (Null_Pointer); - end Release_Grab; - - - function Get_Pushed - return access FLTK.Widgets.Widget'Class - is - Pushed_Ptr : Storage.Integer_Address := fl_event_get_pushed; - Actual_Pushed : access FLTK.Widgets.Widget'Class; - begin - if Pushed_Ptr /= Null_Pointer then - Pushed_Ptr := fl_widget_get_user_data (Pushed_Ptr); - pragma Assert (Pushed_Ptr /= Null_Pointer); - Actual_Pushed := Widget_Convert.To_Pointer (Storage.To_Address (Pushed_Ptr)); - end if; - return Actual_Pushed; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end Get_Pushed; - - - procedure Set_Pushed - (To : in FLTK.Widgets.Widget'Class) is - begin - fl_event_set_pushed (Wrapper (To).Void_Ptr); - end Set_Pushed; - - - function Get_Below_Mouse - return access FLTK.Widgets.Widget'Class - is - Below_Ptr : Storage.Integer_Address := fl_event_get_belowmouse; - Actual_Below : access FLTK.Widgets.Widget'Class; - begin - if Below_Ptr /= Null_Pointer then - Below_Ptr := fl_widget_get_user_data (Below_Ptr); - pragma Assert (Below_Ptr /= Null_Pointer); - Actual_Below := Widget_Convert.To_Pointer (Storage.To_Address (Below_Ptr)); - end if; - return Actual_Below; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end Get_Below_Mouse; - - - procedure Set_Below_Mouse - (To : in FLTK.Widgets.Widget'Class) is - begin - fl_event_set_belowmouse (Wrapper (To).Void_Ptr); - end Set_Below_Mouse; - - - function Get_Focus - return access FLTK.Widgets.Widget'Class - is - Focus_Ptr : Storage.Integer_Address := fl_event_get_focus; - Actual_Focus : access FLTK.Widgets.Widget'Class; - begin - if Focus_Ptr /= Null_Pointer then - Focus_Ptr := fl_widget_get_user_data (Focus_Ptr); - pragma Assert (Focus_Ptr /= Null_Pointer); - Actual_Focus := Widget_Convert.To_Pointer (Storage.To_Address (Focus_Ptr)); - end if; - return Actual_Focus; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end Get_Focus; - - - procedure Set_Focus - (To : in FLTK.Widgets.Widget'Class) is - begin - fl_event_set_focus (Wrapper (To).Void_Ptr); - end Set_Focus; - - - - - function Compose - (Del : out Natural) - return Boolean is - begin - return fl_event_compose (Interfaces.C.int (Del)) /= 0; - end Compose; - - procedure Compose_Reset is - begin - fl_event_compose_reset; - end Compose_Reset; - - - function Text - return String - is - Str : Interfaces.C.Strings.chars_ptr := fl_event_text; - begin - if Str = Interfaces.C.Strings.Null_Ptr then - return ""; - else - return Interfaces.C.Strings.Value (Str, Interfaces.C.size_t (fl_event_length)); - end if; - end Text; - - - function Text_Length - return Natural is - begin - return Natural (fl_event_length); - end Text_Length; - - - - - function Last - return Event_Kind is - begin - return Event_Kind'Val (fl_event_get); - end Last; - - - function Last_Modifier - return Modifier is - begin - return To_Ada (fl_event_state); - end Last_Modifier; - - - function Last_Modifier - (Had : in Modifier) - return Boolean is - begin - return fl_event_check_state (To_C (Had)) /= 0; - end Last_Modifier; - - - - - function Mouse_X - return Integer is - begin - return Integer (fl_event_x); - end Mouse_X; - - - function Mouse_X_Root - return Integer is - begin - return Integer (fl_event_x_root); - end Mouse_X_Root; - - - function Mouse_Y - return Integer is - begin - return Integer (fl_event_y); - end Mouse_Y; - - - function Mouse_Y_Root - return Integer is - begin - return Integer (fl_event_y_root); - end Mouse_Y_Root; - - - - function Mouse_DX - return Integer is - begin - return Integer (fl_event_dx); - end Mouse_DX; - - - function Mouse_DY - return Integer is - begin - return Integer (fl_event_dy); - end Mouse_DY; - - - procedure Get_Mouse - (X, Y : out Integer) is - begin - fl_event_get_mouse (Interfaces.C.int (X), Interfaces.C.int (Y)); - end Get_Mouse; - - - function Is_Click - return Boolean is - begin - return fl_event_is_click /= 0; - end Is_Click; - - - function Is_Multi_Click - return Boolean is - begin - return fl_event_is_clicks /= 0; - end Is_Multi_Click; - - - procedure Set_Clicks - (To : in Natural) is - begin - fl_event_set_clicks (Interfaces.C.int (To)); - end Set_Clicks; - - - function Last_Button - return Mouse_Button is - begin - return Mouse_Button'Val (fl_event_button); - end Last_Button; - - - function Mouse_Left - return Boolean is - begin - return fl_event_button1 /= 0; - end Mouse_Left; - - - function Mouse_Middle - return Boolean is - begin - return fl_event_button2 /= 0; - end Mouse_Middle; - - - function Mouse_Right - return Boolean is - begin - return fl_event_button3 /= 0; - end Mouse_Right; - - - function Is_Inside - (X, Y, W, H : in Integer) - return Boolean is - begin - return fl_event_inside - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H)) /= 0; - end Is_Inside; - - - - - function Last_Key - return Keypress is - begin - return To_Ada (fl_event_key); - end Last_Key; - - - function Original_Last_Key - return Keypress is - begin - return To_Ada (fl_event_original_key); - end Original_Last_Key; - - - function Pressed_During - (Key : in Keypress) - return Boolean is - begin - return fl_event_key_during (To_C (Key)) /= 0; - end Pressed_During; - - - function Key_Now - (Key : in Keypress) - return Boolean is - begin - return fl_event_get_key (To_C (Key)) /= 0; - end Key_Now; - - - function Key_Ctrl - return Boolean is - begin - return fl_event_ctrl /= 0; - end Key_Ctrl; - - - function Key_Alt - return Boolean is - begin - return fl_event_alt /= 0; - end Key_Alt; - - - function Key_Command - return Boolean is - begin - return fl_event_command /= 0; - end Key_Command; - - - function Key_Shift - return Boolean is - begin - return fl_event_shift /= 0; - end Key_Shift; - - -begin - - - fl_event_add_handler (Storage.To_Integer (Event_Handler_Hook'Address)); - -- fl_event_set_event_dispatch (Storage.To_Integer (Dispatch_Hook'Address)); - - -end FLTK.Event; - diff --git a/body/fltk-events.adb b/body/fltk-events.adb new file mode 100644 index 0000000..7a5932f --- /dev/null +++ b/body/fltk-events.adb @@ -0,0 +1,1090 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Containers.Vectors, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Events is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Constants From C -- + ------------------------ + + fl_enum_button1 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button1, "fl_enum_button1"); + + fl_enum_button2 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button2, "fl_enum_button2"); + + fl_enum_button3 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button3, "fl_enum_button3"); + + fl_enum_button4 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button4, "fl_enum_button4"); + + fl_enum_button5 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button5, "fl_enum_button5"); + + fl_enum_left_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_left_mouse, "fl_enum_left_mouse"); + + fl_enum_middle_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_middle_mouse, "fl_enum_middle_mouse"); + + fl_enum_right_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_right_mouse, "fl_enum_right_mouse"); + + fl_enum_back_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_back_mouse, "fl_enum_back_mouse"); + + fl_enum_forward_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_forward_mouse, "fl_enum_forward_mouse"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Handlers -- + + procedure fl_event_add_handler + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); + pragma Inline (fl_event_add_handler); + + procedure fl_event_remove_handler + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_remove_handler, "fl_event_remove_handler"); + pragma Inline (fl_event_remove_handler); + + procedure fl_event_add_system_handler + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_event_add_system_handler, "fl_event_add_system_handler"); + pragma Inline (fl_event_add_system_handler); + + procedure fl_event_remove_system_handler + (H : in Storage.Integer_Address); + pragma Import (C, fl_event_remove_system_handler, "fl_event_remove_system_handler"); + pragma Inline (fl_event_remove_system_handler); + + + + + -- Dispatch -- + + procedure fl_event_set_dispatch + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_set_dispatch, "fl_event_set_dispatch"); + pragma Inline (fl_event_set_dispatch); + + function fl_event_handle_dispatch + (E : in Interfaces.C.int; + W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_handle_dispatch, "fl_event_handle_dispatch"); + pragma Inline (fl_event_handle_dispatch); + + function fl_event_handle + (E : in Interfaces.C.int; + W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_handle, "fl_event_handle"); + pragma Inline (fl_event_handle); + + + + + -- Receiving -- + + function fl_event_get_grab + return Storage.Integer_Address; + pragma Import (C, fl_event_get_grab, "fl_event_get_grab"); + pragma Inline (fl_event_get_grab); + + procedure fl_event_set_grab + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_grab, "fl_event_set_grab"); + pragma Inline (fl_event_set_grab); + + function fl_event_get_pushed + return Storage.Integer_Address; + pragma Import (C, fl_event_get_pushed, "fl_event_get_pushed"); + pragma Inline (fl_event_get_pushed); + + procedure fl_event_set_pushed + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_pushed, "fl_event_set_pushed"); + pragma Inline (fl_event_set_pushed); + + function fl_event_get_belowmouse + return Storage.Integer_Address; + pragma Import (C, fl_event_get_belowmouse, "fl_event_get_belowmouse"); + pragma Inline (fl_event_get_belowmouse); + + procedure fl_event_set_belowmouse + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_belowmouse, "fl_event_set_belowmouse"); + pragma Inline (fl_event_set_belowmouse); + + function fl_event_get_focus + return Storage.Integer_Address; + pragma Import (C, fl_event_get_focus, "fl_event_get_focus"); + pragma Inline (fl_event_get_focus); + + procedure fl_event_set_focus + (To : in Storage.Integer_Address); + pragma Import (C, fl_event_set_focus, "fl_event_set_focus"); + pragma Inline (fl_event_set_focus); + + function fl_event_get_visible_focus + return Interfaces.C.int; + pragma Import (C, fl_event_get_visible_focus, "fl_event_get_visible_focus"); + pragma Inline (fl_event_get_visible_focus); + + procedure fl_event_set_visible_focus + (T : in Interfaces.C.int); + pragma Import (C, fl_event_set_visible_focus, "fl_event_set_visible_focus"); + pragma Inline (fl_event_set_visible_focus); + + + + + -- Clipboard -- + + function fl_event_clipboard_text + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_clipboard_text, "fl_event_clipboard_text"); + pragma Inline (fl_event_clipboard_text); + + function fl_event_clipboard_type + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_clipboard_type, "fl_event_clipboard_type"); + pragma Inline (fl_event_clipboard_type); + + + + + -- Multikey -- + + function fl_event_compose + (D : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_compose, "fl_event_compose"); + pragma Inline (fl_event_compose); + + function fl_event_text + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_text, "fl_event_text"); + pragma Inline (fl_event_text); + + function fl_event_length + return Interfaces.C.int; + pragma Import (C, fl_event_length, "fl_event_length"); + pragma Inline (fl_event_length); + + function fl_event_test_shortcut + (S : in Interfaces.C.unsigned) + return Interfaces.C.int; + pragma Import (C, fl_event_test_shortcut, "fl_event_test_shortcut"); + pragma Inline (fl_event_test_shortcut); + + + + + -- Modifiers -- + + function fl_event_get + return Interfaces.C.int; + pragma Import (C, fl_event_get, "fl_event_get"); + pragma Inline (fl_event_get); + + function fl_event_state + return Interfaces.C.int; + pragma Import (C, fl_event_state, "fl_event_state"); + pragma Inline (fl_event_state); + + function fl_event_check_state + (S : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_check_state, "fl_event_check_state"); + pragma Inline (fl_event_check_state); + + + + + -- Mouse -- + + function fl_event_x + return Interfaces.C.int; + pragma Import (C, fl_event_x, "fl_event_x"); + pragma Inline (fl_event_x); + + function fl_event_x_root + return Interfaces.C.int; + pragma Import (C, fl_event_x_root, "fl_event_x_root"); + pragma Inline (fl_event_x_root); + + function fl_event_y + return Interfaces.C.int; + pragma Import (C, fl_event_y, "fl_event_y"); + pragma Inline (fl_event_y); + + function fl_event_y_root + return Interfaces.C.int; + pragma Import (C, fl_event_y_root, "fl_event_y_root"); + pragma Inline (fl_event_y_root); + + function fl_event_dx + return Interfaces.C.int; + pragma Import (C, fl_event_dx, "fl_event_dx"); + pragma Inline (fl_event_dx); + + function fl_event_dy + return Interfaces.C.int; + pragma Import (C, fl_event_dy, "fl_event_dy"); + pragma Inline (fl_event_dy); + + procedure fl_event_get_mouse + (X, Y : out Interfaces.C.int); + pragma Import (C, fl_event_get_mouse, "fl_event_get_mouse"); + pragma Inline (fl_event_get_mouse); + + function fl_event_is_click + return Interfaces.C.int; + pragma Import (C, fl_event_is_click, "fl_event_is_click"); + pragma Inline (fl_event_is_click); + + procedure fl_event_set_click + (C : in Interfaces.C.int); + pragma Import (C, fl_event_set_click, "fl_event_set_click"); + pragma Inline (fl_event_set_click); + + function fl_event_get_clicks + return Interfaces.C.int; + pragma Import (C, fl_event_get_clicks, "fl_event_get_clicks"); + pragma Inline (fl_event_get_clicks); + + procedure fl_event_set_clicks + (C : in Interfaces.C.int); + pragma Import (C, fl_event_set_clicks, "fl_event_set_clicks"); + pragma Inline (fl_event_set_clicks); + + function fl_event_button + return Interfaces.C.int; + pragma Import (C, fl_event_button, "fl_event_button"); + pragma Inline (fl_event_button); + + function fl_event_button1 + return Interfaces.C.int; + pragma Import (C, fl_event_button1, "fl_event_button1"); + pragma Inline (fl_event_button1); + + function fl_event_button2 + return Interfaces.C.int; + pragma Import (C, fl_event_button2, "fl_event_button2"); + pragma Inline (fl_event_button2); + + function fl_event_button3 + return Interfaces.C.int; + pragma Import (C, fl_event_button3, "fl_event_button3"); + pragma Inline (fl_event_button3); + + function fl_event_button4 + return Interfaces.C.int; + pragma Import (C, fl_event_button4, "fl_event_button4"); + pragma Inline (fl_event_button4); + + function fl_event_button5 + return Interfaces.C.int; + pragma Import (C, fl_event_button5, "fl_event_button5"); + pragma Inline (fl_event_button5); + + function fl_event_buttons + return Interfaces.C.int; + pragma Import (C, fl_event_buttons, "fl_event_buttons"); + pragma Inline (fl_event_buttons); + + function fl_event_inside2 + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_inside2, "fl_event_inside2"); + pragma Inline (fl_event_inside2); + + function fl_event_inside + (X, Y, W, H : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_inside, "fl_event_inside"); + pragma Inline (fl_event_inside); + + + + + -- Keyboard -- + + function fl_event_key + return Interfaces.C.int; + pragma Import (C, fl_event_key, "fl_event_key"); + pragma Inline (fl_event_key); + + function fl_event_original_key + return Interfaces.C.int; + pragma Import (C, fl_event_original_key, "fl_event_original_key"); + pragma Inline (fl_event_original_key); + + function fl_event_key_during + (K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_key_during, "fl_event_key_during"); + pragma Inline (fl_event_key_during); + + function fl_event_get_key + (K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_get_key, "fl_event_get_key"); + pragma Inline (fl_event_get_key); + + function fl_event_ctrl + return Interfaces.C.int; + pragma Import (C, fl_event_ctrl, "fl_event_ctrl"); + pragma Inline (fl_event_ctrl); + + function fl_event_alt + return Interfaces.C.int; + pragma Import (C, fl_event_alt, "fl_event_alt"); + pragma Inline (fl_event_alt); + + function fl_event_command + return Interfaces.C.int; + pragma Import (C, fl_event_command, "fl_event_command"); + pragma Inline (fl_event_command); + + function fl_event_shift + return Interfaces.C.int; + pragma Import (C, fl_event_shift, "fl_event_shift"); + pragma Inline (fl_event_shift); + + + + + ------------- + -- Hooks -- + ------------- + + -- 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; + pragma Convention (C, Event_Handler_Hook); + + function Event_Handler_Hook + (Num : in Interfaces.C.int) + return Interfaces.C.int is + begin + for Call of reverse Handlers loop + if Call (Event_Kind'Val (Num)) /= Not_Handled then + return Event_Outcome'Pos (Handled); + end if; + end loop; + return Event_Outcome'Pos (Not_Handled); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Event_Handler hook received unexpected event int value of " & + Interfaces.C.int'Image (Num); + end Event_Handler_Hook; + + + -- This is handled on the Ada side because otherwise there would be + -- no way to specify which callback to remove in FLTK once one was + -- added. This is because Fl::remove_system_handler does not pay + -- attention to the void * data. This hook is passed during package init. + package System_Handler_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => System_Handler); + + System_Handlers : System_Handler_Vectors.Vector; + + function System_Handler_Hook + (E, U : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Convention (C, System_Handler_Hook); + + function System_Handler_Hook + (E, U : in Storage.Integer_Address) + return Interfaces.C.int is + begin + for Call of reverse System_Handlers loop + if Call (System_Event (Storage.To_Address (E))) = Handled then + return Event_Outcome'Pos (Handled); + end if; + end loop; + return Event_Outcome'Pos (Not_Handled); + end System_Handler_Hook; + + + function Dispatch_Hook + (Num : in Interfaces.C.int; + Ptr : in Storage.Integer_Address) + 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; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Handlers -- + + procedure Add_Handler + (Func : in not null Event_Handler) is + begin + Handlers.Append (Func); + end Add_Handler; + + + procedure Remove_Handler + (Func : in not null Event_Handler) is + begin + for I in reverse Handlers.First_Index .. Handlers.Last_Index loop + if Handlers (I) = Func then + Handlers.Delete (I); + return; + end if; + end loop; + end Remove_Handler; + + + 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; + + + 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 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; + + + + + -- Receiving -- + + function Get_Grab + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Grab_Ptr : Storage.Integer_Address := fl_event_get_grab; + Actual_Grab : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Grab_Ptr /= Null_Pointer then + Grab_Ptr := fl_widget_get_user_data (Grab_Ptr); + pragma Assert (Grab_Ptr /= Null_Pointer); + Actual_Grab := Window_Convert.To_Pointer (Storage.To_Address (Grab_Ptr)); + end if; + return Actual_Grab; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::grab did not have user_data reference back to Ada"; + end Get_Grab; + + + procedure Set_Grab + (To : in FLTK.Widgets.Groups.Windows.Window'Class) is + begin + fl_event_set_grab (Wrapper (To).Void_Ptr); + end Set_Grab; + + + procedure Release_Grab is + begin + fl_event_set_grab (Null_Pointer); + end Release_Grab; + + + function Get_Pushed + return access FLTK.Widgets.Widget'Class + is + Pushed_Ptr : Storage.Integer_Address := fl_event_get_pushed; + Actual_Pushed : access FLTK.Widgets.Widget'Class; + begin + if Pushed_Ptr /= Null_Pointer then + Pushed_Ptr := fl_widget_get_user_data (Pushed_Ptr); + pragma Assert (Pushed_Ptr /= Null_Pointer); + Actual_Pushed := Widget_Convert.To_Pointer (Storage.To_Address (Pushed_Ptr)); + end if; + return Actual_Pushed; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::pushed did not have user_data reference back to Ada"; + end Get_Pushed; + + + procedure Set_Pushed + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_pushed (Wrapper (To).Void_Ptr); + end Set_Pushed; + + + function Get_Below_Mouse + return access FLTK.Widgets.Widget'Class + is + Below_Ptr : Storage.Integer_Address := fl_event_get_belowmouse; + Actual_Below : access FLTK.Widgets.Widget'Class; + begin + if Below_Ptr /= Null_Pointer then + Below_Ptr := fl_widget_get_user_data (Below_Ptr); + pragma Assert (Below_Ptr /= Null_Pointer); + Actual_Below := Widget_Convert.To_Pointer (Storage.To_Address (Below_Ptr)); + end if; + return Actual_Below; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::belowmouse did not have user_data reference back to Ada"; + end Get_Below_Mouse; + + + procedure Set_Below_Mouse + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_belowmouse (Wrapper (To).Void_Ptr); + end Set_Below_Mouse; + + + function Get_Focus + return access FLTK.Widgets.Widget'Class + is + Focus_Ptr : Storage.Integer_Address := fl_event_get_focus; + Actual_Focus : access FLTK.Widgets.Widget'Class; + begin + if Focus_Ptr /= Null_Pointer then + Focus_Ptr := fl_widget_get_user_data (Focus_Ptr); + pragma Assert (Focus_Ptr /= Null_Pointer); + Actual_Focus := Widget_Convert.To_Pointer (Storage.To_Address (Focus_Ptr)); + end if; + return Actual_Focus; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::focus did not have user_data reference back to Ada"; + end Get_Focus; + + + procedure Set_Focus + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_focus (Wrapper (To).Void_Ptr); + end Set_Focus; + + + function Has_Visible_Focus + return Boolean is + begin + return fl_event_get_visible_focus /= 0; + end Has_Visible_Focus; + + + procedure Set_Visible_Focus + (To : in Boolean) is + begin + fl_event_set_visible_focus (Boolean'Pos (To)); + end Set_Visible_Focus; + + + + + -- Clipboard -- + + function Clipboard_Text + return String + is + Text_Ptr : 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 -- + + function Compose + (Del : out Natural) + return Boolean is + begin + return fl_event_compose (Interfaces.C.int (Del)) /= 0; + end Compose; + + + function Text + return String + is + Str : constant Interfaces.C.Strings.chars_ptr := fl_event_text; + begin + if Str = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Str, Interfaces.C.size_t (fl_event_length)); + end if; + end Text; + + + function Text_Length + return Natural is + begin + return Natural (fl_event_length); + end Text_Length; + + + function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean is + begin + return fl_event_test_shortcut (To_C (Shortcut)) /= 0; + end Test_Shortcut; + + + + + -- Modifiers -- + + function Last + return Event_Kind + is + Value : constant Interfaces.C.int := fl_event_get; + begin + return Event_Kind'Val (Value); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event returned unexpected int value of " & Interfaces.C.int'Image (Value); + end Last; + + + function Last_Modifier + return Modifier is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_state)); + end Last_Modifier; + + + function Last_Modifier + (Had : in Modifier) + return Boolean is + begin + return fl_event_check_state (Interfaces.C.int (To_C (Had))) /= 0; + end Last_Modifier; + + + + + -- Mouse -- + + function Mouse_X + return Integer is + begin + return Integer (fl_event_x); + end Mouse_X; + + + function Mouse_X_Root + return Integer is + begin + return Integer (fl_event_x_root); + end Mouse_X_Root; + + + function Mouse_Y + return Integer is + begin + return Integer (fl_event_y); + end Mouse_Y; + + + function Mouse_Y_Root + return Integer is + begin + return Integer (fl_event_y_root); + end Mouse_Y_Root; + + + + function Mouse_DX + return Integer is + begin + return Integer (fl_event_dx); + end Mouse_DX; + + + function Mouse_DY + return Integer is + begin + return Integer (fl_event_dy); + end Mouse_DY; + + + procedure Get_Mouse + (X, Y : out Integer) is + begin + fl_event_get_mouse (Interfaces.C.int (X), Interfaces.C.int (Y)); + end Get_Mouse; + + + function Is_Click + return Boolean is + begin + return fl_event_is_click /= 0; + end Is_Click; + + + procedure Clear_Click is + begin + fl_event_set_click (0); + end Clear_Click; + + + function Is_Multi_Click + return Boolean is + begin + return fl_event_get_clicks /= 0; + end Is_Multi_Click; + + + function Get_Clicks + return Natural + is + Raw : 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 + if To = 0 then + fl_event_set_clicks (0); + Clear_Click; + elsif To = 1 then + fl_event_set_clicks (0); + else + fl_event_set_clicks (Interfaces.C.int (To) - 1); + end if; + end Set_Clicks; + + + function Last_Button + return Mouse_Button + is + Code : constant Interfaces.C.int := fl_event_button; + begin + pragma Assert (Last = Push or Last = Release); + if Code = fl_enum_left_mouse then + return Left_Button; + elsif Code = fl_enum_middle_mouse then + return Middle_Button; + elsif Code = fl_enum_right_mouse then + return Right_Button; + elsif Code = fl_enum_back_mouse then + return Back_Button; + elsif Code = fl_enum_forward_mouse then + return Forward_Button; + else + raise Internal_FLTK_Error with "Fl::event_button returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::event_button was called when the most recent event was not Push or Release"; + end Last_Button; + + + function Mouse_Left + return Boolean is + begin + return fl_event_button1 /= 0; + end Mouse_Left; + + + function Mouse_Middle + return Boolean is + begin + return fl_event_button2 /= 0; + end Mouse_Middle; + + + function Mouse_Right + return Boolean is + begin + return fl_event_button3 /= 0; + end Mouse_Right; + + + function Mouse_Back + return Boolean is + begin + return fl_event_button4 /= 0; + end Mouse_Back; + + + function Mouse_Forward + return Boolean is + begin + return fl_event_button5 /= 0; + end Mouse_Forward; + + + procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean) + is + type Cint_Mod is mod 2 ** Interfaces.C.int'Size; + Mask : 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 + begin + return fl_event_inside + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)) /= 0; + end Is_Inside; + + + + + -- Keyboard -- + + function Last_Key + return Keypress is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_key)); + end Last_Key; + + + function Original_Last_Key + return Keypress is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_original_key)); + end Original_Last_Key; + + + function Pressed_During + (Key : in Keypress) + return Boolean is + begin + return fl_event_key_during (Interfaces.C.int (To_C (Key))) /= 0; + end Pressed_During; + + + function Key_Now + (Key : in Keypress) + return Boolean is + begin + return fl_event_get_key (Interfaces.C.int (To_C (Key))) /= 0; + end Key_Now; + + + function Key_Ctrl + return Boolean is + begin + return fl_event_ctrl /= 0; + end Key_Ctrl; + + + function Key_Alt + return Boolean is + begin + return fl_event_alt /= 0; + end Key_Alt; + + + function Key_Command + return Boolean is + begin + return fl_event_command /= 0; + end Key_Command; + + + function Key_Shift + return Boolean is + begin + return fl_event_shift /= 0; + end Key_Shift; + + +begin + + + fl_event_add_handler (Storage.To_Integer (Event_Handler_Hook'Address)); + fl_event_add_system_handler (Storage.To_Integer (System_Handler_Hook'Address), Null_Pointer); + + +end FLTK.Events; + + diff --git a/body/fltk-file_choosers.adb b/body/fltk-file_choosers.adb index 5662f8a..ef33753 100644 --- a/body/fltk-file_choosers.adb +++ b/body/fltk-file_choosers.adb @@ -31,22 +31,24 @@ package body FLTK.File_Choosers is -- Functions From C -- ------------------------ + -- User Data -- + function fl_widget_get_user_data (W : in Storage.Integer_Address) return Storage.Integer_Address; pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); 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); @@ -56,6 +58,8 @@ package body FLTK.File_Choosers is + -- Sorting -- + procedure file_chooser_setup_sort_hook; pragma Import (C, file_chooser_setup_sort_hook, "file_chooser_setup_sort_hook"); pragma Inline (file_chooser_setup_sort_hook); @@ -63,6 +67,8 @@ package body FLTK.File_Choosers is + -- Allocation -- + function new_fl_file_chooser (N, P : in Interfaces.C.char_array; K : in Interfaces.C.int; @@ -79,6 +85,8 @@ package body FLTK.File_Choosers is + -- Buttons -- + function fl_file_chooser_newbutton (F : in Storage.Integer_Address) return Storage.Integer_Address; @@ -100,6 +108,8 @@ package body FLTK.File_Choosers is + -- Static Labels -- + function fl_file_chooser_get_add_favorites_label return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_file_chooser_get_add_favorites_label, @@ -257,6 +267,8 @@ package body FLTK.File_Choosers is + -- Callback and Extra -- + function fl_file_chooser_add_extra (F, W : in Storage.Integer_Address) return Storage.Integer_Address; @@ -271,6 +283,8 @@ package body FLTK.File_Choosers is + -- Settings -- + function fl_file_chooser_get_color (F : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -382,6 +396,8 @@ package body FLTK.File_Choosers is + -- File Selection -- + function fl_file_chooser_count (F : in Storage.Integer_Address) return Interfaces.C.int; @@ -450,6 +466,8 @@ package body FLTK.File_Choosers is + -- Visibility -- + procedure fl_file_chooser_show (F : in Storage.Integer_Address); pragma Import (C, fl_file_chooser_show, "fl_file_chooser_show"); @@ -496,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 @@ -518,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; @@ -673,6 +673,8 @@ package body FLTK.File_Choosers is -- Attributes -- ------------------ + -- Buttons -- + function New_Button (This : in out File_Chooser) return FLTK.Widgets.Buttons.Button_Reference is @@ -703,6 +705,8 @@ package body FLTK.File_Choosers is -- Static Attributes -- ------------------------- + -- Static Labels -- + function Get_Add_Favorites_Label return String is begin @@ -932,22 +936,25 @@ package body FLTK.File_Choosers is -- API Subprograms -- ----------------------- + -- Callback and Extra -- + procedure Add_Extra (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; @@ -967,7 +974,8 @@ package body FLTK.File_Choosers is end if; return Ada_Obj; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Chooser::add_extra returned Widget with no user_data reference back to Ada"; end Eject_Extra; @@ -981,6 +989,8 @@ package body FLTK.File_Choosers is + -- Settings -- + function Get_Background_Color (This : in File_Chooser) return Color is @@ -1053,12 +1063,14 @@ 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); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Chooser::preview returned unexpected int value of " & + Interfaces.C.int'Image (Ret); end Has_Preview; @@ -1122,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); @@ -1143,6 +1155,8 @@ package body FLTK.File_Choosers is + -- File Selection -- + function Number_Selected (This : in File_Chooser) return Natural is @@ -1155,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 ""; @@ -1186,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 ""; @@ -1248,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 @@ -1269,6 +1285,8 @@ package body FLTK.File_Choosers is + -- Visibility -- + procedure Show (This : in out File_Chooser) is begin diff --git a/body/fltk-filenames.adb b/body/fltk-filenames.adb index 7674323..9e41b7d 100644 --- a/body/fltk-filenames.adb +++ b/body/fltk-filenames.adb @@ -37,6 +37,8 @@ package body FLTK.Filenames is -- Functions From C -- ------------------------ + -- Data Structures -- + procedure free_filename_file_list (L : in Storage.Integer_Address; N : in Interfaces.C.int); @@ -53,23 +55,25 @@ package body FLTK.Filenames is + -- C API -- + procedure filename_decode_uri (URI : in Interfaces.C.char_array); pragma Import (C, filename_decode_uri, "filename_decode_uri"); 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); @@ -107,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); @@ -123,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); @@ -132,6 +137,8 @@ package body FLTK.Filenames is + -- Sorting -- + function filename_alphasort (A, B : in Interfaces.C.char_array) return Interfaces.C.int; @@ -155,22 +162,26 @@ package body FLTK.Filenames is - ------------------------------ - -- Comparison Subprograms -- - ------------------------------ + ----------------------------- + -- Auxiliary Subprograms -- + ----------------------------- + + -- Sorting -- function Alpha_Sort (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 (Result in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last)); return Comparison'Val (Result); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Wrapper of fl_alphasort returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Alpha_Sort; @@ -178,14 +189,16 @@ 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 (Result in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last)); return Comparison'Val (Result); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Wrapper of fl_casealphasort returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Case_Alpha_Sort; @@ -193,14 +206,16 @@ 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 (Result in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last)); return Comparison'Val (Result); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Wrapper of fl_numericsort returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Numeric_Sort; @@ -208,22 +223,22 @@ 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 (Result in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last)); return Comparison'Val (Result); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Wrapper of fl_casenumericsort returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Case_Numeric_Sort; - --------------------------- - -- Listing Subprograms -- - --------------------------- + -- Datatypes -- procedure Finalize (This : in out File_List) is @@ -255,15 +270,17 @@ package body FLTK.Filenames is - -------------------- - -- Filename API -- - -------------------- + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Uniform Resource Identifiers -- function Decode_URI (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); @@ -275,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); @@ -286,19 +303,22 @@ package body FLTK.Filenames is pragma Assert (Result = 1); end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_open_uri returned unexpected int value of " & Interfaces.C.int'Image (Result); end Open_URI; + -- Pathnames -- + function Absolute (Name : in Path_String) return Path_String 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)); @@ -314,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)); @@ -330,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)); @@ -346,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)); @@ -362,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)); @@ -378,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)); @@ -390,11 +410,13 @@ package body FLTK.Filenames is + -- Filenames -- + function Base_Name (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; @@ -404,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 ""; @@ -435,6 +457,8 @@ package body FLTK.Filenames is + -- Directories -- + function Is_Directory (Name : in Path_String) return Boolean is @@ -455,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 @@ -479,6 +503,8 @@ package body FLTK.Filenames is + -- Patterns -- + function Match (Input, Pattern : in String) return Boolean is diff --git a/body/fltk-help_dialogs.adb b/body/fltk-help_dialogs.adb index fc5ab07..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 @@ -21,6 +21,8 @@ package body FLTK.Help_Dialogs is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_help_dialog return Storage.Integer_Address; pragma Import (C, new_fl_help_dialog, "new_fl_help_dialog"); @@ -34,6 +36,8 @@ package body FLTK.Help_Dialogs is + -- Visibility -- + procedure fl_help_dialog_show (D : in Storage.Integer_Address); pragma Import (C, fl_help_dialog_show, "fl_help_dialog_show"); @@ -60,6 +64,8 @@ package body FLTK.Help_Dialogs is + -- Topline -- + procedure fl_help_dialog_set_topline_number (D : in Storage.Integer_Address; N : in Interfaces.C.int); @@ -75,6 +81,8 @@ package body FLTK.Help_Dialogs is + -- Content -- + procedure fl_help_dialog_load (D : in Storage.Integer_Address; N : in Interfaces.C.char_array); @@ -96,6 +104,8 @@ package body FLTK.Help_Dialogs is + -- Settings -- + function fl_help_dialog_get_textsize (D : in Storage.Integer_Address) return Interfaces.C.int; @@ -111,6 +121,8 @@ package body FLTK.Help_Dialogs is + -- Dimensions -- + function fl_help_dialog_get_x (D : in Storage.Integer_Address) return Interfaces.C.int; @@ -191,6 +203,9 @@ package body FLTK.Help_Dialogs is end return; end Create; + + pragma Inline (Create); + end Forge; @@ -200,6 +215,8 @@ package body FLTK.Help_Dialogs is -- API Subprograms -- ----------------------- + -- Visibility -- + procedure Show (This : in out Help_Dialog) is begin @@ -210,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; @@ -231,6 +248,8 @@ package body FLTK.Help_Dialogs is + -- Topline -- + procedure Set_Topline_Number (This : in out Help_Dialog; Line : in Positive) is @@ -249,6 +268,8 @@ package body FLTK.Help_Dialogs is + -- Content -- + procedure Load (This : in out Help_Dialog; Name : in String) is @@ -261,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 @@ -282,6 +304,8 @@ package body FLTK.Help_Dialogs is + -- Settings -- + function Get_Text_Size (This : in Help_Dialog) return Font_Size is @@ -300,6 +324,8 @@ package body FLTK.Help_Dialogs is + -- Dimensions -- + function Get_X (This : in Help_Dialog) return Integer is diff --git a/body/fltk-images-bitmaps-xbm.adb b/body/fltk-images-bitmaps-xbm.adb index eb8c093..0115b1b 100644 --- a/body/fltk-images-bitmaps-xbm.adb +++ b/body/fltk-images-bitmaps-xbm.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.Bitmaps.XBM is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_xbm_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +32,10 @@ package body FLTK.Images.Bitmaps.XBM is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out XBM_Image) is begin @@ -39,7 +49,7 @@ package body FLTK.Images.Bitmaps.XBM is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,17 +61,7 @@ package body FLTK.Images.Bitmaps.XBM is return This : XBM_Image do This.Void_Ptr := new_fl_xbm_image (Interfaces.C.To_C (Filename)); - case fl_image_fail (This.Void_Ptr) is - when 1 => - -- raise No_Image_Error; - null; - -- Since the image depth and line data are both zero here, - -- the fail method will think there's no image even though - -- nothing is wrong. This is a bug in FLTK. - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Raise_Fail_Errors (This); end return; end Create; @@ -70,3 +70,4 @@ package body FLTK.Images.Bitmaps.XBM is end FLTK.Images.Bitmaps.XBM; + diff --git a/body/fltk-images-bitmaps.adb b/body/fltk-images-bitmaps.adb index 90150c9..5b59c13 100644 --- a/body/fltk-images-bitmaps.adb +++ b/body/fltk-images-bitmaps.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.Bitmaps is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_bitmap (D : in Storage.Integer_Address; W, H : in Interfaces.C.int) @@ -24,6 +30,11 @@ package body FLTK.Images.Bitmaps is pragma Import (C, free_fl_bitmap, "free_fl_bitmap"); pragma Inline (free_fl_bitmap); + + + + -- Copying -- + function fl_bitmap_copy (I : in Storage.Integer_Address; W, H : in Interfaces.C.int) @@ -40,6 +51,8 @@ package body FLTK.Images.Bitmaps is + -- Activity -- + procedure fl_bitmap_uncache (I : in Storage.Integer_Address); pragma Import (C, fl_bitmap_uncache, "fl_bitmap_uncache"); @@ -48,6 +61,19 @@ package body FLTK.Images.Bitmaps is + -- Pixel Data -- + + function fl_bitmap_data + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_bitmap_data, "fl_bitmap_data"); + pragma Inline (fl_bitmap_data); + + + + + -- Drawing -- + procedure fl_bitmap_draw2 (I : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -63,6 +89,10 @@ package body FLTK.Images.Bitmaps is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out Bitmap) is begin @@ -76,7 +106,7 @@ package body FLTK.Images.Bitmaps is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -88,26 +118,38 @@ 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)); - case fl_image_fail (This.Void_Ptr) is - when 1 => - -- raise No_Image_Error; - null; - -- Since the image depth and line data are both zero here, - -- the fail method will think there's no image even though - -- nothing is wrong. This is a bug in FLTK. - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; end return; end Create; end Forge; + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Contracts -- + + function Bytes_Needed + (Bits : in Natural) + return Natural is + begin + return Integer (Float'Ceiling + (Float (Bits) / Float (Color_Component_Array'Component_Size))); + end Bytes_Needed; + + + + + -- Copying -- + function Copy (This : in Bitmap; Width, Height : in Natural) @@ -134,9 +176,7 @@ package body FLTK.Images.Bitmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Bitmap) is @@ -146,9 +186,85 @@ package body FLTK.Images.Bitmaps is - --------------- + + -- Pixel Data -- + + function Data_Size + (This : in Bitmap) + return Size_Type is + begin + 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_Size) + return Color_Component + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Place); + end Get_Datum; + + + procedure Set_Datum + (This : in out Bitmap; + Place : in Positive_Size; + Value : in Color_Component) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place) := Value; + end Set_Datum; + + + function Slice + (This : in Bitmap; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Low .. High); + end Slice; + + + procedure Overwrite + (This : in out Bitmap; + Place : in Positive_Size; + Values : in Color_Component_Array) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place .. Place + Values'Length - 1) := Values; + end Overwrite; + + + function All_Data + (This : in Bitmap) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data; + end All_Data; + + + + -- Drawing -- - --------------- procedure Draw (This : in Bitmap; @@ -162,9 +278,9 @@ package body FLTK.Images.Bitmaps is procedure Draw - (This : in Bitmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0) is + (This : in Bitmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is begin fl_bitmap_draw (This.Void_Ptr, @@ -172,10 +288,11 @@ package body FLTK.Images.Bitmaps is Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.int (CX), - Interfaces.C.int (CY)); + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); end Draw; end FLTK.Images.Bitmaps; + diff --git a/body/fltk-images-pixmaps-gif.adb b/body/fltk-images-pixmaps-gif.adb index 535debf..fb8dca8 100644 --- a/body/fltk-images-pixmaps-gif.adb +++ b/body/fltk-images-pixmaps-gif.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.Pixmaps.GIF is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_gif_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +32,10 @@ package body FLTK.Images.Pixmaps.GIF is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out GIF_Image) is begin @@ -39,7 +49,7 @@ package body FLTK.Images.Pixmaps.GIF is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,12 +61,7 @@ package body FLTK.Images.Pixmaps.GIF is return This : GIF_Image do This.Void_Ptr := new_fl_gif_image (Interfaces.C.To_C (Filename)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Raise_Fail_Errors (This); end return; end Create; @@ -65,3 +70,4 @@ package body FLTK.Images.Pixmaps.GIF is end FLTK.Images.Pixmaps.GIF; + diff --git a/body/fltk-images-pixmaps-xpm.adb b/body/fltk-images-pixmaps-xpm.adb index 006c8b4..d9cff25 100644 --- a/body/fltk-images-pixmaps-xpm.adb +++ b/body/fltk-images-pixmaps-xpm.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.Pixmaps.XPM is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_xpm_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +32,10 @@ package body FLTK.Images.Pixmaps.XPM is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out XPM_Image) is begin @@ -39,7 +49,7 @@ package body FLTK.Images.Pixmaps.XPM is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,12 +61,7 @@ package body FLTK.Images.Pixmaps.XPM is return This : XPM_Image do This.Void_Ptr := new_fl_xpm_image (Interfaces.C.To_C (Filename)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Raise_Fail_Errors (This); end return; end Create; @@ -65,3 +70,4 @@ package body FLTK.Images.Pixmaps.XPM is end FLTK.Images.Pixmaps.XPM; + diff --git a/body/fltk-images-pixmaps.adb b/body/fltk-images-pixmaps.adb index 2e66d2f..8487459 100644 --- a/body/fltk-images-pixmaps.adb +++ b/body/fltk-images-pixmaps.adb @@ -6,17 +6,34 @@ with - Interfaces.C; + FLTK.Pixmap_Marshal; package body FLTK.Images.Pixmaps is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_pixmap + (D : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, new_fl_pixmap, "new_fl_pixmap"); + pragma Inline (new_fl_pixmap); + procedure free_fl_pixmap (I : in Storage.Integer_Address); pragma Import (C, free_fl_pixmap, "free_fl_pixmap"); pragma Inline (free_fl_pixmap); + + + + -- Copying -- + function fl_pixmap_copy (I : in Storage.Integer_Address; W, H : in Interfaces.C.int) @@ -33,6 +50,8 @@ package body FLTK.Images.Pixmaps is + -- Colors -- + procedure fl_pixmap_color_average (I : in Storage.Integer_Address; C : in Interfaces.C.int; @@ -48,6 +67,8 @@ package body FLTK.Images.Pixmaps is + -- Activity -- + procedure fl_pixmap_uncache (I : in Storage.Integer_Address); pragma Import (C, fl_pixmap_uncache, "fl_pixmap_uncache"); @@ -56,6 +77,8 @@ package body FLTK.Images.Pixmaps is + -- Drawing -- + procedure fl_pixmap_draw2 (I : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -71,10 +94,15 @@ package body FLTK.Images.Pixmaps is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out Pixmap) is begin if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + Pixmap_Marshal.Free_Recursive (This.Loose_Ptr); free_fl_pixmap (This.Void_Ptr); This.Void_Ptr := Null_Pointer; end if; @@ -84,9 +112,35 @@ package body FLTK.Images.Pixmaps is -------------------- - -- Construction -- + -- Constructors -- -------------------- + package body Forge is + + function Create + (Values : in Header; + Colors : in Color_Definition_Array; + Pixels : in Pixmap_Data) + return Pixmap is + begin + return This : Pixmap do + This.Loose_Ptr := Pixmap_Marshal.Marshal_Data (Values, Colors, Pixels); + This.Void_Ptr := new_fl_pixmap + (Storage.To_Integer (This.Loose_Ptr (This.Loose_Ptr'First)'Address)); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + function Copy (This : in Pixmap; Width, Height : in Natural) @@ -113,9 +167,7 @@ package body FLTK.Images.Pixmaps is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Pixmap; @@ -138,9 +190,7 @@ package body FLTK.Images.Pixmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Pixmap) is @@ -151,9 +201,7 @@ package body FLTK.Images.Pixmaps is - --------------- -- Drawing -- - --------------- procedure Draw (This : in Pixmap; @@ -167,9 +215,9 @@ package body FLTK.Images.Pixmaps is procedure Draw - (This : in Pixmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0) is + (This : in Pixmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is begin fl_pixmap_draw (This.Void_Ptr, @@ -177,10 +225,11 @@ package body FLTK.Images.Pixmaps is Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.int (CX), - Interfaces.C.int (CY)); + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); end Draw; end FLTK.Images.Pixmaps; + diff --git a/body/fltk-images-rgb-bmp.adb b/body/fltk-images-rgb-bmp.adb index 01669eb..23ffe01 100644 --- a/body/fltk-images-rgb-bmp.adb +++ b/body/fltk-images-rgb-bmp.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.RGB.BMP is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_bmp_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +32,10 @@ package body FLTK.Images.RGB.BMP is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out BMP_Image) is begin @@ -39,7 +49,7 @@ package body FLTK.Images.RGB.BMP is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,12 +61,7 @@ package body FLTK.Images.RGB.BMP is return This : BMP_Image do This.Void_Ptr := new_fl_bmp_image (Interfaces.C.To_C (Filename)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Raise_Fail_Errors (This); end return; end Create; @@ -65,3 +70,4 @@ package body FLTK.Images.RGB.BMP is end FLTK.Images.RGB.BMP; + diff --git a/body/fltk-images-rgb-jpeg.adb b/body/fltk-images-rgb-jpeg.adb index 17debb5..61d06e6 100644 --- a/body/fltk-images-rgb-jpeg.adb +++ b/body/fltk-images-rgb-jpeg.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.RGB.JPEG is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_jpeg_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -33,6 +39,10 @@ package body FLTK.Images.RGB.JPEG is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out JPEG_Image) is begin @@ -46,7 +56,7 @@ package body FLTK.Images.RGB.JPEG is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -58,15 +68,11 @@ package body FLTK.Images.RGB.JPEG is return This : JPEG_Image do This.Void_Ptr := new_fl_jpeg_image (Interfaces.C.To_C (Filename)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Raise_Fail_Errors (This); end return; end Create; + function Create (Name : in String := ""; Data : in Color_Component_Array) @@ -75,13 +81,10 @@ 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)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + (if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer)); + Raise_Fail_Errors (This); end return; end Create; @@ -90,3 +93,4 @@ package body FLTK.Images.RGB.JPEG is end FLTK.Images.RGB.JPEG; + diff --git a/body/fltk-images-rgb-png.adb b/body/fltk-images-rgb-png.adb index 67befe3..1f6e7b9 100644 --- a/body/fltk-images-rgb-png.adb +++ b/body/fltk-images-rgb-png.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.RGB.PNG is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_png_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -34,6 +40,10 @@ package body FLTK.Images.RGB.PNG is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out PNG_Image) is begin @@ -47,7 +57,7 @@ package body FLTK.Images.RGB.PNG is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -59,15 +69,11 @@ package body FLTK.Images.RGB.PNG is return This : PNG_Image do This.Void_Ptr := new_fl_png_image (Interfaces.C.To_C (Filename)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Raise_Fail_Errors (This); end return; end Create; + function Create (Name : in String := ""; Data : in Color_Component_Array) @@ -76,14 +82,11 @@ 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); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Raise_Fail_Errors (This); end return; end Create; @@ -92,3 +95,4 @@ package body FLTK.Images.RGB.PNG is end FLTK.Images.RGB.PNG; + diff --git a/body/fltk-images-rgb-pnm.adb b/body/fltk-images-rgb-pnm.adb index 362b8d6..4ddb06f 100644 --- a/body/fltk-images-rgb-pnm.adb +++ b/body/fltk-images-rgb-pnm.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.RGB.PNM is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_pnm_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +32,10 @@ package body FLTK.Images.RGB.PNM is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out PNM_Image) is begin @@ -39,7 +49,7 @@ package body FLTK.Images.RGB.PNM is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,12 +61,7 @@ package body FLTK.Images.RGB.PNM is return This : PNM_Image do This.Void_Ptr := new_fl_pnm_image (Interfaces.C.To_C (Filename)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Raise_Fail_Errors (This); end return; end Create; @@ -65,3 +70,4 @@ package body FLTK.Images.RGB.PNM is end FLTK.Images.RGB.PNM; + diff --git a/body/fltk-images-rgb.adb b/body/fltk-images-rgb.adb index 19a7952..71d2520 100644 --- a/body/fltk-images-rgb.adb +++ b/body/fltk-images-rgb.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.RGB is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_rgb_image (Data : in Storage.Integer_Address; W, H, D, L : in Interfaces.C.int) @@ -31,6 +37,11 @@ package body FLTK.Images.RGB is pragma Import (C, free_fl_rgb_image, "free_fl_rgb_image"); pragma Inline (free_fl_rgb_image); + + + + -- Static Settings -- + function fl_rgb_image_get_max_size return Interfaces.C.size_t; pragma Import (C, fl_rgb_image_get_max_size, "fl_rgb_image_get_max_size"); @@ -41,6 +52,11 @@ package body FLTK.Images.RGB is pragma Import (C, fl_rgb_image_set_max_size, "fl_rgb_image_set_max_size"); pragma Inline (fl_rgb_image_set_max_size); + + + + -- Copying -- + function fl_rgb_image_copy (I : in Storage.Integer_Address; W, H : in Interfaces.C.int) @@ -57,6 +73,8 @@ package body FLTK.Images.RGB is + -- Colors -- + procedure fl_rgb_image_color_average (I : in Storage.Integer_Address; C : in Interfaces.C.int; @@ -72,6 +90,8 @@ package body FLTK.Images.RGB is + -- Activity -- + procedure fl_rgb_image_uncache (I : in Storage.Integer_Address); pragma Import (C, fl_rgb_image_uncache, "fl_rgb_image_uncache"); @@ -80,6 +100,19 @@ package body FLTK.Images.RGB is + -- Pixel Data -- + + function fl_rgb_image_data + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_rgb_image_data, "fl_rgb_image_data"); + pragma Inline (fl_rgb_image_data); + + + + + -- Drawing -- + procedure fl_rgb_image_draw2 (I : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -95,6 +128,10 @@ package body FLTK.Images.RGB is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out RGB_Image) is begin @@ -108,7 +145,7 @@ package body FLTK.Images.RGB is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -117,25 +154,22 @@ package body FLTK.Images.RGB is (Data : in Color_Component_Array; Width, Height : in Natural; Depth : in Natural := 3; - Line_Data : in Natural := 0) + Line_Size : in Natural := 0) return RGB_Image 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), - Interfaces.C.int (Line_Data)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Interfaces.C.int (Line_Size)); end return; end Create; + function Create (Data : in FLTK.Images.Pixmaps.Pixmap'Class; Background : in Color := Background_Color) @@ -145,32 +179,38 @@ package body FLTK.Images.RGB is This.Void_Ptr := new_fl_rgb_image2 (Wrapper (Data).Void_Ptr, Interfaces.C.unsigned (Background)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; end return; end Create; end Forge; + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- 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; + + + -- Copying -- + function Copy (This : in RGB_Image; Width, Height : in Natural) @@ -197,9 +237,7 @@ package body FLTK.Images.RGB is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out RGB_Image; @@ -222,9 +260,7 @@ package body FLTK.Images.RGB is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out RGB_Image) is @@ -235,9 +271,90 @@ package body FLTK.Images.RGB is - --------------- + -- Pixel Data -- + + function Data_Size + (This : in RGB_Image) + return Size_Type + is + Per_Line : constant Natural := This.Get_Line_Size; + begin + if Per_Line = 0 then + return Size_Type (This.Get_W) * Size_Type (This.Get_D) * Size_Type (This.Get_H); + else + 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_Size) + return Color_Component + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Place); + end Get_Datum; + + + procedure Set_Datum + (This : in out RGB_Image; + Place : in Positive_Size; + Value : in Color_Component) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place) := Value; + end Set_Datum; + + + function Slice + (This : in RGB_Image; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Low .. High); + end Slice; + + + procedure Overwrite + (This : in out RGB_Image; + Place : in Positive_Size; + Values : in Color_Component_Array) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place .. Place + Values'Length - 1) := Values; + end Overwrite; + + + function All_Data + (This : in RGB_Image) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data; + end All_Data; + + + + -- Drawing -- - --------------- procedure Draw (This : in RGB_Image; @@ -251,9 +368,9 @@ package body FLTK.Images.RGB is procedure Draw - (This : in RGB_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0) is + (This : in RGB_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is begin fl_rgb_image_draw (This.Void_Ptr, @@ -261,10 +378,11 @@ package body FLTK.Images.RGB is Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.int (CX), - Interfaces.C.int (CY)); + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); end Draw; end FLTK.Images.RGB; + diff --git a/body/fltk-images-shared.adb b/body/fltk-images-shared.adb index d475cc3..b8de511 100644 --- a/body/fltk-images-shared.adb +++ b/body/fltk-images-shared.adb @@ -17,6 +17,12 @@ use type package body FLTK.Images.Shared is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function fl_shared_image_get (F : in Interfaces.C.char_array; W, H : in Interfaces.C.int) @@ -42,6 +48,11 @@ package body FLTK.Images.Shared is pragma Import (C, fl_shared_image_release, "fl_shared_image_release"); pragma Inline (fl_shared_image_release); + + + + -- Copying -- + function fl_shared_image_copy (I : in Storage.Integer_Address; W, H : in Interfaces.C.int) @@ -58,6 +69,8 @@ package body FLTK.Images.Shared is + -- Colors -- + procedure fl_shared_image_color_average (I : in Storage.Integer_Address; C : in Interfaces.C.int; @@ -73,6 +86,8 @@ package body FLTK.Images.Shared is + -- Activity -- + function fl_shared_image_num_images return Interfaces.C.int; pragma Import (C, fl_shared_image_num_images, "fl_shared_image_num_images"); @@ -109,6 +124,8 @@ package body FLTK.Images.Shared is + -- Drawing -- + procedure fl_shared_image_scaling_algorithm (A : in Interfaces.C.int); pragma Import (C, fl_shared_image_scaling_algorithm, "fl_shared_image_scaling_algorithm"); @@ -135,6 +152,10 @@ package body FLTK.Images.Shared is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out Shared_Image) is begin @@ -148,7 +169,7 @@ package body FLTK.Images.Shared is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -196,6 +217,14 @@ package body FLTK.Images.Shared is end Forge; + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + function Copy (This : in Shared_Image; Width, Height : in Natural) @@ -222,9 +251,7 @@ package body FLTK.Images.Shared is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Shared_Image; @@ -247,9 +274,7 @@ package body FLTK.Images.Shared is - ---------------- -- Activity -- - ---------------- function Number_Of_Images return Natural is @@ -262,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 ""; @@ -304,9 +329,7 @@ package body FLTK.Images.Shared is - --------------- -- Drawing -- - --------------- procedure Set_Scaling_Algorithm (To : in Scaling_Kind) is @@ -359,3 +382,4 @@ package body FLTK.Images.Shared is end FLTK.Images.Shared; + diff --git a/body/fltk-images-tiled.adb b/body/fltk-images-tiled.adb index 6bed730..cb0d935 100644 --- a/body/fltk-images-tiled.adb +++ b/body/fltk-images-tiled.adb @@ -12,6 +12,12 @@ with package body FLTK.Images.Tiled is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_tiled_image (T : in Storage.Integer_Address; W, H : in Interfaces.C.int) @@ -24,6 +30,11 @@ package body FLTK.Images.Tiled is pragma Import (C, free_fl_tiled_image, "free_fl_tiled_image"); pragma Inline (free_fl_tiled_image); + + + + -- Copying -- + function fl_tiled_image_copy (T : in Storage.Integer_Address; W, H : in Interfaces.C.int) @@ -40,6 +51,8 @@ package body FLTK.Images.Tiled is + -- Miscellaneous -- + function fl_tiled_image_get_image (T : in Storage.Integer_Address) return Storage.Integer_Address; @@ -49,6 +62,8 @@ package body FLTK.Images.Tiled is + -- Colors -- + procedure fl_tiled_image_color_average (T : in Storage.Integer_Address; C : in Interfaces.C.int; @@ -64,6 +79,8 @@ package body FLTK.Images.Tiled is + -- Drawing -- + procedure fl_tiled_image_draw (T : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -80,6 +97,10 @@ package body FLTK.Images.Tiled is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out Tiled_Image) is begin @@ -93,7 +114,7 @@ package body FLTK.Images.Tiled is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -116,6 +137,14 @@ package body FLTK.Images.Tiled is end Forge; + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + function Copy (This : in Tiled_Image; Width, Height : in Natural) @@ -146,9 +175,7 @@ package body FLTK.Images.Tiled is - --------------------- -- Miscellaneous -- - --------------------- procedure Inactive (This : in out Tiled_Image) is @@ -169,9 +196,7 @@ package body FLTK.Images.Tiled is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Tiled_Image; @@ -198,6 +223,8 @@ package body FLTK.Images.Tiled is + -- Drawing -- + procedure Draw (This : in Tiled_Image; X, Y : in Integer) is @@ -210,9 +237,9 @@ package body FLTK.Images.Tiled is procedure Draw - (This : in Tiled_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer) is + (This : in Tiled_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer) is begin fl_tiled_image_draw2 (This.Void_Ptr, @@ -220,10 +247,11 @@ package body FLTK.Images.Tiled is Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.int (CX), - Interfaces.C.int (CY)); + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); end Draw; end FLTK.Images.Tiled; + diff --git a/body/fltk-images.adb b/body/fltk-images.adb index 19a1f86..3d5dce7 100644 --- a/body/fltk-images.adb +++ b/body/fltk-images.adb @@ -6,7 +6,7 @@ with - Interfaces.C.Strings; + Interfaces.C; use type @@ -16,6 +16,28 @@ use type package body FLTK.Images is + ------------------------ + -- Constants From C -- + ------------------------ + + fl_image_err_no_image : constant Interfaces.C.int; + pragma Import (C, fl_image_err_no_image, "fl_image_err_no_image"); + + fl_image_err_file_access : constant Interfaces.C.int; + pragma Import (C, fl_image_err_file_access, "fl_image_err_file_access"); + + fl_image_err_format : constant Interfaces.C.int; + pragma Import (C, fl_image_err_format, "fl_image_err_format"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_image (W, H, D : in Interfaces.C.int) return Storage.Integer_Address; @@ -30,6 +52,18 @@ package body FLTK.Images is + -- Errors -- + + function fl_image_fail + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_fail, "fl_image_fail"); + + + + + -- Copying -- + function fl_image_get_rgb_scaling return Interfaces.C.int; pragma Import (C, fl_image_get_rgb_scaling, "fl_image_get_rgb_scaling"); @@ -56,6 +90,8 @@ package body FLTK.Images is + -- Colors -- + procedure fl_image_color_average (I : in Storage.Integer_Address; C : in Interfaces.C.int; @@ -71,6 +107,8 @@ package body FLTK.Images is + -- Activity -- + procedure fl_image_inactive (I : in Storage.Integer_Address); pragma Import (C, fl_image_inactive, "fl_image_inactive"); @@ -84,6 +122,8 @@ package body FLTK.Images is + -- Dimensions -- + function fl_image_w (I : in Storage.Integer_Address) return Interfaces.C.int; @@ -108,37 +148,10 @@ package body FLTK.Images is pragma Import (C, fl_image_ld, "fl_image_ld"); pragma Inline (fl_image_ld); - function fl_image_count - (I : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_image_count, "fl_image_count"); - pragma Inline (fl_image_count); - - - - - function fl_image_data - (I : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_image_data, "fl_image_data"); - pragma Inline (fl_image_data); - - function fl_image_get_pixel - (C : in Interfaces.C.Strings.chars_ptr; - O : in Interfaces.C.int) - return Interfaces.C.unsigned_char; - pragma Import (C, fl_image_get_pixel, "fl_image_get_pixel"); - pragma Inline (fl_image_get_pixel); - - procedure fl_image_set_pixel - (C : in Interfaces.C.Strings.chars_ptr; - O : in Interfaces.C.int; - V : in Interfaces.C.unsigned_char); - pragma Import (C, fl_image_set_pixel, "fl_image_set_pixel"); - pragma Inline (fl_image_set_pixel); + -- Drawing -- procedure fl_image_draw (I : in Storage.Integer_Address; @@ -161,6 +174,31 @@ package body FLTK.Images is + ------------------------ + -- Internal Utility -- + ------------------------ + + procedure Raise_Fail_Errors + (This : in Image'Class) + is + 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; + elsif Result = fl_image_err_file_access then + raise File_Access_Error; + elsif Result = fl_image_err_format then + raise Format_Error; + end if; + end Raise_Fail_Errors; + + + + + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out Image) is begin @@ -174,7 +212,7 @@ package body FLTK.Images is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -188,18 +226,20 @@ package body FLTK.Images is (Interfaces.C.int (Width), Interfaces.C.int (Height), Interfaces.C.int (Depth)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; end return; end Create; end Forge; + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + function Get_Copy_Algorithm return Scaling_Kind is begin @@ -240,9 +280,7 @@ package body FLTK.Images is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Image; @@ -265,9 +303,7 @@ package body FLTK.Images is - ---------------- -- Activity -- - ---------------- procedure Inactive (This : in out Image) is @@ -280,7 +316,7 @@ package body FLTK.Images is (This : in Image) return Boolean is begin - return fl_image_fail (This.Void_Ptr) /= 0; + return fl_image_count (This.Void_Ptr) = 0 or This.Get_W = 0 or This.Get_H = 0; end Is_Empty; @@ -293,9 +329,7 @@ package body FLTK.Images is - ------------------ -- Dimensions -- - ------------------ function Get_W (This : in Image) @@ -321,131 +355,17 @@ package body FLTK.Images is end Get_D; - function Get_Line_Data + function Get_Line_Size (This : in Image) return Natural is begin return Natural (fl_image_ld (This.Void_Ptr)); - end Get_Line_Data; - - - function Get_Data_Count - (This : in Image) - return Natural is - begin - return Natural (fl_image_count (This.Void_Ptr)); - end Get_Data_Count; - - - function Get_Data_Size - (This : in Image) - return Natural - is - My_Depth : Natural := This.Get_D; - My_Line_Data : Natural := This.Get_Line_Data; - begin - if My_Line_Data > 0 then - return My_Line_Data * This.Get_H; - elsif My_Depth = 0 then - return Integer (Float'Ceiling (Float (This.Get_W) / 8.0)) * This.Get_H; - else - return This.Get_W * My_Depth * This.Get_H; - end if; - end Get_Data_Size; - - + end Get_Line_Size; - ------------------ - -- Pixel Data -- - ------------------ - - function Get_Datum - (This : in Image; - Data : in Positive; - Position : in Positive) - return Color_Component - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - begin - return Color_Component - (fl_image_get_pixel (Pointers (Data), Interfaces.C.int (Position) - 1)); - end Get_Datum; - - - procedure Set_Datum - (This : in out Image; - Data : in Positive; - Position : in Positive; - Value : in Color_Component) - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - begin - fl_image_set_pixel - (Pointers (Data), - Interfaces.C.int (Position) - 1, - Interfaces.C.unsigned_char (Value)); - end Set_Datum; - - - function Get_Data - (This : in Image; - Data : in Positive; - Position : in Positive; - Count : in Natural) - return Color_Component_Array - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - Result : Color_Component_Array := (1 .. Count => 0); - begin - for Index in Result'Range loop - Result (Index) := Color_Component (fl_image_get_pixel - (Pointers (Data), - Interfaces.C.int (Index - 1 + Position - 1))); - end loop; - return Result; - end Get_Data; - - - function All_Data - (This : in Image; - Data : in Positive) - return Color_Component_Array is - begin - return This.Get_Data (Data, 1, This.Get_Data_Size); - end All_Data; - - - procedure Update_Data - (This : in out Image; - Data : in Positive; - Position : in Positive; - Values : in Color_Component_Array) - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - begin - for Counter in Integer range 0 .. Values'Length - 1 loop - fl_image_set_pixel - (Pointers (Data), - Interfaces.C.int (Position - 1 + Counter), - Interfaces.C.unsigned_char (Values (Values'First + Counter))); - end loop; - end Update_Data; - - - --------------- -- Drawing -- - --------------- procedure Draw (This : in Image; @@ -459,9 +379,9 @@ package body FLTK.Images is procedure Draw - (This : in Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0) is + (This : in Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is begin fl_image_draw2 (This.Void_Ptr, @@ -469,8 +389,8 @@ package body FLTK.Images is Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.int (CX), - Interfaces.C.int (CY)); + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); end Draw; @@ -487,3 +407,4 @@ package body FLTK.Images is end FLTK.Images; + 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 006db6b..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 @@ -16,6 +21,8 @@ package body FLTK.Labels is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_label (V : in Interfaces.C.Strings.chars_ptr; F : in Interfaces.C.int; @@ -35,6 +42,14 @@ 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); @@ -114,6 +129,8 @@ package body FLTK.Labels is + -- Drawing -- + procedure fl_label_draw (L : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int; @@ -130,26 +147,27 @@ package body FLTK.Labels is - ----------------------------------- - -- Controlled Type Subprograms -- - ----------------------------------- + ------------------- + -- Destructors -- + ------------------- procedure Finalize (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; - ----------------- - -- Label API -- - ----------------- + -------------------- + -- Constructors -- + -------------------- package body Forge is @@ -175,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; @@ -183,11 +202,23 @@ package body FLTK.Labels is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Attributes -- + 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; @@ -325,6 +356,8 @@ package body FLTK.Labels is + -- Drawing -- + procedure Draw (This : in out Label; X, Y, W, H : in Integer; @@ -339,6 +372,7 @@ package body FLTK.Labels is Interfaces.C.unsigned (Place)); end Draw; + procedure Measure (This : in Label; W, H : out Integer) is diff --git a/body/fltk-menu_items.adb b/body/fltk-menu_items.adb index d68eb60..d75dd4a 100644 --- a/body/fltk-menu_items.adb +++ b/body/fltk-menu_items.adb @@ -23,6 +23,12 @@ package body FLTK.Menu_Items is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + function new_fl_menu_item (T : in Interfaces.C.char_array; C : in Storage.Integer_Address; @@ -39,6 +45,8 @@ package body FLTK.Menu_Items is + -- Callback -- + function fl_menu_item_get_user_data (MI : in Storage.Integer_Address) return Storage.Integer_Address; @@ -58,6 +66,8 @@ package body FLTK.Menu_Items is + -- Settings -- + function fl_menu_item_checkbox (MI : in Storage.Integer_Address) return Interfaces.C.int; @@ -100,6 +110,8 @@ package body FLTK.Menu_Items is + -- Label -- + function fl_menu_item_get_label (MI : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -170,6 +182,8 @@ package body FLTK.Menu_Items is + -- Shortcut and Flags -- + function fl_menu_item_get_shortcut (MI : in Storage.Integer_Address) return Interfaces.C.int; @@ -197,6 +211,8 @@ package body FLTK.Menu_Items is + -- Image -- + procedure fl_menu_item_image (MI, I : in Storage.Integer_Address); pragma Import (C, fl_menu_item_image, "fl_menu_item_image"); @@ -205,6 +221,8 @@ package body FLTK.Menu_Items is + -- Activity and Visibility -- + procedure fl_menu_item_activate (MI : in Storage.Integer_Address); pragma Import (C, fl_menu_item_activate, "fl_menu_item_activate"); @@ -246,6 +264,10 @@ package body FLTK.Menu_Items is + ------------------- + -- Destructors -- + ------------------- + procedure Finalize (This : in out Menu_Item) is begin @@ -258,6 +280,10 @@ package body FLTK.Menu_Items is + -------------------- + -- Constructors -- + -------------------- + package body Forge is function Create @@ -271,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; @@ -283,6 +309,12 @@ package body FLTK.Menu_Items is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Callback -- + function Get_Callback (This : in Menu_Item) return FLTK.Widgets.Widget_Callback is @@ -312,6 +344,8 @@ package body FLTK.Menu_Items is + -- Settings -- + function Has_Checkbox (This : in Menu_Item) return Boolean is @@ -379,11 +413,13 @@ package body FLTK.Menu_Items is + -- Label -- + function Get_Label (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 ""; @@ -430,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 @@ -452,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 @@ -474,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 @@ -494,11 +530,13 @@ package body FLTK.Menu_Items is + -- Shortcut and Flags -- + function Get_Shortcut (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; @@ -514,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; @@ -522,12 +560,14 @@ 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; + -- Image -- + function Get_Image (This : in Menu_Item) return access FLTK.Images.Image'Class is @@ -547,6 +587,8 @@ package body FLTK.Menu_Items is + -- Activity and Visibility -- + procedure Activate (This : in out Menu_Item) is begin diff --git a/body/fltk-pixmap_marshal.adb b/body/fltk-pixmap_marshal.adb new file mode 100644 index 0000000..966e29b --- /dev/null +++ b/body/fltk-pixmap_marshal.adb @@ -0,0 +1,98 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Strings.Fixed, + Ada.Strings.Unbounded, + Ada.Unchecked_Deallocation, + FLTK.Images.Pixmaps; + + +package body FLTK.Pixmap_Marshal is + + + package SU renames Ada.Strings.Unbounded; + package Pix renames FLTK.Images.Pixmaps; + package C renames Interfaces.C; + package CS renames Interfaces.C.Strings; + + + + + function To_Coltype + (Value : in Pix.Color_Kind) + return Character is + begin + case Value is + when Pix.Colorful => return 'c'; + when Pix.Monochrome => return 'm'; + when Pix.Greyscale => return 'g'; + when Pix.Symbolic => return 's'; + end case; + end To_Coltype; + + + + + function Marshal_Data + (Values : in Pix.Header; + Colors : in Pix.Color_Definition_Array; + Pixels : in Pix.Pixmap_Data) + return chars_ptr_array_access + is + 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 + C_Data (1) := CS.New_String (Ada.Strings.Fixed.Trim + ((Positive'Image (Values.Width) & Positive'Image (Values.Height) & + Positive'Image (Values.Colors) & Positive'Image (Values.Per_Pixel)), + Ada.Strings.Left)); + + -- Color definition lines + for Place in 1 .. Colors'Length loop + C_Data (C.size_t (Place + 1)) := CS.New_String + (SU.To_String (Colors (Colors'First + Place - 1).Name) & " " & + To_Coltype (Colors (Colors'First + Place - 1).Kind) & " " & + SU.To_String (Colors (Colors'First + Place - 1).Value)); + end loop; + + -- Pixel data lines + for Place in 1 .. Pixels'Length (1) loop + declare + Line : String (1 .. Pixels'Length (2)); + for Line'Address use Pixels (Pixels'First (1) + Place - 1, 1)'Address; + pragma Import (Ada, Line); + begin + C_Data (C.size_t (Place + 1 + Colors'Length)) := CS.New_String (Line); + end; + end loop; + + return C_Data; + end Marshal_Data; + + + + + procedure Free is new Ada.Unchecked_Deallocation + (Interfaces.C.Strings.chars_ptr_array, chars_ptr_array_access); + + procedure Free_Recursive + (This : in out chars_ptr_array_access) is + begin + if This /= null then + for Item of This.all loop + CS.Free (Item); + end loop; + Free (This); + end if; + end Free_Recursive; + + +end FLTK.Pixmap_Marshal; + + diff --git a/body/fltk-pixmap_marshal.ads b/body/fltk-pixmap_marshal.ads new file mode 100644 index 0000000..d12b0f8 --- /dev/null +++ b/body/fltk-pixmap_marshal.ads @@ -0,0 +1,44 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Images.Pixmaps; + +with + + Interfaces.C.Strings; + + +private package FLTK.Pixmap_Marshal is + + + type chars_ptr_array_access is access all Interfaces.C.Strings.chars_ptr_array; + + + + + -- From Ada to C char * -- + + -- Note the resulting chars_ptr_array_access must be deallocated manually. + + function To_Coltype + (Value : in FLTK.Images.Pixmaps.Color_Kind) + return Character; + + function Marshal_Data + (Values : in FLTK.Images.Pixmaps.Header; + Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; + Pixels : in FLTK.Images.Pixmaps.Pixmap_Data) + return chars_ptr_array_access; + + procedure Free_Recursive + (This : in out chars_ptr_array_access); + + +end FLTK.Pixmap_Marshal; + + 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 ad25cbe..6b8118e 100644 --- a/body/fltk-screen.adb +++ b/body/fltk-screen.adb @@ -16,6 +16,47 @@ use type package body FLTK.Screen is + ------------------------ + -- Constants From C -- + ------------------------ + + fl_enum_mode_rgb : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_rgb, "fl_enum_mode_rgb"); + + fl_enum_mode_rgb8 : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_rgb8, "fl_enum_mode_rgb8"); + + fl_enum_mode_double : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_double, "fl_enum_mode_double"); + + fl_enum_mode_index : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_index, "fl_enum_mode_index"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- 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 return Interfaces.C.int; pragma Import (C, fl_screen_x, "fl_screen_x"); @@ -39,6 +80,8 @@ package body FLTK.Screen is + -- Pixel Density -- + function fl_screen_count return Interfaces.C.int; pragma Import (C, fl_screen_count, "fl_screen_count"); @@ -53,6 +96,8 @@ package body FLTK.Screen is + -- Position Lookup -- + function fl_screen_num (X, Y : in Interfaces.C.int) return Interfaces.C.int; @@ -68,6 +113,8 @@ package body FLTK.Screen is + -- Bounding Boxes -- + procedure fl_screen_work_area (X, Y, W, H : out Interfaces.C.int; PX, PY : in Interfaces.C.int); @@ -85,9 +132,6 @@ package body FLTK.Screen is pragma Import (C, fl_screen_work_area3, "fl_screen_work_area3"); pragma Inline (fl_screen_work_area3); - - - procedure fl_screen_xywh (X, Y, W, H : out Interfaces.C.int; PX, PY : in Interfaces.C.int); @@ -114,6 +158,61 @@ 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 begin return Integer (fl_screen_x); @@ -140,6 +239,8 @@ package body FLTK.Screen is + -- Pixel Density -- + function Count return Integer is begin return Integer (fl_screen_count); @@ -160,6 +261,8 @@ package body FLTK.Screen is + -- Position Lookup -- + function Containing (X, Y : in Integer) return Integer is @@ -184,6 +287,8 @@ package body FLTK.Screen is + -- Bounding Boxes -- + procedure Work_Area (X, Y, W, H : out Integer; Pos_X, Pos_Y : in Integer) is @@ -222,8 +327,6 @@ package body FLTK.Screen is end Work_Area; - - procedure Bounding_Rect (X, Y, W, H : out Integer; Pos_X, Pos_Y : in Integer) is @@ -278,5 +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 56b30c0..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,19 +29,99 @@ package body FLTK.Static is - procedure fl_static_add_awake_handler - (H, F : in Storage.Integer_Address); + ----------------- + -- 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 -- + ------------------------ + + -- Command Line Arguments -- + + 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); + + -- Pre-Eventloop Callbacks -- + procedure fl_static_add_check (H, F : in Storage.Integer_Address); pragma Import (C, fl_static_add_check, "fl_static_add_check"); @@ -59,6 +141,8 @@ package body FLTK.Static is + -- Timer Callbacks -- + procedure fl_static_add_timeout (S : in Interfaces.C.double; H, F : in Storage.Integer_Address); @@ -85,13 +169,22 @@ package body FLTK.Static is + -- Clipboard Callbacks -- + procedure fl_static_add_clipboard_notify (H, F : in Storage.Integer_Address); pragma Import (C, fl_static_add_clipboard_notify, "fl_static_add_clipboard_notify"); 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); + + + -- File Descriptor Waiting Callbacks -- procedure fl_static_add_fd (D : in Interfaces.C.int; @@ -118,6 +211,8 @@ package body FLTK.Static is + -- Idle Callbacks -- + procedure fl_static_add_idle (H, F : in Storage.Integer_Address); pragma Import (C, fl_static_add_idle, "fl_static_add_idle"); @@ -137,12 +232,25 @@ 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); @@ -155,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"); @@ -173,6 +292,8 @@ package body FLTK.Static is + -- Custom Fonts -- + function fl_static_get_font (K : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr; @@ -190,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) @@ -212,6 +339,8 @@ package body FLTK.Static is + -- Box_Kind Attributes -- + function fl_static_box_dh (B : in Interfaces.C.int) return Interfaces.C.int; @@ -236,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"); @@ -249,6 +391,19 @@ 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 (T : in Interfaces.C.char_array; L, K : in Interfaces.C.int); @@ -268,8 +423,21 @@ 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; @@ -284,21 +452,10 @@ package body FLTK.Static is - 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); @@ -326,6 +483,8 @@ package body FLTK.Static is + -- Queue -- + function fl_static_readqueue return Storage.Integer_Address; pragma Import (C, fl_static_readqueue, "fl_static_readqueue"); @@ -334,6 +493,8 @@ package body FLTK.Static is + -- Schemes -- + function fl_static_get_scheme return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_static_get_scheme, "fl_static_get_scheme"); @@ -353,6 +514,8 @@ package body FLTK.Static is + -- Library Options -- + function fl_static_get_option (O : in Interfaces.C.int) return Interfaces.C.int; @@ -367,6 +530,8 @@ package body FLTK.Static is + -- Scrollbars -- + function fl_static_get_scrollbar_size return Interfaces.C.int; pragma Import (C, fl_static_get_scrollbar_size, "fl_static_get_scrollbar_size"); @@ -380,6 +545,8 @@ package body FLTK.Static is + -- User Data -- + package Widget_Convert is new System.Address_To_Access_Conversions (FLTK.Widgets.Widget'Class); package Window_Convert is new System.Address_To_Access_Conversions @@ -393,6 +560,41 @@ 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); @@ -400,15 +602,173 @@ 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; + procedure Timeout_Hook + (U : in Storage.Integer_Address); + pragma Convention (C, Timeout_Hook); + + procedure Timeout_Hook + (U : in Storage.Integer_Address) is + begin + Conv.To_Timeout_Access (U).all; + end Timeout_Hook; + + + -- This is handled on the Ada side because otherwise there would be + -- no way to specify which callback to remove in FLTK once one was + -- added. 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); + + Current_Clip_Notes : Clipboard_Notify_Vectors.Vector; + + procedure Clipboard_Notify_Hook + (S : in Interfaces.C.int; + U : in Storage.Integer_Address); + pragma Convention (C, Clipboard_Notify_Hook); + + procedure Clipboard_Notify_Hook + (S : in Interfaces.C.int; + U : in Storage.Integer_Address) is + begin + 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; + + + procedure FD_Hook + (FD : in Interfaces.C.int; + U : in Storage.Integer_Address); + pragma Convention (C, FD_Hook); + + procedure FD_Hook + (FD : in Interfaces.C.int; + U : in Storage.Integer_Address) is + begin + Conv.To_File_Access (U).all (File_Descriptor (FD)); + end FD_Hook; + + + procedure Idle_Hook + (U : in Storage.Integer_Address); + pragma Convention (C, Idle_Hook); + + procedure Idle_Hook + (U : in Storage.Integer_Address) is + begin + Conv.To_Idle_Access (U).all; + end Idle_Hook; + + + + + ------------------- + -- 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 -- + ----------------------- + + -- 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; @@ -416,132 +776,140 @@ 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 Timeout_Hook - (U : in Storage.Integer_Address); - pragma Convention (C, Timeout_Hook); - - procedure Timeout_Hook - (U : in Storage.Integer_Address) is + procedure Awake is begin - Conv.To_Timeout_Access (U).all; - end Timeout_Hook; + 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; + -- 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; - -- This is handled on the Ada side because otherwise there would be - -- no way to specify which callback to remove in FLTK once one was - -- added. The hook is passed during package init. - package Clipboard_Notify_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, - Element_Type => Clipboard_Notify_Handler); - - Current_Clip_Notes : Clipboard_Notify_Vectors.Vector; - - procedure Clipboard_Notify_Hook - (S : in Interfaces.C.int; - U : in Storage.Integer_Address); - pragma Convention (C, Clipboard_Notify_Hook); - - procedure Clipboard_Notify_Hook - (S : in Interfaces.C.int; - U : in Storage.Integer_Address) is - begin - for Call of Current_Clip_Notes loop - Call.all (Buffer_Kind'Val (S)); - end loop; - end Clipboard_Notify_Hook; - + -- Clipboard Callbacks -- procedure Add_Clipboard_Notify - (Func : in Clipboard_Notify_Handler) is + (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; @@ -552,22 +920,11 @@ package body FLTK.Static is - procedure FD_Hook - (FD : in Interfaces.C.int; - U : in Storage.Integer_Address); - pragma Convention (C, FD_Hook); - - procedure FD_Hook - (FD : in Interfaces.C.int; - U : in Storage.Integer_Address) is - begin - Conv.To_File_Access (U).all (File_Descriptor (FD)); - end FD_Hook; - + -- File Descriptor Waiting Callbacks -- procedure Add_File_Descriptor - (FD : in File_Descriptor; - 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), @@ -577,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; @@ -600,53 +957,54 @@ 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; - procedure Idle_Hook - (U : in Storage.Integer_Address); - pragma Convention (C, Idle_Hook); - - procedure Idle_Hook - (U : in Storage.Integer_Address) is - begin - Conv.To_Idle_Access (U).all; - end Idle_Hook; - + -- Idle Callbacks -- procedure Add_Idle - (Func : in Idle_Handler) is + (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; + -- 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 @@ -660,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)); @@ -681,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 @@ -713,6 +1095,8 @@ package body FLTK.Static is + -- Custom Fonts -- + function Font_Image (Kind : in Font_Kind) return String is @@ -732,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; @@ -755,14 +1149,22 @@ 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; + -- Box_Kind Attributes -- + function Get_Box_Height_Offset (Kind : in Box_Kind) return Integer is @@ -809,26 +1211,59 @@ 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 Integer := 0; - -- Offset_W, Offset_H : in Integer := 0) is - -- begin - -- null; - -- end Set_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; + -- 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; + + + + + -- Clipboard / Selection -- + procedure Copy (Text : in String; Dest : in Buffer_Kind) is @@ -861,6 +1296,23 @@ 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 @@ -879,26 +1331,18 @@ package body FLTK.Static is - 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; @@ -915,7 +1359,8 @@ package body FLTK.Static is end if; return Actual_First; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::first_window did not have user_data reference back to Ada"; end Get_First_Window; @@ -940,7 +1385,8 @@ package body FLTK.Static is end if; return Actual_Next; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::next_window did not have user_data reference back to Ada"; end Get_Next_Window; @@ -957,12 +1403,15 @@ package body FLTK.Static is end if; return Actual_Modal; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::modal did not have user_data reference back to Ada"; end Get_Top_Modal; + -- Queue -- + function Read_Queue return access FLTK.Widgets.Widget'Class is @@ -976,16 +1425,19 @@ package body FLTK.Static is end if; return Actual_Queue; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::readqueue did not have user_data reference back to Ada"; end Read_Queue; + -- Schemes -- + 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 ""; @@ -998,20 +1450,29 @@ 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; + -- Library Options -- + function Get_Option (Opt : in Option) return Boolean is @@ -1030,10 +1491,18 @@ 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; @@ -1053,3 +1522,4 @@ begin end FLTK.Static; + diff --git a/body/fltk-text_buffers.adb b/body/fltk-text_buffers.adb index 1afa2a7..a870ece 100644 --- a/body/fltk-text_buffers.adb +++ b/body/fltk-text_buffers.adb @@ -24,6 +24,12 @@ use type package body FLTK.Text_Buffers is + ------------------------ + -- Functions From C -- + ------------------------ + + -- Errors -- + function strerror (Errnum : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr; @@ -32,6 +38,8 @@ package body FLTK.Text_Buffers is + -- Allocation -- + function new_fl_text_buffer (RS, PGS : in Interfaces.C.int) return Storage.Integer_Address; @@ -46,6 +54,8 @@ package body FLTK.Text_Buffers is + -- Callbacks -- + procedure fl_text_buffer_add_modify_callback (TB, CB, UD : in Storage.Integer_Address); pragma Import (C, fl_text_buffer_add_modify_callback, @@ -73,6 +83,8 @@ package body FLTK.Text_Buffers is + -- Files -- + function fl_text_buffer_loadfile (TB : in Storage.Integer_Address; N : in Interfaces.C.char_array; @@ -117,6 +129,8 @@ package body FLTK.Text_Buffers is + -- Modification -- + procedure fl_text_buffer_insert (TB : in Storage.Integer_Address; P : in Interfaces.C.int; @@ -193,6 +207,8 @@ package body FLTK.Text_Buffers is + -- Measurement -- + function fl_text_buffer_count_displayed_characters (TB : in Storage.Integer_Address; S, F : in Interfaces.C.int) @@ -229,6 +245,8 @@ package body FLTK.Text_Buffers is + -- Selection -- + function fl_text_buffer_selection_position (TB : in Storage.Integer_Address; S, E : out Interfaces.C.int) @@ -318,6 +336,8 @@ package body FLTK.Text_Buffers is + -- Highlighting -- + procedure fl_text_buffer_highlight (TB : in Storage.Integer_Address; F, T : in Interfaces.C.int); @@ -338,6 +358,8 @@ package body FLTK.Text_Buffers is + -- Search -- + function fl_text_buffer_findchar_forward (TB : in Storage.Integer_Address; SP : in Interfaces.C.int; @@ -379,6 +401,8 @@ package body FLTK.Text_Buffers is + -- Navigation -- + function fl_text_buffer_word_start (TB : in Storage.Integer_Address; P : in Interfaces.C.int) @@ -439,6 +463,8 @@ package body FLTK.Text_Buffers is + -- Miscellaneous -- + procedure fl_text_buffer_canundo (TB : in Storage.Integer_Address; F : in Interfaces.C.char); @@ -461,6 +487,10 @@ package body FLTK.Text_Buffers is + ---------------------- + -- Callback Hooks -- + ---------------------- + procedure Modify_Callback_Hook (Pos : in Interfaces.C.int; Inserted, Deleted, Restyled : in Interfaces.C.int; @@ -468,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 @@ -504,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 @@ -520,6 +550,10 @@ package body FLTK.Text_Buffers is + ------------------- + -- Destructors -- + ------------------- + procedure Finalize (This : in out Text_Buffer) is begin @@ -532,6 +566,10 @@ package body FLTK.Text_Buffers is + -------------------- + -- Constructors -- + -------------------- + package body Forge is function Create @@ -559,6 +597,12 @@ package body FLTK.Text_Buffers is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Callbacks -- + procedure Add_Modify_Callback (This : in out Text_Buffer; Func : in Modify_Callback) is @@ -631,15 +675,17 @@ package body FLTK.Text_Buffers is + -- Files -- + procedure Load_File (This : in out Text_Buffer; 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)); @@ -652,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)); @@ -669,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), @@ -687,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), @@ -705,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)); @@ -718,15 +764,17 @@ package body FLTK.Text_Buffers is + -- Modification -- + procedure Insert_Text (This : in out Text_Buffer; Place : in Position; 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; @@ -758,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; @@ -775,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; @@ -808,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; @@ -819,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; @@ -860,6 +908,8 @@ package body FLTK.Text_Buffers is + -- Measurement -- + function Count_Displayed_Characters (This : in Text_Buffer; Start, Finish : in Position) @@ -910,6 +960,8 @@ package body FLTK.Text_Buffers is + -- Selection -- + function Get_Selection (This : in Text_Buffer; Start, Finish : out Position) @@ -949,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; @@ -993,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; @@ -1013,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; @@ -1068,6 +1120,8 @@ package body FLTK.Text_Buffers is + -- Highlighting -- + procedure Get_Highlight (This : in Text_Buffer; Start, Finish : out Position) is @@ -1101,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; @@ -1119,6 +1173,8 @@ package body FLTK.Text_Buffers is + -- Search -- + function Findchar_Forward (This : in Text_Buffer; Start_At : in Position; @@ -1217,6 +1273,8 @@ package body FLTK.Text_Buffers is + -- Navigation -- + function Word_Start (This : in Text_Buffer; Place : in Position) @@ -1266,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; @@ -1282,9 +1340,9 @@ package body FLTK.Text_Buffers is return Position is begin return Natural (fl_text_buffer_skip_lines - (This.Void_Ptr, - Interfaces.C.int (Start), - Interfaces.C.int (Lines))); + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Lines))); end Skip_Lines; @@ -1295,9 +1353,9 @@ package body FLTK.Text_Buffers is return Position is begin return Natural (fl_text_buffer_rewind_lines - (This.Void_Ptr, - Interfaces.C.int (Start), - Interfaces.C.int (Lines))); + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Lines))); end Rewind_Lines; @@ -1316,6 +1374,8 @@ package body FLTK.Text_Buffers is + -- Miscellaneous -- + procedure Can_Undo (This : in out Text_Buffer; Flag : in Boolean) is @@ -1350,3 +1410,4 @@ package body FLTK.Text_Buffers is end FLTK.Text_Buffers; + diff --git a/body/fltk-tooltips.adb b/body/fltk-tooltips.adb index ccdb649..8382bb4 100644 --- a/body/fltk-tooltips.adb +++ b/body/fltk-tooltips.adb @@ -27,6 +27,8 @@ package body FLTK.Tooltips is -- Functions From C -- ------------------------ + -- Activity -- + function fl_tooltip_get_current return Storage.Integer_Address; pragma Import (C, fl_tooltip_get_current, "fl_tooltip_get_current"); @@ -61,6 +63,8 @@ package body FLTK.Tooltips is + -- Delay -- + function fl_tooltip_get_delay return Interfaces.C.C_float; pragma Import (C, fl_tooltip_get_delay, "fl_tooltip_get_delay"); @@ -84,6 +88,8 @@ package body FLTK.Tooltips is + -- Color, Margins, Wrap -- + function fl_tooltip_get_color return Interfaces.C.unsigned; pragma Import (C, fl_tooltip_get_color, "fl_tooltip_get_color"); @@ -127,6 +133,8 @@ package body FLTK.Tooltips is + -- Text Settings -- + function fl_tooltip_get_textcolor return Interfaces.C.unsigned; pragma Import (C, fl_tooltip_get_textcolor, "fl_tooltip_get_textcolor"); @@ -160,6 +168,8 @@ package body FLTK.Tooltips is + -- User Data -- + function fl_widget_get_user_data (W : in Storage.Integer_Address) return Storage.Integer_Address; @@ -176,6 +186,8 @@ package body FLTK.Tooltips is -- API Subprograms -- ----------------------- + -- Activity -- + function Get_Target return access FLTK.Widgets.Widget'Class is @@ -189,7 +201,8 @@ package body FLTK.Tooltips is end if; return Actual_Widget; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Tooltip::current did not have user_data reference back to Ada"; end Get_Target; @@ -237,6 +250,8 @@ package body FLTK.Tooltips is + -- Delay -- + function Get_Delay return Float is begin @@ -267,6 +282,8 @@ package body FLTK.Tooltips is + -- Color, Margins, Wrap -- + function Get_Background_Color return Color is begin @@ -325,6 +342,8 @@ package body FLTK.Tooltips is + -- Text Settings -- + function Get_Text_Color return Color is begin diff --git a/body/fltk-widgets-boxes.adb b/body/fltk-widgets-boxes.adb index e412131..efe6e54 100644 --- a/body/fltk-widgets-boxes.adb +++ b/body/fltk-widgets-boxes.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Boxes is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_box (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -39,6 +41,8 @@ package body FLTK.Widgets.Boxes is + -- Drawing, Events -- + procedure fl_box_draw (W : in Storage.Integer_Address); pragma Import (C, fl_box_draw, "fl_box_draw"); @@ -82,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; @@ -170,6 +198,8 @@ package body FLTK.Widgets.Boxes is -- API Subprograms -- ----------------------- + -- Drawing, Events -- + procedure Draw (This : in out Box) is begin diff --git a/body/fltk-widgets-buttons-enter.adb b/body/fltk-widgets-buttons-enter.adb index 3a9e026..35e0391 100644 --- a/body/fltk-widgets-buttons-enter.adb +++ b/body/fltk-widgets-buttons-enter.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons.Enter is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_return_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons.Enter is + -- Drawing, Events -- + procedure fl_return_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_return_button_draw, "fl_return_button_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Buttons.Enter is begin return This : Enter_Button do This.Void_Ptr := new_fl_return_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -131,6 +135,8 @@ package body FLTK.Widgets.Buttons.Enter is -- API Subprograms -- ----------------------- + -- Drawing, Events -- + procedure Draw (This : in out Enter_Button) is begin diff --git a/body/fltk-widgets-buttons-light-check.adb b/body/fltk-widgets-buttons-light-check.adb index de35223..c3f1971 100644 --- a/body/fltk-widgets-buttons-light-check.adb +++ b/body/fltk-widgets-buttons-light-check.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons.Light.Check is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_check_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons.Light.Check is + -- Drawing, Events -- + procedure fl_check_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_check_button_draw, "fl_check_button_draw"); @@ -51,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 @@ -141,11 +129,11 @@ package body FLTK.Widgets.Buttons.Light.Check is begin return This : Check_Button do This.Void_Ptr := new_fl_check_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-buttons-light-radio.adb b/body/fltk-widgets-buttons-light-radio.adb index 9aef7bd..d65e1b0 100644 --- a/body/fltk-widgets-buttons-light-radio.adb +++ b/body/fltk-widgets-buttons-light-radio.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons.Light.Radio is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_radio_light_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons.Light.Radio is + -- Drawing, Events -- + procedure fl_radio_light_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_radio_light_button_draw, "fl_radio_light_button_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Buttons.Light.Radio is begin return This : Radio_Light_Button do This.Void_Ptr := new_fl_radio_light_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-buttons-light-round-radio.adb b/body/fltk-widgets-buttons-light-round-radio.adb index b277922..05745e1 100644 --- a/body/fltk-widgets-buttons-light-round-radio.adb +++ b/body/fltk-widgets-buttons-light-round-radio.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons.Light.Round.Radio is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_radio_round_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons.Light.Round.Radio is + -- Drawing, Events -- + procedure fl_radio_round_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_radio_round_button_draw, "fl_radio_round_button_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Buttons.Light.Round.Radio is begin return This : Radio_Round_Button do This.Void_Ptr := new_fl_radio_round_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-buttons-light-round.adb b/body/fltk-widgets-buttons-light-round.adb index 172c112..5798bf3 100644 --- a/body/fltk-widgets-buttons-light-round.adb +++ b/body/fltk-widgets-buttons-light-round.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons.Light.Round is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_round_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons.Light.Round is + -- Drawing, Events -- + procedure fl_round_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_round_button_draw, "fl_round_button_draw"); @@ -100,11 +104,11 @@ package body FLTK.Widgets.Buttons.Light.Round is begin return This : Round_Button do This.Void_Ptr := new_fl_round_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-buttons-light.adb b/body/fltk-widgets-buttons-light.adb index 3e4791a..4da348f 100644 --- a/body/fltk-widgets-buttons-light.adb +++ b/body/fltk-widgets-buttons-light.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons.Light is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_light_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons.Light is + -- Drawing, Events -- + procedure fl_light_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_light_button_draw, "fl_light_button_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Buttons.Light is begin return This : Light_Button do This.Void_Ptr := new_fl_light_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -131,6 +135,8 @@ package body FLTK.Widgets.Buttons.Light is -- API Subprograms -- ----------------------- + -- Drawing, Events -- + procedure Draw (This : in out Light_Button) is begin diff --git a/body/fltk-widgets-buttons-radio.adb b/body/fltk-widgets-buttons-radio.adb index b51af60..28dfb3d 100644 --- a/body/fltk-widgets-buttons-radio.adb +++ b/body/fltk-widgets-buttons-radio.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons.Radio is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_radio_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons.Radio is + -- Drawing, Events -- + procedure fl_radio_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_radio_button_draw, "fl_radio_button_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Buttons.Radio is begin return This : Radio_Button do This.Void_Ptr := new_fl_radio_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-buttons-repeat.adb b/body/fltk-widgets-buttons-repeat.adb index eda24fd..51e75a4 100644 --- a/body/fltk-widgets-buttons-repeat.adb +++ b/body/fltk-widgets-buttons-repeat.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons.Repeat is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_repeat_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons.Repeat is + -- Activity -- + procedure fl_repeat_button_deactivate (B : in Storage.Integer_Address); pragma Import (C, fl_repeat_button_deactivate, "fl_repeat_button_deactivate"); @@ -40,6 +44,8 @@ package body FLTK.Widgets.Buttons.Repeat is + -- Drawing, Events -- + procedure fl_repeat_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_repeat_button_draw, "fl_repeat_button_draw"); @@ -109,11 +115,11 @@ package body FLTK.Widgets.Buttons.Repeat is begin return This : Repeat_Button do This.Void_Ptr := new_fl_repeat_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -139,6 +145,8 @@ package body FLTK.Widgets.Buttons.Repeat is -- API Subprograms -- ----------------------- + -- Activity -- + procedure Deactivate (This : in out Repeat_Button) is begin @@ -148,6 +156,8 @@ package body FLTK.Widgets.Buttons.Repeat is + -- Events -- + function Handle (This : in out Repeat_Button; Event : in Event_Kind) diff --git a/body/fltk-widgets-buttons-toggle.adb b/body/fltk-widgets-buttons-toggle.adb index a93fa36..1b96ea7 100644 --- a/body/fltk-widgets-buttons-toggle.adb +++ b/body/fltk-widgets-buttons-toggle.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons.Toggle is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_toggle_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons.Toggle is + -- Drawing, Events -- + procedure fl_toggle_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_toggle_button_draw, "fl_toggle_button_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Buttons.Toggle is begin return This : Toggle_Button do This.Void_Ptr := new_fl_toggle_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-buttons.adb b/body/fltk-widgets-buttons.adb index 1e7ef60..2d1e169 100644 --- a/body/fltk-widgets-buttons.adb +++ b/body/fltk-widgets-buttons.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Buttons is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Buttons is + -- State -- + function fl_button_get_state (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -52,6 +56,8 @@ package body FLTK.Widgets.Buttons is + -- Settings -- + function fl_button_get_down_box (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -79,6 +85,8 @@ package body FLTK.Widgets.Buttons is + -- Drawing, Events -- + procedure fl_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_button_draw, "fl_button_draw"); @@ -94,6 +102,8 @@ package body FLTK.Widgets.Buttons is + -- Miscellaneous -- + procedure fl_button_simulate_key_action (B : in Storage.Integer_Address); pragma Import (C, fl_button_simulate_key_action, "fl_button_simulate_key_action"); @@ -106,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 @@ -196,11 +190,11 @@ package body FLTK.Widgets.Buttons is begin return This : Button do This.Void_Ptr := new_fl_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -226,6 +220,8 @@ package body FLTK.Widgets.Buttons is -- API Subprograms -- ----------------------- + -- State -- + function Is_On (This : in Button) return Boolean is @@ -259,6 +255,8 @@ package body FLTK.Widgets.Buttons is + -- Settings -- + function Get_Down_Box (This : in Button) return Box_Kind is @@ -279,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; @@ -293,6 +291,8 @@ package body FLTK.Widgets.Buttons is + -- Drawing, Events -- + procedure Draw (This : in out Button) is begin @@ -311,6 +311,8 @@ package body FLTK.Widgets.Buttons is + -- Miscellaneous -- + procedure Simulate_Key_Action (This : in out Button) is begin diff --git a/body/fltk-widgets-charts.adb b/body/fltk-widgets-charts.adb index 2d4615d..b4a4bfe 100644 --- a/body/fltk-widgets-charts.adb +++ b/body/fltk-widgets-charts.adb @@ -21,6 +21,8 @@ package body FLTK.Widgets.Charts is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_chart (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -36,6 +38,8 @@ package body FLTK.Widgets.Charts is + -- Data -- + procedure fl_chart_add (C : in Storage.Integer_Address; V : in Interfaces.C.double; @@ -70,6 +74,8 @@ package body FLTK.Widgets.Charts is + -- Settings -- + function fl_chart_get_autosize (C : in Storage.Integer_Address) return Interfaces.C.int; @@ -115,6 +121,8 @@ package body FLTK.Widgets.Charts is + -- Text Settings -- + function fl_chart_get_textcolor (C : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -154,6 +162,8 @@ package body FLTK.Widgets.Charts is + -- Dimensions -- + procedure fl_chart_size2 (C : in Storage.Integer_Address; W, H : in Interfaces.C.int); @@ -163,6 +173,8 @@ package body FLTK.Widgets.Charts is + -- Drawing, Events -- + procedure fl_chart_draw (W : in Storage.Integer_Address); pragma Import (C, fl_chart_draw, "fl_chart_draw"); @@ -232,11 +244,11 @@ package body FLTK.Widgets.Charts is begin return This : Chart do This.Void_Ptr := new_fl_chart - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -262,6 +274,8 @@ package body FLTK.Widgets.Charts is -- API Subprograms -- ----------------------- + -- Data -- + procedure Add (This : in out Chart; Data_Value : in Long_Float; @@ -317,6 +331,8 @@ package body FLTK.Widgets.Charts is + -- Settings -- + function Will_Autosize (This : in Chart) return Boolean is @@ -381,6 +397,8 @@ package body FLTK.Widgets.Charts is + -- Text Settings -- + function Get_Text_Color (This : in Chart) return Color is @@ -431,6 +449,8 @@ package body FLTK.Widgets.Charts is + -- Dimensions -- + procedure Resize (This : in out Chart; W, H : in Integer) is @@ -441,6 +461,8 @@ package body FLTK.Widgets.Charts is + -- Drawing -- + procedure Draw (This : in out Chart) is begin diff --git a/body/fltk-widgets-clocks-updated-round.adb b/body/fltk-widgets-clocks-updated-round.adb index 4f4487b..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Clocks.Updated.Round is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_round_clock (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Clocks.Updated.Round is + -- Drawing, Events -- + procedure fl_round_clock_draw (W : in Storage.Integer_Address); pragma Import (C, fl_round_clock_draw, "fl_round_clock_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Clocks.Updated.Round is begin return This : Round_Clock do This.Void_Ptr := new_fl_round_clock - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-clocks-updated.adb b/body/fltk-widgets-clocks-updated.adb index 8b7d5e6..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Clocks.Updated is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_clock (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -40,6 +41,8 @@ package body FLTK.Widgets.Clocks.Updated is + -- Drawing, Events -- + procedure fl_clock_draw (W : in Storage.Integer_Address); pragma Import (C, fl_clock_draw, "fl_clock_draw"); @@ -109,11 +112,11 @@ package body FLTK.Widgets.Clocks.Updated is begin return This : Updated_Clock do This.Void_Ptr := new_fl_clock - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -139,12 +142,12 @@ package body FLTK.Widgets.Clocks.Updated is begin return This : Updated_Clock do This.Void_Ptr := new_fl_clock2 - (Box_Kind'Pos (Kind), - Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -171,6 +174,8 @@ package body FLTK.Widgets.Clocks.Updated is -- API Subprograms -- ----------------------- + -- Events -- + function Handle (This : in out Updated_Clock; Event : in Event_Kind) diff --git a/body/fltk-widgets-clocks.adb b/body/fltk-widgets-clocks.adb index 08be495..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Clocks is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_clock_output (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Clocks is + -- Individual Values -- + function fl_clock_output_get_hour (C : in Storage.Integer_Address) return Interfaces.C.int; @@ -53,6 +56,8 @@ package body FLTK.Widgets.Clocks is + -- Full Value -- + function fl_clock_output_get_value (C : in Storage.Integer_Address) return Interfaces.C.unsigned_long; @@ -74,6 +79,8 @@ package body FLTK.Widgets.Clocks is + -- Drawing, Events -- + procedure fl_clock_output_draw (W : in Storage.Integer_Address); pragma Import (C, fl_clock_output_draw, "fl_clock_output_draw"); @@ -149,11 +156,11 @@ package body FLTK.Widgets.Clocks is begin return This : Clock do This.Void_Ptr := new_fl_clock_output - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -179,6 +186,8 @@ package body FLTK.Widgets.Clocks is -- API Subprograms -- ----------------------- + -- Individual Values -- + function Get_Hour (This : in Clock) return Hour is @@ -205,6 +214,8 @@ package body FLTK.Widgets.Clocks is + -- Full Value -- + function Get_Time (This : in Clock) return Time_Value is @@ -237,6 +248,8 @@ package body FLTK.Widgets.Clocks is + -- Drawing -- + procedure Draw (This : in out Clock) is begin diff --git a/body/fltk-widgets-groups-browsers-check.adb b/body/fltk-widgets-groups-browsers-check.adb index 730dcd4..c519f31 100644 --- a/body/fltk-widgets-groups-browsers-check.adb +++ b/body/fltk-widgets-groups-browsers-check.adb @@ -20,6 +20,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_check_browser (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -35,6 +37,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is + -- Items -- + function fl_check_browser_add (C : in Storage.Integer_Address; S : in Interfaces.C.char_array; @@ -64,6 +68,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is + -- Checkmarking -- + procedure fl_check_browser_check_all (C : in Storage.Integer_Address); pragma Import (C, fl_check_browser_check_all, "fl_check_browser_check_all"); @@ -96,6 +102,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is + -- Text Selection -- + function fl_check_browser_text (C : in Storage.Integer_Address; I : in Interfaces.C.int) @@ -112,6 +120,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is + -- Optional Overrides -- + function fl_check_browser_full_width (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -139,6 +149,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is + -- Item Implementation -- + function fl_check_browser_item_width (C, I : in Storage.Integer_Address) return Interfaces.C.int; @@ -196,6 +208,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is + -- Drawing, Events -- + procedure fl_check_browser_draw (B : in Storage.Integer_Address); pragma Import (C, fl_check_browser_draw, "fl_check_browser_draw"); @@ -296,16 +310,18 @@ package body FLTK.Widgets.Groups.Browsers.Check is - ------------------------- - -- Check_Browser API -- - ------------------------- + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Items -- procedure Add (This : in out Check_Browser; 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)); @@ -318,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 @@ -343,6 +359,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is + -- Checkmarking -- + procedure Check_All (This : in out Check_Browser) is begin @@ -388,6 +406,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is + -- Text Selection -- + function Item_Text (This : in Check_Browser; Index : in Positive) @@ -408,6 +428,8 @@ package body FLTK.Widgets.Groups.Browsers.Check is + -- Item Implementation -- + function Item_Width (This : in Check_Browser; Item : in Item_Cursor) diff --git a/body/fltk-widgets-groups-browsers-textline-choice.adb b/body/fltk-widgets-groups-browsers-textline-choice.adb index 95df2f2..13ed7dd 100644 --- a/body/fltk-widgets-groups-browsers-textline-choice.adb +++ b/body/fltk-widgets-groups-browsers-textline-choice.adb @@ -16,6 +16,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Choice is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_select_browser (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -31,6 +33,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Choice is + -- Item Implementation -- + function fl_select_browser_item_width (B, I : in Storage.Integer_Address) return Interfaces.C.int; @@ -106,6 +110,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Choice is + -- List Implementation -- + function fl_select_browser_full_width (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -133,6 +139,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Choice is + -- Drawing, Events -- + procedure fl_select_browser_draw (B : in Storage.Integer_Address); pragma Import (C, fl_select_browser_draw, "fl_select_browser_draw"); diff --git a/body/fltk-widgets-groups-browsers-textline-file.adb b/body/fltk-widgets-groups-browsers-textline-file.adb index e45396c..d22cfc1 100644 --- a/body/fltk-widgets-groups-browsers-textline-file.adb +++ b/body/fltk-widgets-groups-browsers-textline-file.adb @@ -27,6 +27,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is -- Functions From C -- ------------------------ + -- Errors, File Data -- + function get_error_message return Interfaces.C.Strings.chars_ptr; pragma Import (C, get_error_message, "get_error_message"); @@ -42,6 +44,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + -- Allocation -- + function new_fl_file_browser (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -57,6 +61,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + -- Directory -- + function fl_file_browser_load (B : in Storage.Integer_Address; D : in Interfaces.C.char_array; @@ -68,6 +74,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + -- Settings -- + function fl_file_browser_get_filetype (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -119,6 +127,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + -- Item Implementation -- + function fl_file_browser_item_width (B, I : in Storage.Integer_Address) return Interfaces.C.int; @@ -194,6 +204,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + -- List Implementation -- + function fl_file_browser_full_width (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -221,6 +233,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + -- Drawing, Events -- + procedure fl_file_browser_draw (B : in Storage.Integer_Address); pragma Import (C, fl_file_browser_draw, "fl_file_browser_draw"); @@ -236,6 +250,32 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + ------------- + -- Hooks -- + ------------- + + Current_Sort : FLTK.Filenames.Compare_Function; + + function Compare_Hook + (DA, DB : in Storage.Integer_Address) + return Interfaces.C.int; + + pragma Convention (C, Compare_Hook); + + function Compare_Hook + (DA, DB : in Storage.Integer_Address) + return Interfaces.C.int + is + Result : constant FLTK.Filenames.Comparison := Current_Sort + (Interfaces.C.Strings.Value (filename_dname (DA, 0)), + Interfaces.C.Strings.Value (filename_dname (DB, 0))); + begin + return FLTK.Filenames.Comparison'Pos (Result) - 1; + end Compare_Hook; + + + + ------------------- -- Destructors -- ------------------- @@ -338,25 +378,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is -- API Subprograms -- ----------------------- - Current_Sort : FLTK.Filenames.Compare_Function; - - function Compare_Hook - (DA, DB : in Storage.Integer_Address) - return Interfaces.C.int; - - pragma Convention (C, Compare_Hook); - - function Compare_Hook - (DA, DB : in Storage.Integer_Address) - return Interfaces.C.int - is - Result : FLTK.Filenames.Comparison := Current_Sort - (Interfaces.C.Strings.Value (filename_dname (DA, 0)), - Interfaces.C.Strings.Value (filename_dname (DB, 0))); - begin - return FLTK.Filenames.Comparison'Pos (Result) - 1; - end Compare_Hook; - + -- Directory -- function Load (This : in out File_Browser; @@ -389,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; @@ -397,16 +419,20 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + -- Settings -- + function Get_File_Kind (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); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Browser::filetype returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Get_File_Kind; @@ -422,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 ""; @@ -474,6 +501,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + -- List Implementation -- + function Full_List_Height (This : in File_Browser) return Integer is @@ -492,6 +521,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.File is + -- Item Implementation -- + function Item_Width (This : in File_Browser; Item : in Item_Cursor) diff --git a/body/fltk-widgets-groups-browsers-textline-hold.adb b/body/fltk-widgets-groups-browsers-textline-hold.adb index 4c91322..facfe68 100644 --- a/body/fltk-widgets-groups-browsers-textline-hold.adb +++ b/body/fltk-widgets-groups-browsers-textline-hold.adb @@ -16,6 +16,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Hold is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_hold_browser (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -31,6 +33,7 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Hold is + -- Item Implementation -- function fl_hold_browser_item_width (B, I : in Storage.Integer_Address) @@ -107,6 +110,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Hold is + -- List Implementation -- + function fl_hold_browser_full_width (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -134,6 +139,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Hold is + -- Drawing, Events -- + procedure fl_hold_browser_draw (B : in Storage.Integer_Address); pragma Import (C, fl_hold_browser_draw, "fl_hold_browser_draw"); diff --git a/body/fltk-widgets-groups-browsers-textline-multi.adb b/body/fltk-widgets-groups-browsers-textline-multi.adb index ddcfd0a..e5c7f7a 100644 --- a/body/fltk-widgets-groups-browsers-textline-multi.adb +++ b/body/fltk-widgets-groups-browsers-textline-multi.adb @@ -16,6 +16,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Multi is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_multi_browser (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -31,6 +33,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Multi is + -- Item Implementation -- + function fl_multi_browser_item_width (B, I : in Storage.Integer_Address) return Interfaces.C.int; @@ -106,6 +110,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Multi is + -- List Implementation -- + function fl_multi_browser_full_width (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -133,6 +139,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline.Multi is + -- Drawing, Events -- + procedure fl_multi_browser_draw (B : in Storage.Integer_Address); pragma Import (C, fl_multi_browser_draw, "fl_multi_browser_draw"); diff --git a/body/fltk-widgets-groups-browsers-textline.adb b/body/fltk-widgets-groups-browsers-textline.adb index b7b3077..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 @@ -29,6 +28,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is -- Functions From C -- ------------------------ + -- Errors -- + function get_error_message return Interfaces.C.Strings.chars_ptr; pragma Import (C, get_error_message, "get_error_message"); @@ -37,6 +38,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Allocation -- + function new_fl_browser (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -52,6 +55,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Lines -- + procedure fl_browser_add (B : in Storage.Integer_Address; T : in Interfaces.C.char_array; @@ -99,6 +104,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Text Loading -- + function fl_browser_load (B : in Storage.Integer_Address; F : in Interfaces.C.char_array) @@ -135,6 +142,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Columns, Formatting -- + function fl_browser_get_column_char (B : in Storage.Integer_Address) return Interfaces.C.char; @@ -167,6 +176,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Line Positions -- + function fl_browser_get_topline (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -200,6 +211,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Selection -- + function fl_browser_select (B : in Storage.Integer_Address; L, V : in Interfaces.C.int) @@ -223,6 +236,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Visibility -- + function fl_browser_visible (B : in Storage.Integer_Address; L : in Interfaces.C.int) @@ -268,6 +283,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Dimensions -- + procedure fl_browser_set_size (B : in Storage.Integer_Address; W, H : in Interfaces.C.int); @@ -277,6 +294,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Icons -- + procedure fl_browser_set_icon (B : in Storage.Integer_Address; L : in Interfaces.C.int; @@ -293,6 +312,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Item Implementation -- + function fl_browser_item_width (B, I : in Storage.Integer_Address) return Interfaces.C.int; @@ -368,6 +389,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- List Implementation -- + function fl_browser_full_width (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -395,6 +418,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Line Numbers -- + function fl_browser_lineno (B, I : in Storage.Integer_Address) return Interfaces.C.int; @@ -404,6 +429,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Drawing, Events -- + procedure fl_browser_draw (B : in Storage.Integer_Address); pragma Import (C, fl_browser_draw, "fl_browser_draw"); @@ -534,6 +561,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is -- API Subprograms -- ----------------------- + -- Lines -- + procedure Add (This : in out Textline_Browser; Text : in String) is @@ -607,12 +636,15 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Text Loading -- + procedure Load (This : in out Textline_Browser; 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; @@ -625,7 +657,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is pragma Assert (Code = 1); end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::load returned unexpected int value of " & Interfaces.C.int'Image (Code); end Load; @@ -634,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 @@ -676,6 +709,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Columns, Formatting -- + function Get_Column_Character (This : in Textline_Browser) return Character is @@ -740,6 +775,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Line Positions -- + function Get_Top_Line (This : in Textline_Browser) return Positive is @@ -783,13 +820,15 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Selection -- + function Set_Select (This : in out Textline_Browser; Line : in Positive; 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)); @@ -797,7 +836,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::select returned unexpected int value of " & Interfaces.C.int'Image (Code); end Set_Select; @@ -806,14 +846,15 @@ 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)); begin pragma Assert (Code in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::select returned unexpected int value of " & Interfaces.C.int'Image (Code); end Set_Select; @@ -822,14 +863,15 @@ 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 pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::selected returned unexpected int value of " & Interfaces.C.int'Image (Code); end Is_Selected; @@ -843,6 +885,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Visibility -- + function Is_Visible (This : in Textline_Browser; Line : in Positive) @@ -865,14 +909,15 @@ 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 pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::displayed returned unexpected int value of " & Interfaces.C.int'Image (Code); end Is_Displayed; @@ -908,6 +953,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Dimensions -- + procedure Resize (This : in out Textline_Browser; W, H : in Integer) is @@ -921,6 +968,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Icons -- + function Has_Icon (This : in Textline_Browser; Line : in Positive) @@ -974,6 +1023,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- List Implementation -- + function Full_List_Height (This : in Textline_Browser) return Integer is @@ -992,6 +1043,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Item Implementation -- + function Item_Width (This : in Textline_Browser; Item : in Item_Cursor) @@ -1121,12 +1174,15 @@ 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); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Dispatched item_selected function returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Item_Selected; @@ -1181,6 +1237,8 @@ package body FLTK.Widgets.Groups.Browsers.Textline is + -- Line Numbers -- + function Line_Number (This : in Textline_Browser; Item : in Item_Cursor) diff --git a/body/fltk-widgets-groups-browsers.adb b/body/fltk-widgets-groups-browsers.adb index 36b9f2f..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; @@ -36,6 +36,8 @@ package body FLTK.Widgets.Groups.Browsers is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_abstract_browser (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -51,6 +53,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Attributes -- + function fl_abstract_browser_hscrollbar (B : in Storage.Integer_Address) return Storage.Integer_Address; @@ -66,6 +70,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Items -- + function fl_abstract_browser_select (B, I : in Storage.Integer_Address; V, C : in Interfaces.C.int) @@ -126,6 +132,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Scrollbar Settings -- + function fl_abstract_browser_get_has_scrollbar (B : in Storage.Integer_Address) return Interfaces.C.unsigned_char; @@ -191,6 +199,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Text Settings -- + function fl_abstract_browser_get_textcolor (B : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -230,6 +240,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Dimensions, Redrawing -- + procedure fl_abstract_browser_resize (B : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int); @@ -261,6 +273,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Optional Overrides -- + function fl_abstract_browser_full_width (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -289,6 +303,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Cache Invalidation -- + procedure fl_abstract_browser_new_list (B : in Storage.Integer_Address); pragma Import (C, fl_abstract_browser_new_list, "fl_abstract_browser_new_list"); @@ -317,6 +333,8 @@ package body FLTK.Widgets.Groups.Browsers is + -- Drawing, Events -- + procedure fl_abstract_browser_draw (B : in Storage.Integer_Address); pragma Import (C, fl_abstract_browser_draw, "fl_abstract_browser_draw"); @@ -348,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); @@ -364,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); @@ -380,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); @@ -396,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))); @@ -412,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))); @@ -428,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))); @@ -444,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); @@ -460,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); @@ -476,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))); @@ -492,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))); @@ -510,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 @@ -527,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 @@ -546,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))); @@ -560,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)); @@ -588,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; @@ -614,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 @@ -632,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)); @@ -756,7 +765,7 @@ package body FLTK.Widgets.Groups.Browsers is -- API Subprograms -- ----------------------- - -- Access to the Browser's self contained scrollbars + -- Attributes -- function H_Bar (This : in out Browser) @@ -776,7 +785,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Item related settings + -- Items -- function Set_Select (This : in out Browser; @@ -785,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), @@ -794,7 +803,8 @@ package body FLTK.Widgets.Groups.Browsers is pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select returned unexpected int value of " & Interfaces.C.int'Image (Code); end Set_Select; @@ -804,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), @@ -812,7 +822,8 @@ package body FLTK.Widgets.Groups.Browsers is begin pragma Assert (Code in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select returned unexpected int value of " & Interfaces.C.int'Image (Code); end Set_Select; @@ -822,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)); @@ -830,7 +841,9 @@ package body FLTK.Widgets.Groups.Browsers is pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select_only returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Select_Only; @@ -839,14 +852,16 @@ 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)); begin pragma Assert (Code in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select_only returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Select_Only; @@ -863,14 +878,16 @@ 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 pragma Assert (Code in 0 .. 1); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::deselect returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Deselect; @@ -878,13 +895,15 @@ 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 pragma Assert (Code in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::deselect returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Deselect; @@ -901,13 +920,15 @@ 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); return Boolean'Val (Code); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::displayed returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Is_Displayed; @@ -934,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); @@ -945,7 +966,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Scrollbar related settings + -- Scrollbar Settings -- function Get_Scrollbar_Mode (This : in Browser) @@ -1033,7 +1054,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Text related settings + -- Text Settings -- function Get_Text_Color (This : in Browser) @@ -1085,7 +1106,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Graphical dimensions and redrawing + -- Dimensions, Redrawing -- procedure Resize (This : in out Browser; @@ -1138,7 +1159,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Optional Override API + -- Optional Overrides -- function Full_List_Width (This : in Browser) @@ -1201,7 +1222,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Mandatory Override API + -- Mandatory Overrides -- function Item_Width (This : in Browser; @@ -1299,7 +1320,7 @@ package body FLTK.Widgets.Groups.Browsers is - -- Cache invalidation + -- Cache Invalidation -- procedure New_List (This : in out Browser) is @@ -1351,38 +1372,6 @@ package body FLTK.Widgets.Groups.Browsers is end Swapping; - - - -- Standard Override API - - procedure Draw - (This : in out Browser) - is - procedure my_draw - (V : in Storage.Integer_Address); - for my_draw'Address use This.Draw_Ptr; - pragma Import (Ada, my_draw); - begin - my_draw (This.Void_Ptr); - end Draw; - - - function Handle - (This : in out Browser; - Event : in Event_Kind) - return Event_Outcome - is - function my_handle - (V : in Storage.Integer_Address; - E : in Interfaces.C.int) - return Interfaces.C.int; - for my_handle'Address use This.Handle_Ptr; - pragma Import (Ada, my_handle); - begin - return Event_Outcome'Val (my_handle (This.Void_Ptr, Event_Kind'Pos (Event))); - end Handle; - - end FLTK.Widgets.Groups.Browsers; diff --git a/body/fltk-widgets-groups-color_choosers.adb b/body/fltk-widgets-groups-color_choosers.adb index 15f34ed..cce0f08 100644 --- a/body/fltk-widgets-groups-color_choosers.adb +++ b/body/fltk-widgets-groups-color_choosers.adb @@ -26,6 +26,8 @@ package body FLTK.Widgets.Groups.Color_Choosers is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_color_chooser (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -41,6 +43,8 @@ package body FLTK.Widgets.Groups.Color_Choosers is + -- RGB Color -- + function fl_color_chooser_r (N : in Storage.Integer_Address) return Interfaces.C.double; @@ -69,6 +73,8 @@ package body FLTK.Widgets.Groups.Color_Choosers is + -- HSV Color -- + function fl_color_chooser_hue (N : in Storage.Integer_Address) return Interfaces.C.double; @@ -97,6 +103,8 @@ package body FLTK.Widgets.Groups.Color_Choosers is + -- RGB / HSV Conversion -- + procedure fl_color_chooser_hsv2rgb (H, S, V : in Interfaces.C.double; R, G, B : out Interfaces.C.double); @@ -112,6 +120,8 @@ package body FLTK.Widgets.Groups.Color_Choosers is + -- Settings -- + function fl_color_chooser_get_mode (N : in Storage.Integer_Address) return Interfaces.C.int; @@ -127,6 +137,8 @@ package body FLTK.Widgets.Groups.Color_Choosers is + -- Drawing, Events -- + procedure fl_color_chooser_draw (W : in Storage.Integer_Address); pragma Import (C, fl_color_chooser_draw, "fl_color_chooser_draw"); @@ -196,11 +208,11 @@ package body FLTK.Widgets.Groups.Color_Choosers is begin return This : Color_Chooser do This.Void_Ptr := new_fl_color_chooser - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -226,6 +238,8 @@ package body FLTK.Widgets.Groups.Color_Choosers is -- API Subprograms -- ----------------------- + -- RGB Color -- + function Get_Red (This : in Color_Chooser) return Long_Float is @@ -254,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), @@ -262,7 +276,9 @@ package body FLTK.Widgets.Groups.Color_Choosers is begin pragma Assert (Result in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Color_Chooser::rgb returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_RGB; @@ -271,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), @@ -279,12 +295,16 @@ package body FLTK.Widgets.Groups.Color_Choosers is begin return Boolean'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Color_Chooser::rgb returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_RGB; + -- HSV Color -- + function Get_Hue (This : in Color_Chooser) return Long_Float is @@ -313,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), @@ -321,7 +341,9 @@ package body FLTK.Widgets.Groups.Color_Choosers is begin pragma Assert (Result in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Color_Chooser:hsv returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_HSV; @@ -330,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), @@ -338,12 +360,16 @@ package body FLTK.Widgets.Groups.Color_Choosers is begin return Boolean'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Color_Chooser::hsv returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_HSV; + -- RGB / HSV Conversion -- + procedure HSV_To_RGB (H, S, V : in Long_Float; R, G, B : out Long_Float) is @@ -374,6 +400,8 @@ package body FLTK.Widgets.Groups.Color_Choosers is + -- Settings -- + function Get_Mode (This : in Color_Chooser) return Color_Mode is diff --git a/body/fltk-widgets-groups-help_views.adb b/body/fltk-widgets-groups-help_views.adb index 6435c0f..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 @@ -27,6 +27,8 @@ package body FLTK.Widgets.Groups.Help_Views is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_help_view (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -42,6 +44,8 @@ package body FLTK.Widgets.Groups.Help_Views is + -- Selection -- + procedure fl_help_view_clear_selection (V : in Storage.Integer_Address); pragma Import (C, fl_help_view_clear_selection, "fl_help_view_clear_selection"); @@ -55,6 +59,8 @@ package body FLTK.Widgets.Groups.Help_Views is + -- Position -- + function fl_help_view_find (V : in Storage.Integer_Address; S : in Interfaces.C.char_array; @@ -96,6 +102,8 @@ package body FLTK.Widgets.Groups.Help_Views is + -- Content -- + function fl_help_view_directory (V : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -141,6 +149,8 @@ package body FLTK.Widgets.Groups.Help_Views is + -- Settings -- + function fl_help_view_get_scrollbar_size (V : in Storage.Integer_Address) return Interfaces.C.int; @@ -210,6 +220,8 @@ package body FLTK.Widgets.Groups.Help_Views is + -- Drawing, Events -- + procedure fl_help_view_draw (V : in Storage.Integer_Address); pragma Import (C, fl_help_view_draw, "fl_help_view_draw"); @@ -243,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); @@ -260,7 +272,9 @@ package body FLTK.Widgets.Groups.Help_Views is return Ada_Help_View.Hilda; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Help_View::link callback hook received Widget with no user_data reference " & + "back to Ada"; end Link_Callback_Hook; @@ -352,6 +366,8 @@ package body FLTK.Widgets.Groups.Help_Views is -- API Subprograms -- ----------------------- + -- Selection -- + procedure Clear_Selection (This : in out Help_View) is begin @@ -368,6 +384,8 @@ package body FLTK.Widgets.Groups.Help_Views is + -- Position -- + function Find (This : in Help_View; Item : in String; @@ -423,6 +441,8 @@ package body FLTK.Widgets.Groups.Help_Views is + -- Content -- + function Current_Directory (This : in Help_View) return String is @@ -443,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; @@ -451,7 +472,9 @@ package body FLTK.Widgets.Groups.Help_Views is pragma Assert (Code = 0); end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Help_View::load returned unexpected int value of " & + Interfaces.C.int'Image (Code); end Load; @@ -459,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 @@ -474,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 @@ -503,6 +527,8 @@ package body FLTK.Widgets.Groups.Help_Views is + -- Settings -- + function Get_Scrollbar_Size (This : in Help_View) return Natural is @@ -601,6 +627,8 @@ package body FLTK.Widgets.Groups.Help_Views is + -- Drawing, Events -- + procedure Draw (This : in out Help_View) is begin diff --git a/body/fltk-widgets-groups-input_choices.adb b/body/fltk-widgets-groups-input_choices.adb index 4ee6ffd..9119768 100644 --- a/body/fltk-widgets-groups-input_choices.adb +++ b/body/fltk-widgets-groups-input_choices.adb @@ -21,6 +21,8 @@ package body FLTK.Widgets.Groups.Input_Choices is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_input_choice (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -36,6 +38,8 @@ package body FLTK.Widgets.Groups.Input_Choices is + -- Attributes -- + function fl_input_choice_input (N : in Storage.Integer_Address) return Storage.Integer_Address; @@ -51,6 +55,8 @@ package body FLTK.Widgets.Groups.Input_Choices is + -- Menu Items -- + procedure fl_input_choice_clear (N : in Storage.Integer_Address); pragma Import (C, fl_input_choice_clear, "fl_input_choice_clear"); @@ -59,6 +65,8 @@ package body FLTK.Widgets.Groups.Input_Choices is + -- Settings -- + function fl_input_choice_changed (N : in Storage.Integer_Address) return Interfaces.C.int; @@ -144,6 +152,8 @@ package body FLTK.Widgets.Groups.Input_Choices is + -- Dimensions -- + procedure fl_input_choice_resize (N : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int); @@ -153,6 +163,8 @@ package body FLTK.Widgets.Groups.Input_Choices is + -- Drawing, Events -- + procedure fl_input_choice_draw (W : in Storage.Integer_Address); pragma Import (C, fl_input_choice_draw, "fl_input_choice_draw"); @@ -172,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; @@ -274,11 +270,11 @@ package body FLTK.Widgets.Groups.Input_Choices is begin return This : Input_Choice do This.Void_Ptr := new_fl_input_choice - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -300,9 +296,11 @@ package body FLTK.Widgets.Groups.Input_Choices is - ------------------ + ----------------------- + -- API Subprograms -- + ----------------------- + -- Attributes -- - ------------------ function Text_Field (This : in out Input_Choice) @@ -322,9 +320,7 @@ package body FLTK.Widgets.Groups.Input_Choices is - ----------------------- - -- API Subprograms -- - ----------------------- + -- Menu Items -- function Has_Item (This : in Input_Choice; @@ -361,6 +357,8 @@ package body FLTK.Widgets.Groups.Input_Choices is + -- Settings -- + function Has_Changed (This : in Input_Choice) return Boolean is @@ -454,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 ""; @@ -483,6 +481,8 @@ package body FLTK.Widgets.Groups.Input_Choices is + -- Dimensions -- + procedure Resize (This : in out Input_Choice; X, Y, W, H : in Integer) is diff --git a/body/fltk-widgets-groups-packed.adb b/body/fltk-widgets-groups-packed.adb index 126da76..d832a35 100644 --- a/body/fltk-widgets-groups-packed.adb +++ b/body/fltk-widgets-groups-packed.adb @@ -16,6 +16,8 @@ package body FLTK.Widgets.Groups.Packed is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_pack (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -31,6 +33,8 @@ package body FLTK.Widgets.Groups.Packed is + -- Settings -- + function fl_pack_get_spacing (P : in Storage.Integer_Address) return Interfaces.C.int; @@ -46,6 +50,8 @@ package body FLTK.Widgets.Groups.Packed is + -- Drawing, Events -- + procedure fl_pack_draw (W : in Storage.Integer_Address); pragma Import (C, fl_pack_draw, "fl_pack_draw"); @@ -115,11 +121,11 @@ package body FLTK.Widgets.Groups.Packed is begin return This : Packed_Group do This.Void_Ptr := new_fl_pack - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -145,6 +151,8 @@ package body FLTK.Widgets.Groups.Packed is -- API Subprograms -- ----------------------- + -- Settings -- + function Get_Spacing (This : in Packed_Group) return Integer is @@ -165,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 @@ -185,6 +193,8 @@ package body FLTK.Widgets.Groups.Packed is + -- Drawing -- + procedure Draw (This : in out Packed_Group) is begin diff --git a/body/fltk-widgets-groups-scrolls.adb b/body/fltk-widgets-groups-scrolls.adb index fa1b03e..65498a6 100644 --- a/body/fltk-widgets-groups-scrolls.adb +++ b/body/fltk-widgets-groups-scrolls.adb @@ -6,20 +6,29 @@ with + Ada.Characters.Latin_1, Interfaces.C.Strings; use type + Interfaces.C.int, Interfaces.C.unsigned_char; package body FLTK.Widgets.Groups.Scrolls is + package Latin renames Ada.Characters.Latin_1; + + + + ------------------------ -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_scroll (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -35,6 +44,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Attributes -- + function fl_scroll_hscrollbar (S : in Storage.Integer_Address) return Storage.Integer_Address; @@ -50,6 +61,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Scrolling -- + procedure fl_scroll_to (S : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -71,6 +84,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Scrollbar Settings -- + function fl_scroll_get_size (S : in Storage.Integer_Address) return Interfaces.C.int; @@ -86,6 +101,39 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Dimensions -- + + procedure fl_scroll_resize + (S : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_scroll_resize, "fl_scroll_resize"); + pragma Inline (fl_scroll_resize); + + procedure fl_scroll_recalc_scrollbars + (Addr : in Storage.Integer_Address; + CB_X, CB_Y, CB_W, CB_H : out Interfaces.C.int; + IB_X, IB_Y, IB_W, IB_H : out Interfaces.C.int; + IC_X, IC_Y, IC_W, IC_H : out Interfaces.C.int; + CH_Need, CV_Need : out Interfaces.C.int; + HS_X, HS_Y, HS_W, HS_H : out Interfaces.C.int; + HS_Size, HS_Total, HS_First, HS_Pos : out Interfaces.C.int; + VS_X, VS_Y, VS_W, VS_H : out Interfaces.C.int; + VS_Size, VS_Total, VS_First, VS_Pos : out Interfaces.C.int; + SSize : out Interfaces.C.int); + pragma Import (C, fl_scroll_recalc_scrollbars, "fl_scroll_recalc_scrollbars"); + pragma Inline (fl_scroll_recalc_scrollbars); + + + + + -- Drawing, Events -- + + procedure fl_scroll_bbox + (S : in Storage.Integer_Address; + X, Y, W, H : out Interfaces.C.int); + pragma Import (C, fl_scroll_bbox, "fl_scroll_bbox"); + pragma Inline (fl_scroll_bbox); + procedure fl_scroll_draw (S : in Storage.Integer_Address); pragma Import (C, fl_scroll_draw, "fl_scroll_draw"); @@ -105,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; @@ -231,11 +254,11 @@ package body FLTK.Widgets.Groups.Scrolls is begin return This : Scroll do This.Void_Ptr := new_fl_scroll - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -257,9 +280,11 @@ package body FLTK.Widgets.Groups.Scrolls is - ------------------ + ----------------------- + -- API Subprograms -- + ----------------------- + -- Attributes -- - ------------------ function H_Bar (This : in out Scroll) @@ -279,9 +304,7 @@ package body FLTK.Widgets.Groups.Scrolls is - ----------------------- - -- API Subprograms -- - ----------------------- + -- Contents -- procedure Clear (This : in out Scroll) is @@ -299,6 +322,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Scrolling -- + procedure Scroll_To (This : in out Scroll; X, Y : in Integer) is @@ -325,6 +350,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Scrollbar Settings -- + function Get_Scrollbar_Size (This : in Scroll) return Integer is @@ -345,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 @@ -365,6 +392,98 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Dimensions -- + + procedure Resize + (This : in out Scroll; + X, Y, W, H : in Integer) is + begin + fl_scroll_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Recalculate_Scrollbars + (This : in Scroll; + Data : out Scroll_Info) + is + C_Scroll_Size, + C_H_Need, C_V_Need, + C_H_Data_Size, C_V_Data_Size, + C_H_Data_Total, C_V_Data_Total : Interfaces.C.int; + begin + fl_scroll_recalc_scrollbars + (This.Void_Ptr, + + -- child LRTB region that will be reworked into XYWH in C++ + Interfaces.C.int (Data.Child_Box.X), Interfaces.C.int (Data.Child_Box.Y), + Interfaces.C.int (Data.Child_Box.W), Interfaces.C.int (Data.Child_Box.H), + + -- innerbox XYWH region + Interfaces.C.int (Data.Inner_Ex.X), Interfaces.C.int (Data.Inner_Ex.Y), + Interfaces.C.int (Data.Inner_Ex.W), Interfaces.C.int (Data.Inner_Ex.H), + + -- innerchild XYWH region + Interfaces.C.int (Data.Inner_Inc.X), Interfaces.C.int (Data.Inner_Inc.Y), + Interfaces.C.int (Data.Inner_Inc.W), Interfaces.C.int (Data.Inner_Inc.H), + + -- raw hneeded/vneeded values to be converted into Booleans + C_H_Need, C_V_Need, + + -- hscroll data + Interfaces.C.int (Data.H_Data.X), Interfaces.C.int (Data.H_Data.Y), + Interfaces.C.int (Data.H_Data.W), Interfaces.C.int (Data.H_Data.H), + C_H_Data_Size, C_H_Data_Total, + Interfaces.C.int (Data.H_Data.First), Interfaces.C.int (Data.H_Data.Position), + + -- vscroll data + Interfaces.C.int (Data.V_Data.X), Interfaces.C.int (Data.V_Data.Y), + Interfaces.C.int (Data.V_Data.W), Interfaces.C.int (Data.V_Data.H), + C_V_Data_Size, C_V_Data_Total, + Interfaces.C.int (Data.V_Data.First), Interfaces.C.int (Data.V_Data.Position), + + -- scrollsize + C_Scroll_Size); + + Data.H_Needed := C_H_Need /= 0; + Data.V_Needed := C_V_Need /= 0; + Data.H_Data.Size := Natural (C_H_Data_Size); + Data.H_Data.Total := Natural (C_H_Data_Total); + Data.V_Data.Size := Natural (C_V_Data_Size); + Data.V_Data.Total := Natural (C_V_Data_Total); + Data.Scroll_Size := Natural (C_Scroll_Size); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Scroll::recalc_scrollbars returned unexpected int values of " & Latin.LF & + Latin.HT & "hscroll.size = " & Interfaces.C.int'Image (C_H_Data_Size) & Latin.LF & + Latin.HT & "hscroll.total = " & Interfaces.C.int'Image (C_H_Data_Total) & Latin.LF & + Latin.HT & "vscroll.size = " & Interfaces.C.int'Image (C_V_Data_Size) & Latin.LF & + Latin.HT & "vscroll.total = " & Interfaces.C.int'Image (C_V_Data_Total) & Latin.LF & + Latin.HT & "scrollsize = " & Interfaces.C.int'Image (C_Scroll_Size); + end Recalculate_Scrollbars; + + + + + -- Drawing, Events -- + + procedure Bounding_Box + (This : in Scroll; + X, Y, W, H : out Integer) is + begin + fl_scroll_bbox + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Bounding_Box; + + procedure Draw (This : in out Scroll) is begin diff --git a/body/fltk-widgets-groups-spinners.adb b/body/fltk-widgets-groups-spinners.adb index d73d3e9..d9501ee 100644 --- a/body/fltk-widgets-groups-spinners.adb +++ b/body/fltk-widgets-groups-spinners.adb @@ -21,6 +21,8 @@ package body FLTK.Widgets.Groups.Spinners is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_spinner (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -36,6 +38,8 @@ package body FLTK.Widgets.Groups.Spinners is + -- Settings -- + function fl_spinner_get_color (S : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -99,6 +103,8 @@ package body FLTK.Widgets.Groups.Spinners is + -- Values -- + function fl_spinner_get_minimum (S : in Storage.Integer_Address) return Interfaces.C.double; @@ -156,6 +162,8 @@ package body FLTK.Widgets.Groups.Spinners is + -- Formatting -- + function fl_spinner_get_format (S : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -183,6 +191,8 @@ package body FLTK.Widgets.Groups.Spinners is + -- Dimensions -- + procedure fl_spinner_resize (S : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int); @@ -192,6 +202,8 @@ package body FLTK.Widgets.Groups.Spinners is + -- Drawing, Events -- + procedure fl_spinner_draw (W : in Storage.Integer_Address); pragma Import (C, fl_spinner_draw, "fl_spinner_draw"); @@ -261,11 +273,11 @@ package body FLTK.Widgets.Groups.Spinners is begin return This : Spinner do This.Void_Ptr := new_fl_spinner - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -291,6 +303,8 @@ package body FLTK.Widgets.Groups.Spinners is -- API Subprograms -- ----------------------- + -- Settings -- + function Get_Background_Color (This : in Spinner) return Color is @@ -373,6 +387,8 @@ package body FLTK.Widgets.Groups.Spinners is + -- Values -- + function Get_Minimum (This : in Spinner) return Long_Float is @@ -459,11 +475,13 @@ package body FLTK.Widgets.Groups.Spinners is + -- Formatting -- + function Get_Format (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 ""; @@ -487,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 @@ -507,6 +525,8 @@ package body FLTK.Widgets.Groups.Spinners is + -- Dimensions -- + procedure Resize (This : in out Spinner; X, Y, W, H : in Integer) is @@ -522,6 +542,8 @@ package body FLTK.Widgets.Groups.Spinners is + -- Events -- + function Handle (This : in out Spinner; Event : in Event_Kind) diff --git a/body/fltk-widgets-groups-tabbed.adb b/body/fltk-widgets-groups-tabbed.adb index 360b824..28c4c04 100644 --- a/body/fltk-widgets-groups-tabbed.adb +++ b/body/fltk-widgets-groups-tabbed.adb @@ -22,6 +22,8 @@ package body FLTK.Widgets.Groups.Tabbed is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_tabs (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -37,6 +39,8 @@ package body FLTK.Widgets.Groups.Tabbed is + -- Child Area -- + procedure fl_tabs_client_area (T : in Storage.Integer_Address; X, Y, W, H : out Interfaces.C.int; @@ -47,6 +51,8 @@ package body FLTK.Widgets.Groups.Tabbed is + -- Operation -- + function fl_tabs_get_push (T : in Storage.Integer_Address) return Storage.Integer_Address; @@ -79,6 +85,8 @@ package body FLTK.Widgets.Groups.Tabbed is + -- Drawing, Events -- + procedure fl_tabs_draw (W : in Storage.Integer_Address); pragma Import (C, fl_tabs_draw, "fl_tabs_draw"); @@ -153,11 +161,11 @@ package body FLTK.Widgets.Groups.Tabbed is begin return This : Tabbed_Group do This.Void_Ptr := new_fl_tabs - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -183,6 +191,8 @@ package body FLTK.Widgets.Groups.Tabbed is -- API Subprograms -- ----------------------- + -- Child Area -- + procedure Get_Client_Area (This : in Tabbed_Group; Tab_Height : in Natural; @@ -200,6 +210,8 @@ package body FLTK.Widgets.Groups.Tabbed is + -- Operation -- + function Get_Push (This : in Tabbed_Group) return access Widget'Class @@ -214,7 +226,8 @@ package body FLTK.Widgets.Groups.Tabbed is end if; return Actual_Widget; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Tabs::push returned Widget with no user_data reference back to Ada"; end Get_Push; @@ -240,7 +253,8 @@ package body FLTK.Widgets.Groups.Tabbed is end if; return Actual_Widget; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Tabs::value returned Widget with no user_data reference back to Ada"; end Get_Visible; @@ -268,12 +282,15 @@ package body FLTK.Widgets.Groups.Tabbed is end if; return Actual_Widget; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Tabs::which returned Widget with no user_data reference back to Ada"; end Get_Which; + -- Drawing, Events -- + procedure Draw (This : in out Tabbed_Group) is begin diff --git a/body/fltk-widgets-groups-tables-row.adb b/body/fltk-widgets-groups-tables-row.adb index 2063470..0a7250a 100644 --- a/body/fltk-widgets-groups-tables-row.adb +++ b/body/fltk-widgets-groups-tables-row.adb @@ -26,6 +26,8 @@ package body FLTK.Widgets.Groups.Tables.Row is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_table_row (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -41,6 +43,8 @@ package body FLTK.Widgets.Groups.Tables.Row is + -- Rows -- + function fl_table_row_get_rows (T : in Storage.Integer_Address) return Interfaces.C.int; @@ -56,6 +60,8 @@ package body FLTK.Widgets.Groups.Tables.Row is + -- Selection -- + function fl_table_row_row_selected (T : in Storage.Integer_Address; R : in Interfaces.C.int) @@ -91,6 +97,8 @@ package body FLTK.Widgets.Groups.Tables.Row is + -- Drawing, Events -- + procedure fl_table_row_draw (T : in Storage.Integer_Address); pragma Import (C, fl_table_row_draw, "fl_table_row_draw"); @@ -201,6 +209,12 @@ package body FLTK.Widgets.Groups.Tables.Row is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Contents Modification -- + procedure Clear (This : in out Row_Table) is begin @@ -212,11 +226,13 @@ package body FLTK.Widgets.Groups.Tables.Row is + -- Rows -- + function Get_Rows (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 @@ -236,12 +252,14 @@ package body FLTK.Widgets.Groups.Tables.Row is + -- Selection -- + function Is_Row_Selected (This : in Row_Table; 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); @@ -257,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)); @@ -280,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)); @@ -309,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 @@ -329,13 +347,15 @@ package body FLTK.Widgets.Groups.Tables.Row is + -- Drawing, Events -- + procedure Cell_Dimensions (This : in Row_Table; Context : in Table_Context; 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 30cc642..8417cd6 100644 --- a/body/fltk-widgets-groups-tables.adb +++ b/body/fltk-widgets-groups-tables.adb @@ -60,6 +60,8 @@ package body FLTK.Widgets.Groups.Tables is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_table (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -75,6 +77,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Attributes -- + function fl_table_hscrollbar (T : in Storage.Integer_Address) return Storage.Integer_Address; @@ -96,6 +100,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Contents Modification -- + procedure fl_table_add (T, W : in Storage.Integer_Address); pragma Import (C, fl_table_add, "fl_table_add"); @@ -120,6 +126,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Contents Query -- + function fl_table_child (T : in Storage.Integer_Address; P : in Interfaces.C.int) @@ -148,6 +156,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Current -- + procedure fl_table_begin (T : in Storage.Integer_Address); pragma Import (C, fl_table_begin, "fl_table_begin"); @@ -161,6 +171,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Callbacks -- + procedure fl_table_set_callback (T, F : in Storage.Integer_Address); pragma Import (C, fl_table_set_callback, "fl_table_set_callback"); @@ -192,7 +204,7 @@ package body FLTK.Widgets.Groups.Tables is procedure fl_table_when (T : in Storage.Integer_Address; - W : in Interfaces.C.unsigned); + W : in Interfaces.C.unsigned_char); pragma Import (C, fl_table_when, "fl_table_when"); pragma Inline (fl_table_when); @@ -204,6 +216,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Columns -- + function fl_table_get_col_header (T : in Storage.Integer_Address) return Interfaces.C.int; @@ -317,6 +331,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Rows -- + function fl_table_get_row_header (T : in Storage.Integer_Address) return Interfaces.C.int; @@ -442,6 +458,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Selection -- + procedure fl_table_change_cursor (T : in Storage.Integer_Address; C : in Interfaces.C.int); @@ -514,6 +532,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Dimensions -- + function fl_table_get_scrollbar_size (T : in Storage.Integer_Address) return Interfaces.C.int; @@ -561,6 +581,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Drawing, Events -- + procedure fl_table_draw (T : in Storage.Integer_Address); pragma Import (C, fl_table_draw, "fl_table_draw"); @@ -721,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; @@ -869,6 +874,8 @@ package body FLTK.Widgets.Groups.Tables is -- API Subprograms -- ----------------------- + -- Attributes -- + function H_Bar (This : in out Table) return Valuators.Sliders.Scrollbars.Scrollbar_Reference is @@ -895,6 +902,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Contents Modification -- + procedure Add (This : in out Table; Item : in out Widget'Class) is @@ -946,6 +955,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Contents Query -- + function Has_Child (This : in Table; Place : in Index) @@ -996,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; @@ -1023,6 +1034,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Current -- + procedure Begin_Current (This : in out Table) is begin @@ -1039,6 +1052,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Callbacks -- + procedure Set_Callback (This : in out Table; Func : in Widget_Callback) is @@ -1054,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 @@ -1068,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 @@ -1082,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 @@ -1109,7 +1124,7 @@ package body FLTK.Widgets.Groups.Tables is (This : in out Table; Value : in Callback_Flag) is begin - fl_table_when (This.Void_Ptr, Interfaces.C.unsigned (Value)); + fl_table_when (This.Void_Ptr, Flag_To_UChar (Value)); end Set_When; @@ -1122,6 +1137,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Columns -- + function Column_Headers_Enabled (This : in Table) return Boolean is @@ -1158,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 @@ -1181,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); @@ -1216,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 @@ -1238,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 @@ -1287,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 @@ -1307,6 +1324,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Rows -- + function Row_Headers_Enabled (This : in Table) return Boolean is @@ -1343,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 @@ -1366,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); @@ -1401,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 @@ -1423,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 @@ -1472,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 @@ -1494,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 @@ -1514,6 +1533,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Selection -- + procedure Set_Cursor_Kind (This : in out Table; Kind : in Mouse_Cursor_Kind) is @@ -1529,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); @@ -1621,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); @@ -1639,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, @@ -1659,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, @@ -1677,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 @@ -1699,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 @@ -1719,6 +1740,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Dimensions -- + function Get_Scrollbar_Size (This : in Table) return Integer is @@ -1752,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 @@ -1792,6 +1815,8 @@ package body FLTK.Widgets.Groups.Tables is + -- Drawing, Events -- + procedure Draw (This : in out Table) is begin @@ -1880,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, @@ -1925,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); @@ -1948,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 15066f9..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 @@ -25,6 +24,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_text_editor (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -40,6 +41,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Default Key Function -- + procedure fl_text_editor_default (TE : in Storage.Integer_Address; K : in Interfaces.C.int); @@ -49,6 +52,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Operation Key Functions -- + procedure fl_text_editor_undo (TE : in Storage.Integer_Address); pragma Import (C, fl_text_editor_undo, "fl_text_editor_undo"); @@ -82,6 +87,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Special Key Functions -- + procedure fl_text_editor_backspace (TE : in Storage.Integer_Address); pragma Import (C, fl_text_editor_backspace, "fl_text_editor_backspace"); @@ -105,6 +112,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Movement Key Functions -- + procedure fl_text_editor_home (TE : in Storage.Integer_Address); pragma Import (C, fl_text_editor_home, "fl_text_editor_home"); @@ -148,6 +157,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Shift Key Functions -- + procedure fl_text_editor_shift_home (TE : in Storage.Integer_Address); pragma Import (C, fl_text_editor_shift_home, "fl_text_editor_shift_home"); @@ -191,6 +202,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Control Key Functions -- + procedure fl_text_editor_ctrl_home (TE : in Storage.Integer_Address); pragma Import (C, fl_text_editor_ctrl_home, "fl_text_editor_ctrl_home"); @@ -234,6 +247,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Control Shift Key Functions -- + procedure fl_text_editor_ctrl_shift_home (TE : in Storage.Integer_Address); pragma Import (C, fl_text_editor_ctrl_shift_home, "fl_text_editor_ctrl_shift_home"); @@ -277,6 +292,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Meta Key Functions -- + procedure fl_text_editor_meta_home (TE : in Storage.Integer_Address); pragma Import (C, fl_text_editor_meta_home, "fl_text_editor_meta_home"); @@ -320,6 +337,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Meta Shift Key Functions -- + procedure fl_text_editor_meta_shift_home (TE : in Storage.Integer_Address); pragma Import (C, fl_text_editor_meta_shift_home, "fl_text_editor_meta_shift_home"); @@ -363,12 +382,14 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is - 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); + -- 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_remove_all_key_bindings (TE : in Storage.Integer_Address); @@ -385,6 +406,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Settings -- + function fl_text_editor_get_insert_mode (TE : in Storage.Integer_Address) return Interfaces.C.int; @@ -397,9 +420,6 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is pragma Import (C, fl_text_editor_set_insert_mode, "fl_text_editor_set_insert_mode"); pragma Inline (fl_text_editor_set_insert_mode); - - - function fl_text_editor_get_tab_nav (TE : in Storage.Integer_Address) return Interfaces.C.int; @@ -415,6 +435,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Drawing, Events -- + procedure fl_text_editor_draw (W : in Storage.Integer_Address); pragma Import (C, fl_text_editor_draw, "fl_text_editor_draw"); @@ -450,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 @@ -554,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 @@ -590,6 +611,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is -- API Subprograms -- ----------------------- + -- Default Key Function -- + procedure KF_Default (This : in out Text_Editor'Class; Key : in Key_Combo) is @@ -602,6 +625,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Operation Key Functions -- + procedure KF_Undo (This : in out Text_Editor'Class) is begin @@ -646,6 +671,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Special Key Functions -- + procedure KF_Backspace (This : in out Text_Editor'Class) is begin @@ -683,6 +710,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Movement Key Functions -- + procedure KF_Home (This : in out Text_Editor'Class) is begin @@ -741,6 +770,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Shift Key Functions -- + procedure KF_Shift_Home (This : in out Text_Editor'Class) is begin @@ -799,6 +830,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Control Key Functions -- + procedure KF_Ctrl_Home (This : in out Text_Editor'Class) is begin @@ -857,6 +890,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Control Shift Key Functions -- + procedure KF_Ctrl_Shift_Home (This : in out Text_Editor'Class) is begin @@ -915,6 +950,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Meta Key Functions -- + procedure KF_Meta_Home (This : in out Text_Editor'Class) is begin @@ -973,6 +1010,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Meta Shift Key Functions -- + procedure KF_Meta_Shift_Home (This : in out Text_Editor'Class) is begin @@ -1031,6 +1070,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Key Binding Modification -- + procedure Add_Key_Binding (This : in out Text_Editor; Key : in Key_Combo; @@ -1149,11 +1190,13 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Settings -- + function Get_Insert_Mode (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 @@ -1171,13 +1214,11 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is end Set_Insert_Mode; - - function Get_Tab_Mode (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 @@ -1197,6 +1238,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Events -- + function Handle (This : in out Text_Editor; Event : in Event_Kind) @@ -1210,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 011d841..ac1f6e9 100644 --- a/body/fltk-widgets-groups-text_displays.adb +++ b/body/fltk-widgets-groups-text_displays.adb @@ -6,21 +6,32 @@ with - Interfaces.C, - FLTK.Text_Buffers; + Ada.Assertions, + Ada.Characters.Latin_1, + Ada.Unchecked_Conversion, + Interfaces.C.Strings; use type - Interfaces.C.int; + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; package body FLTK.Widgets.Groups.Text_Displays is + package Chk renames Ada.Assertions; + package Latin renames Ada.Characters.Latin_1; + + + + ------------------------ -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_text_display (X, Y, W, H : in Interfaces.C.int; Label : in Interfaces.C.char_array) @@ -36,19 +47,36 @@ package body FLTK.Widgets.Groups.Text_Displays is - 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); + -- 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); procedure fl_text_display_set_buffer (TD, TB : in Storage.Integer_Address); pragma Import (C, fl_text_display_set_buffer, "fl_text_display_set_buffer"); pragma Inline (fl_text_display_set_buffer); + procedure fl_text_display_buffer_modified_cb + (P, I, D, R : in Interfaces.C.int; + T : in Interfaces.C.Strings.chars_ptr; + TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_buffer_modified_cb, "fl_text_display_buffer_modified_cb"); + pragma Inline (fl_text_display_buffer_modified_cb); + + procedure fl_text_display_buffer_predelete_cb + (P, D : in Interfaces.C.int; + TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_buffer_predelete_cb, "fl_text_display_buffer_predelete_cb"); + pragma Inline (fl_text_display_buffer_predelete_cb); + + + -- Highlighting -- procedure fl_text_display_highlight_data (TD, TB, ST : in Storage.Integer_Address; @@ -59,14 +87,23 @@ package body FLTK.Widgets.Groups.Text_Displays is procedure fl_text_display_highlight_data2 (TD, TB, ST : in Storage.Integer_Address; L : in Interfaces.C.int; - C : in Interfaces.C.unsigned; + C : in Interfaces.C.char; B, A : in Storage.Integer_Address); pragma Import (C, fl_text_display_highlight_data2, "fl_text_display_highlight_data2"); pragma Inline (fl_text_display_highlight_data2); + function fl_text_display_position_style + (TD : in Storage.Integer_Address; + S, L, I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_position_style, "fl_text_display_position_style"); + pragma Inline (fl_text_display_position_style); + + -- Measurement Conversion -- + function fl_text_display_col_to_x (TD : in Storage.Integer_Address; C : in Interfaces.C.double) @@ -96,9 +133,57 @@ package body FLTK.Widgets.Groups.Text_Displays is pragma Import (C, fl_text_display_position_to_xy, "fl_text_display_position_to_xy"); pragma Inline (fl_text_display_position_to_xy); + procedure fl_text_display_find_line_end + (TD : in Storage.Integer_Address; + SP, SPILS : in Interfaces.C.int; + LE, NLS : out Interfaces.C.int); + pragma Import (C, fl_text_display_find_line_end, "fl_text_display_find_line_end"); + pragma Inline (fl_text_display_find_line_end); + + function fl_text_display_find_x + (TD : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + L, S, X : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_find_x, "fl_text_display_find_x"); + pragma Inline (fl_text_display_find_x); + + function fl_text_display_position_to_line + (TD : in Storage.Integer_Address; + P : in Interfaces.C.int; + LN : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_position_to_line, "fl_text_display_position_to_line"); + pragma Inline (fl_text_display_position_to_line); + + function fl_text_display_position_to_linecol + (TD : in Storage.Integer_Address; + P : in Interfaces.C.int; + LN, C : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_position_to_linecol, "fl_text_display_position_to_linecol"); + pragma Inline (fl_text_display_position_to_linecol); + + function fl_text_display_xy_to_position + (TD : in Storage.Integer_Address; + X, Y, K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_xy_to_position, "fl_text_display_xy_to_position"); + pragma Inline (fl_text_display_xy_to_position); + + procedure fl_text_display_xy_to_rowcol + (TD : in Storage.Integer_Address; + X, Y : in Interfaces.C.int; + R, C : out Interfaces.C.int; + K : in Interfaces.C.int); + pragma Import (C, fl_text_display_xy_to_rowcol, "fl_text_display_xy_to_rowcol"); + pragma Inline (fl_text_display_xy_to_rowcol); + + -- Cursors -- + function fl_text_display_get_cursor_color (TD : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -130,6 +215,8 @@ package body FLTK.Widgets.Groups.Text_Displays is + -- Text Settings -- + function fl_text_display_get_text_color (TD : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -169,6 +256,8 @@ package body FLTK.Widgets.Groups.Text_Displays is + -- Text Insert -- + procedure fl_text_display_insert (TD : in Storage.Integer_Address; I : in Interfaces.C.char_array); @@ -201,6 +290,8 @@ package body FLTK.Widgets.Groups.Text_Displays is + -- Words -- + function fl_text_display_word_start (TD : in Storage.Integer_Address; P : in Interfaces.C.int) @@ -225,15 +316,51 @@ package body FLTK.Widgets.Groups.Text_Displays is pragma Import (C, fl_text_display_previous_word, "fl_text_display_previous_word"); pragma Inline (fl_text_display_previous_word); + + + + -- Wrapping -- + procedure fl_text_display_wrap_mode (TD : in Storage.Integer_Address; W, M : in Interfaces.C.int); pragma Import (C, fl_text_display_wrap_mode, "fl_text_display_wrap_mode"); pragma Inline (fl_text_display_wrap_mode); + function fl_text_display_wrapped_row + (TD : in Storage.Integer_Address; + R : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_wrapped_row, "fl_text_display_wrapped_row"); + pragma Inline (fl_text_display_wrapped_row); + + function fl_text_display_wrapped_column + (TD : in Storage.Integer_Address; + R, C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_wrapped_column, "fl_text_display_wrapped_column"); + pragma Inline (fl_text_display_wrapped_column); + + function fl_text_display_wrap_uses_character + (TD : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_wrap_uses_character, "fl_text_display_wrap_uses_character"); + pragma Inline (fl_text_display_wrap_uses_character); + + procedure fl_text_display_wrapped_line_counter + (TD, Buf : in Storage.Integer_Address; + SP, MP, ML, SPILS, SBO : in Interfaces.C.int; + RP, RL, RLS, RLE : out Interfaces.C.int; + CLLMNL : in Interfaces.C.int); + pragma Import (C, fl_text_display_wrapped_line_counter, "fl_text_display_wrapped_line_counter"); + pragma Inline (fl_text_display_wrapped_line_counter); + + -- Lines -- + function fl_text_display_line_start (TD : in Storage.Integer_Address; S : in Interfaces.C.int) @@ -269,9 +396,91 @@ package body FLTK.Widgets.Groups.Text_Displays is pragma Import (C, fl_text_display_rewind_lines, "fl_text_display_rewind_lines"); pragma Inline (fl_text_display_rewind_lines); + procedure fl_text_display_calc_last_char + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_calc_last_char, "fl_text_display_calc_last_char"); + pragma Inline (fl_text_display_calc_last_char); + + procedure fl_text_display_calc_line_starts + (TD : in Storage.Integer_Address; + S, F : in Interfaces.C.int); + pragma Import (C, fl_text_display_calc_line_starts, "fl_text_display_calc_line_starts"); + pragma Inline (fl_text_display_calc_line_starts); + + procedure fl_text_display_offset_line_starts + (TD : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_text_display_offset_line_starts, "fl_text_display_offset_line_starts"); + pragma Inline (fl_text_display_offset_line_starts); + + + + + -- Absolute Lines -- + + procedure fl_text_display_absolute_top_line_number + (TD : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_text_display_absolute_top_line_number, + "fl_text_display_absolute_top_line_number"); + pragma Inline (fl_text_display_absolute_top_line_number); + + function fl_text_display_get_absolute_top_line_number + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_absolute_top_line_number, + "fl_text_display_get_absolute_top_line_number"); + pragma Inline (fl_text_display_get_absolute_top_line_number); + + procedure fl_text_display_maintain_absolute_top_line_number + (TD : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_text_display_maintain_absolute_top_line_number, + "fl_text_display_maintain_absolute_top_line_number"); + pragma Inline (fl_text_display_maintain_absolute_top_line_number); + + function fl_text_display_maintaining_absolute_top_line_number + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_maintaining_absolute_top_line_number, + "fl_text_display_maintaining_absolute_top_line_number"); + pragma Inline (fl_text_display_maintaining_absolute_top_line_number); + + procedure fl_text_display_reset_absolute_top_line_number + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_reset_absolute_top_line_number, + "fl_text_display_reset_absolute_top_line_number"); + pragma Inline (fl_text_display_reset_absolute_top_line_number); + + + + + -- Visible Lines -- + + function fl_text_display_empty_vlines + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_empty_vlines, "fl_text_display_empty_vlines"); + pragma Inline (fl_text_display_empty_vlines); + + function fl_text_display_longest_vline + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_longest_vline, "fl_text_display_longest_vline"); + pragma Inline (fl_text_display_longest_vline); + + function fl_text_display_vline_length + (TD : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_vline_length, "fl_text_display_vline_length"); + pragma Inline (fl_text_display_vline_length); + + -- Line Numbers -- + function fl_text_display_get_linenumber_align (TD : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -356,9 +565,54 @@ package body FLTK.Widgets.Groups.Text_Displays is "fl_text_display_set_linenumber_width"); pragma Inline (fl_text_display_set_linenumber_width); + function fl_text_display_get_linenumber_format + (TD : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_text_display_get_linenumber_format, + "fl_text_display_get_linenumber_format"); + pragma Inline (fl_text_display_get_linenumber_format); + + procedure fl_text_display_set_linenumber_format + (TD : in Storage.Integer_Address; + V : in Interfaces.C.char_array); + pragma Import (C, fl_text_display_set_linenumber_format, + "fl_text_display_set_linenumber_format"); + pragma Inline (fl_text_display_set_linenumber_format); + + + + + -- Text Measurement -- + + function fl_text_display_measure_proportional_character + (TD : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + X, P : in Interfaces.C.int) + return Interfaces.C.double; + pragma Import (C, fl_text_display_measure_proportional_character, + "fl_text_display_measure_proportional_character"); + pragma Inline (fl_text_display_measure_proportional_character); + + function fl_text_display_measure_vline + (TD : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_measure_vline, "fl_text_display_measure_vline"); + pragma Inline (fl_text_display_measure_vline); + + function fl_text_display_string_width + (TD : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + L, S : in Interfaces.C.int) + return Interfaces.C.double; + pragma Import (C, fl_text_display_string_width, "fl_text_display_string_width"); + pragma Inline (fl_text_display_string_width); + + -- Movement -- + function fl_text_display_move_down (TD : in Storage.Integer_Address) return Interfaces.C.int; @@ -386,12 +640,21 @@ package body FLTK.Widgets.Groups.Text_Displays is + -- Scrolling -- + procedure fl_text_display_scroll - (TD : in Storage.Integer_Address; - L : in Interfaces.C.int); + (TD : in Storage.Integer_Address; + L, C : in Interfaces.C.int); pragma Import (C, fl_text_display_scroll, "fl_text_display_scroll"); pragma Inline (fl_text_display_scroll); + function fl_text_display_scroll2 + (TD : in Storage.Integer_Address; + L, P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_scroll2, "fl_text_display_scroll2"); + pragma Inline (fl_text_display_scroll2); + function fl_text_display_get_scrollbar_align (TD : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -416,9 +679,60 @@ package body FLTK.Widgets.Groups.Text_Displays is pragma Import (C, fl_text_display_set_scrollbar_width, "fl_text_display_set_scrollbar_width"); pragma Inline (fl_text_display_set_scrollbar_width); + procedure fl_text_display_update_h_scrollbar + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_update_h_scrollbar, "fl_text_display_update_h_scrollbar"); + pragma Inline (fl_text_display_update_h_scrollbar); + + procedure fl_text_display_update_v_scrollbar + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_update_v_scrollbar, "fl_text_display_update_v_scrollbar"); + pragma Inline (fl_text_display_update_v_scrollbar); + + + + + -- Shortcuts -- + + function fl_text_display_get_shortcut + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_shortcut, "fl_text_display_get_shortcut"); + pragma Inline (fl_text_display_get_shortcut); + + procedure fl_text_display_set_shortcut + (TD : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_shortcut, "fl_text_display_set_shortcut"); + pragma Inline (fl_text_display_set_shortcut); + + + + + -- Dimensions -- + + procedure fl_text_display_resize + (TD : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_text_display_resize, "fl_text_display_resize"); + pragma Inline (fl_text_display_resize); + + -- Drawing, Events -- + + procedure fl_text_display_clear_rect + (TD : in Storage.Integer_Address; + S, X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_text_display_clear_rect, "fl_text_display_clear_rect"); + pragma Inline (fl_text_display_clear_rect); + + procedure fl_text_display_display_insert + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_display_insert, "fl_text_display_display_insert"); + pragma Inline (fl_text_display_display_insert); + procedure fl_text_display_redisplay_range (TD : in Storage.Integer_Address; S, F : in Interfaces.C.int); @@ -430,6 +744,44 @@ package body FLTK.Widgets.Groups.Text_Displays is pragma Import (C, fl_text_display_draw, "fl_text_display_draw"); pragma Inline (fl_text_display_draw); + procedure fl_text_display_draw_cursor + (TD : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_cursor, "fl_text_display_draw_cursor"); + pragma Inline (fl_text_display_draw_cursor); + + procedure fl_text_display_draw_line_numbers + (TD : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_line_numbers, "fl_text_display_draw_line_numbers"); + pragma Inline (fl_text_display_draw_line_numbers); + + procedure fl_text_display_draw_range + (TD : in Storage.Integer_Address; + S, F : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_range, "fl_text_display_draw_range"); + pragma Inline (fl_text_display_draw_range); + + procedure fl_text_display_draw_string + (TD : in Storage.Integer_Address; + S, X, Y, R : in Interfaces.C.int; + T : in Interfaces.C.char_array; + N : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_string, "fl_text_display_draw_string"); + pragma Inline (fl_text_display_draw_string); + + procedure fl_text_display_draw_text + (TD : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_text, "fl_text_display_draw_text"); + pragma Inline (fl_text_display_draw_text); + + procedure fl_text_display_draw_vline + (TD : in Storage.Integer_Address; + N, L, R, LC, RC : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_vline, "fl_text_display_draw_vline"); + pragma Inline (fl_text_display_draw_vline); + function fl_text_display_handle (W : in Storage.Integer_Address; E : in Interfaces.C.int) @@ -440,6 +792,37 @@ package body FLTK.Widgets.Groups.Text_Displays is + ------------------------ + -- Internal Utility -- + ------------------------ + + function UChar_To_Mask is new Ada.Unchecked_Conversion + (Interfaces.C.unsigned_char, Styles.Style_Mask); + + function Cint_To_Style_Info + (Value : in Interfaces.C.int) + return Styles.Style_Info is + begin + return + (Mask => UChar_To_Mask (Interfaces.C.unsigned_char ((Value / 256) mod 256)), + Index => Styles.Style_Index (Character'Val (Value mod 256))); + end Cint_To_Style_Info; + + + function Mask_To_UChar is new Ada.Unchecked_Conversion + (Styles.Style_Mask, Interfaces.C.unsigned_char); + + function Style_Info_To_Cint + (Value : in Styles.Style_Info) + return Interfaces.C.int is + begin + return Interfaces.C.int (Mask_To_UChar (Value.Mask)) * 256 + + Character'Pos (Character (Value.Index)); + end Style_Info_To_Cint; + + + + ---------------------- -- Callback Hooks -- ---------------------- @@ -450,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 @@ -519,11 +902,11 @@ package body FLTK.Widgets.Groups.Text_Displays is begin return This : Text_Display do This.Void_Ptr := new_fl_text_display - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -545,37 +928,12 @@ package body FLTK.Widgets.Groups.Text_Displays is - ---------------------- - -- Child Packages -- - ---------------------- - - package body Styles is - - function Item - (Tint : in Color; - Font : in Font_Kind; - Size : in Font_Size) - return Style_Entry is - begin - return This : Style_Entry do - This.Attr := 0; - This.Col := Interfaces.C.unsigned (Tint); - This.Font := Font_Kind'Pos (Font); - This.Size := Interfaces.C.int (Size); - end return; - end Item; - - pragma Inline (Item); - - end Styles; - - - - ----------------------- -- API Subprograms -- ----------------------- + -- Buffers -- + function Get_Buffer (This : in Text_Display) return FLTK.Text_Buffers.Text_Buffer_Reference is @@ -598,8 +956,51 @@ package body FLTK.Widgets.Groups.Text_Displays is end Set_Buffer; + procedure Buffer_Modified_Callback + (This : in out Text_Display; + Action : in FLTK.Text_Buffers.Modification; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural; + Deleted_Text : in String) + is + Bytes_Inserted, Bytes_Deleted, Bytes_Restyled : Interfaces.C.int := 0; + C_Text : aliased Interfaces.C.char_array := Interfaces.C.To_C (Deleted_Text); + use type FLTK.Text_Buffers.Modification; + begin + case Action is + when FLTK.Text_Buffers.Insert => Bytes_Inserted := Interfaces.C.int (Length); + when FLTK.Text_Buffers.Restyle => Bytes_Restyled := Interfaces.C.int (Length); + when FLTK.Text_Buffers.Delete => Bytes_Deleted := Interfaces.C.int (Length); + when FLTK.Text_Buffers.None => null; + end case; + fl_text_display_buffer_modified_cb + (Interfaces.C.int (Place), + Bytes_Inserted, + Bytes_Deleted, + Bytes_Restyled, + (if Action = FLTK.Text_Buffers.Delete + then Interfaces.C.Strings.To_Chars_Ptr (C_Text'Unchecked_Access) + else Interfaces.C.Strings.Null_Ptr), + This.Void_Ptr); + end Buffer_Modified_Callback; + + + procedure Buffer_Predelete_Callback + (This : in out Text_Display; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural) is + begin + fl_text_display_buffer_predelete_cb + (Interfaces.C.int (Place), + Interfaces.C.int (Length), + This.Void_Ptr); + end Buffer_Predelete_Callback; + + + -- Highlighting -- + procedure Highlight_Data (This : in out Text_Display; Buff : in out FLTK.Text_Buffers.Text_Buffer; @@ -608,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'Address), + (if Table'Length > 0 + then Storage.To_Integer (Table (Table'First)'Address) + else Null_Pointer), Table'Length); end Highlight_Data; @@ -617,22 +1020,47 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display; Buff : in out FLTK.Text_Buffers.Text_Buffer; Table : in Styles.Style_Array; - Unfinished : in Styles.Style_Index; + Unfinished : in Character; Callback : in Styles.Unfinished_Style_Callback) is begin This.Style_Callback := Callback; fl_text_display_highlight_data2 (This.Void_Ptr, Wrapper (Buff).Void_Ptr, - Storage.To_Integer (Table'Address), + (if Table'Length > 0 + then Storage.To_Integer (Table (Table'First)'Address) + else Null_Pointer), Table'Length, - Character'Pos (Character (Unfinished)), + Interfaces.C.To_C (Unfinished), Storage.To_Integer (Style_Hook'Address), Storage.To_Integer (This'Address)); end Highlight_Data; + function Position_Style + (This : in Text_Display; + Line_Start : in Natural; + Line_Length : in Natural; + Line_Index : in Natural) + return Styles.Style_Info + is + Result : constant Interfaces.C.int := fl_text_display_position_style + (This.Void_Ptr, + Interfaces.C.int (Line_Start), + Interfaces.C.int (Line_Length), + Interfaces.C.int (Line_Index)); + begin + return Cint_To_Style_Info (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_style returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_Style; + + + + -- Measurement Conversion -- function Col_To_X (This : in Text_Display; @@ -640,7 +1068,7 @@ package body FLTK.Widgets.Groups.Text_Displays is return Integer is begin return Integer (Interfaces.C.double'Rounding - (fl_text_display_col_to_x (This.Void_Ptr, Interfaces.C.double (Col_Num)))); + (fl_text_display_col_to_x (This.Void_Ptr, Interfaces.C.double (Col_Num)))); end Col_To_X; @@ -650,7 +1078,7 @@ package body FLTK.Widgets.Groups.Text_Displays is return Integer is begin return Integer (Interfaces.C.double'Rounding - (fl_text_display_x_to_col (This.Void_Ptr, Interfaces.C.double (X_Pos)))); + (fl_text_display_x_to_col (This.Void_Ptr, Interfaces.C.double (X_Pos)))); end X_To_Col; @@ -660,7 +1088,7 @@ package body FLTK.Widgets.Groups.Text_Displays is return Boolean is begin return fl_text_display_in_selection - (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)) /= 0; + (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)) /= 0; end In_Selection; @@ -671,14 +1099,208 @@ package body FLTK.Widgets.Groups.Text_Displays is Vert_Out : out Boolean) is begin Vert_Out := fl_text_display_position_to_xy - (This.Void_Ptr, - Interfaces.C.int (Pos), - Interfaces.C.int (X), - Interfaces.C.int (Y)) /= 0; + (This.Void_Ptr, + Interfaces.C.int (Pos), + Interfaces.C.int (X), + Interfaces.C.int (Y)) /= 0; end Position_To_XY; + procedure Find_Line_End + (This : in Text_Display; + Start : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Line_End : out Natural; + Next_Line_Start : out Natural) + is + C_Line_End, C_Next_Line_Start : Interfaces.C.int; + begin + fl_text_display_find_line_end + (This.Void_Ptr, + Interfaces.C.int (Start), + Boolean'Pos (Start_Pos_Is_Line_Start), + C_Line_End, C_Next_Line_Start); + Line_End := Natural (C_Line_End); + Next_Line_Start := Natural (C_Next_Line_Start); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::find_line_end returned unexpected int values of" & Latin.LF & + Latin.HT & "lineEnd = " & Interfaces.C.int'Image (C_Line_End) & Latin.LF & + Latin.HT & "nextLineStart = " & Interfaces.C.int'Image (C_Next_Line_Start); + end Find_Line_End; + + + function Find_Character + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index; + X : in Integer) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_find_x + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Text'Length, + Character'Pos (Character (Style)), + Interfaces.C.int (X)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::find_x returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Find_Character; + + + function Position_To_Line + (This : in Text_Display; + Position : in Natural) + return Natural + is + C_Line_Num : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_text_display_position_to_line + (This.Void_Ptr, + Interfaces.C.int (Position), + C_Line_Num); + begin + pragma Assert (Result >= 0); + return Natural (C_Line_Num); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_line returned unexpected int value of" & Latin.LF & + Latin.HT & "lineNum = " & Interfaces.C.int'Image (C_Line_Num); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_line returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_To_Line; + + + function Position_To_Line + (This : in Text_Display; + Position : in Natural; + Displayed : out Boolean) + return Natural + is + C_Line_Num : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_text_display_position_to_line + (This.Void_Ptr, + Interfaces.C.int (Position), + C_Line_Num); + begin + pragma Assert (Result >= 0); + Displayed := Result /= 0; + return Natural (C_Line_Num); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_line returned unexpected int value of" & Latin.LF & + Latin.HT & "lineNum = " & Interfaces.C.int'Image (C_Line_Num); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_line returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_To_Line; + + + procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural) + is + C_Line_Num, C_Column : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_text_display_position_to_linecol + (This.Void_Ptr, + Interfaces.C.int (Position), + C_Line_Num, C_Column); + begin + Line := Natural (C_Line_Num); + Column := Natural (C_Column); + pragma Assert (Result >= 0); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_linecol returned unexpected int values of" & Latin.LF & + Latin.HT & "lineNum = " & Interfaces.C.int'Image (C_Line_Num) & Latin.LF & + Latin.HT & "column = " & Interfaces.C.int'Image (C_Column); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_linecol returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_To_Line_Column; + + + procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural; + Displayed : out Boolean) + is + C_Line_Num, C_Column : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_text_display_position_to_linecol + (This.Void_Ptr, + Interfaces.C.int (Position), + C_Line_Num, C_Column); + begin + Line := Natural (C_Line_Num); + Column := Natural (C_Column); + pragma Assert (Result >= 0); + Displayed := Result /= 0; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_linecol returned unexpected int values of" & Latin.LF & + Latin.HT & "lineNum = " & Interfaces.C.int'Image (C_Line_Num) & Latin.LF & + Latin.HT & "column = " & Interfaces.C.int'Image (C_Column); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_linecol returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_To_Line_Column; + + + function XY_To_Position + (This : in Text_Display; + X, Y : in Integer; + Kind : in Position_Kind := Character_Position) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_xy_to_position + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Position_Kind'Pos (Kind)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::xy_to_position returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end XY_To_Position; + + + procedure XY_To_Row_Column + (This : in Text_Display; + X, Y : in Integer; + Row, Column : out Natural; + Kind : in Position_Kind := Character_Position) + is + C_Row, C_Column : Interfaces.C.int; + begin + fl_text_display_xy_to_rowcol + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + C_Row, C_Column, + Position_Kind'Pos (Kind)); + Row := Natural (C_Row); + Column := Natural (C_Column); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::xy_to_rowcol returned unexpected int values of" & Latin.LF & + Latin.HT & "row = " & Interfaces.C.int'Image (C_Row) & Latin.LF & + Latin.HT & "column = " & Interfaces.C.int'Image (C_Column); + end XY_To_Row_Column; + + + + -- Cursors -- function Get_Cursor_Color (This : in Text_Display) @@ -720,6 +1342,8 @@ package body FLTK.Widgets.Groups.Text_Displays is + -- Text Settings -- + function Get_Text_Color (This : in Text_Display) return Color is @@ -770,6 +1394,8 @@ package body FLTK.Widgets.Groups.Text_Displays is + -- Text Insert -- + procedure Insert_Text (This : in out Text_Display; Item : in String) is @@ -811,14 +1437,16 @@ package body FLTK.Widgets.Groups.Text_Displays is + -- Words -- + function Word_Start (This : in out Text_Display; Pos : in Natural) return Natural is begin return Natural (fl_text_display_word_start - (This.Void_Ptr, - Interfaces.C.int (Pos))); + (This.Void_Ptr, + Interfaces.C.int (Pos))); end Word_Start; @@ -828,8 +1456,8 @@ package body FLTK.Widgets.Groups.Text_Displays is return Natural is begin return Natural (fl_text_display_word_end - (This.Void_Ptr, - Interfaces.C.int (Pos))); + (This.Void_Ptr, + Interfaces.C.int (Pos))); end Word_End; @@ -847,19 +1475,118 @@ package body FLTK.Widgets.Groups.Text_Displays is end Previous_Word; + + + -- Wrapping -- + procedure Set_Wrap_Mode (This : in out Text_Display; Mode : in Wrap_Mode; Margin : in Natural := 0) is begin fl_text_display_wrap_mode - (This.Void_Ptr, - Wrap_Mode'Pos (Mode), - Interfaces.C.int (Margin)); + (This.Void_Ptr, + Wrap_Mode'Pos (Mode), + Interfaces.C.int (Margin)); end Set_Wrap_Mode; - + function Wrapped_Row + (This : in Text_Display; + Row : in Natural) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_wrapped_row + (This.Void_Ptr, + Interfaces.C.int (Row)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::wrapped_row returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Wrapped_Row; + + + function Wrapped_Column + (This : in Text_Display; + Row, Column : in Natural) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_wrapped_column + (This.Void_Ptr, + Interfaces.C.int (Row), + Interfaces.C.int (Column)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::wrapped_column returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Wrapped_Column; + + + function Wrap_Uses_Character + (This : in Text_Display; + Line_End : in Natural) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_wrap_uses_character + (This.Void_Ptr, + Interfaces.C.int (Line_End)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::wrap_uses_character returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Wrap_Uses_Character; + + + procedure Count_Wrapped_Lines + (This : in Text_Display; + Buffer : in FLTK.Text_Buffers.Text_Buffer; + Start : in Natural; + Max_Position, Max_Lines : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Style_Offset : in Natural; + Finish, Line_Count : out Natural; + End_Count_Line_Start : out Natural; + Last_Line_End : out Natural; + Count_Last_Missing_Newline : in Boolean := True) + is + C_Finish, C_Line_Count, C_End_Count_Line_Start, C_Last_Line_End : Interfaces.C.int; + begin + fl_text_display_wrapped_line_counter + (This.Void_Ptr, + Wrapper (Buffer).Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Max_Position), + Interfaces.C.int (Max_Lines), + Boolean'Pos (Start_Pos_Is_Line_Start), + Interfaces.C.int (Style_Offset), + C_Finish, + C_Line_Count, + C_End_Count_Line_Start, + C_Last_Line_End, + Boolean'Pos (Count_Last_Missing_Newline)); + Finish := Natural (C_Finish); + Line_Count := Natural (C_Line_Count); + End_Count_Line_Start := Natural (C_End_Count_Line_Start); + Last_Line_End := Natural (C_Last_Line_End); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::wrapped_line_counter returned unexpected int values of" & Latin.LF & + Latin.HT & "retPos = " & Interfaces.C.int'Image (C_Finish) & Latin.LF & + Latin.HT & "retLines = " & Interfaces.C.int'Image (C_Line_Count) & Latin.LF & + Latin.HT & "retLineStart = " & Interfaces.C.int'Image (C_End_Count_Line_Start) & Latin.LF & + Latin.HT & "retLineEnd = " & Interfaces.C.int'Image (C_Last_Line_End); + end Count_Wrapped_Lines; + + + + + -- Lines -- function Line_Start (This : in Text_Display; @@ -867,8 +1594,8 @@ package body FLTK.Widgets.Groups.Text_Displays is return Natural is begin return Natural (fl_text_display_line_start - (This.Void_Ptr, - Interfaces.C.int (Pos))); + (This.Void_Ptr, + Interfaces.C.int (Pos))); end Line_Start; @@ -879,9 +1606,9 @@ package body FLTK.Widgets.Groups.Text_Displays is return Natural is begin return Natural (fl_text_display_line_end - (This.Void_Ptr, - Interfaces.C.int (Pos), - Boolean'Pos (Start_Pos_Is_Line_Start))); + (This.Void_Ptr, + Interfaces.C.int (Pos), + Boolean'Pos (Start_Pos_Is_Line_Start))); end Line_End; @@ -892,10 +1619,10 @@ package body FLTK.Widgets.Groups.Text_Displays is return Natural is begin return Natural (fl_text_display_count_lines - (This.Void_Ptr, - Interfaces.C.int (Start), - Interfaces.C.int (Finish), - Boolean'Pos (Start_Pos_Is_Line_Start))); + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish), + Boolean'Pos (Start_Pos_Is_Line_Start))); end Count_Lines; @@ -906,10 +1633,10 @@ package body FLTK.Widgets.Groups.Text_Displays is return Natural is begin return Natural (fl_text_display_skip_lines - (This.Void_Ptr, - Interfaces.C.int (Start), - Interfaces.C.int (Lines), - Boolean'Pos (Start_Pos_Is_Line_Start))); + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Lines), + Boolean'Pos (Start_Pos_Is_Line_Start))); end Skip_Lines; @@ -919,13 +1646,149 @@ package body FLTK.Widgets.Groups.Text_Displays is return Natural is begin return Natural (fl_text_display_rewind_lines - (This.Void_Ptr, - Interfaces.C.int (Start), - Interfaces.C.int (Lines))); + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Lines))); end Rewind_Lines; + procedure Calculate_Last_Character + (This : in out Text_Display) is + begin + fl_text_display_calc_last_char (This.Void_Ptr); + end Calculate_Last_Character; + + + procedure Calculate_Line_Starts + (This : in out Text_Display; + Start, Finish : in Natural) is + begin + fl_text_display_calc_line_starts + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + end Calculate_Line_Starts; + + + procedure Offset_Line_Starts + (This : in out Text_Display; + New_Top : in Natural) is + begin + fl_text_display_offset_line_starts + (This.Void_Ptr, + Interfaces.C.int (New_Top)); + end Offset_Line_Starts; + + + + + -- Absolute Lines -- + + procedure Redo_Absolute_Top_Line + (This : in out Text_Display; + Old_First : in Natural) is + begin + fl_text_display_absolute_top_line_number (This.Void_Ptr, Interfaces.C.int (Old_First)); + end Redo_Absolute_Top_Line; + + + function Get_Absolute_Top_Line + (This : in Text_Display) + return Natural + is + Result : constant Interfaces.C.int := + fl_text_display_get_absolute_top_line_number (This.Void_Ptr); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::get_absolute_top_line_number returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Absolute_Top_Line; + + + procedure Maintain_Absolute_Top_Line + (This : in out Text_Display; + State : in Boolean := True) is + begin + fl_text_display_maintain_absolute_top_line_number (This.Void_Ptr, Boolean'Pos (State)); + end Maintain_Absolute_Top_Line; + + + function Maintaining_Absolute_Top_Line + (This : in Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_maintaining_absolute_top_line_number + (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::maintaining_absolute_top_line_number returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Maintaining_Absolute_Top_Line; + + + procedure Reset_Absolute_Top_Line + (This : in out Text_Display) is + begin + fl_text_display_reset_absolute_top_line_number (This.Void_Ptr); + end Reset_Absolute_Top_Line; + + + + + -- Visible Lines -- + + function Has_Empty_Visible_Lines + (This : in Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_empty_vlines (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::empty_vlines returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Has_Empty_Visible_Lines; + + + function Get_Longest_Visible_Line + (This : in Text_Display) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_longest_vline (This.Void_Ptr); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::longest_vline returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Longest_Visible_Line; + + + function Visible_Line_Length + (This : in Text_Display; + Line : in Natural) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_vline_length + (This.Void_Ptr, + Interfaces.C.int (Line)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::vline_length returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Visible_Line_Length; + + + + -- Line Numbers -- function Get_Linenumber_Alignment (This : in Text_Display) @@ -940,8 +1803,8 @@ package body FLTK.Widgets.Groups.Text_Displays is To : in Alignment) is begin fl_text_display_set_linenumber_align - (This.Void_Ptr, - Interfaces.C.unsigned (To)); + (This.Void_Ptr, + Interfaces.C.unsigned (To)); end Set_Linenumber_Alignment; @@ -958,8 +1821,8 @@ package body FLTK.Widgets.Groups.Text_Displays is To : in Color) is begin fl_text_display_set_linenumber_bgcolor - (This.Void_Ptr, - Interfaces.C.unsigned (To)); + (This.Void_Ptr, + Interfaces.C.unsigned (To)); end Set_Linenumber_Back_Color; @@ -976,8 +1839,8 @@ package body FLTK.Widgets.Groups.Text_Displays is To : in Color) is begin fl_text_display_set_linenumber_fgcolor - (This.Void_Ptr, - Interfaces.C.unsigned (To)); + (This.Void_Ptr, + Interfaces.C.unsigned (To)); end Set_Linenumber_Fore_Color; @@ -994,8 +1857,8 @@ package body FLTK.Widgets.Groups.Text_Displays is To : in Font_Kind) is begin fl_text_display_set_linenumber_font - (This.Void_Ptr, - Font_Kind'Pos (To)); + (This.Void_Ptr, + Font_Kind'Pos (To)); end Set_Linenumber_Font; @@ -1012,8 +1875,8 @@ package body FLTK.Widgets.Groups.Text_Displays is To : in Font_Size) is begin fl_text_display_set_linenumber_size - (This.Void_Ptr, - Interfaces.C.int (To)); + (This.Void_Ptr, + Interfaces.C.int (To)); end Set_Linenumber_Size; @@ -1030,56 +1893,228 @@ package body FLTK.Widgets.Groups.Text_Displays is Width : in Natural) is begin fl_text_display_set_linenumber_width - (This.Void_Ptr, - Interfaces.C.int (Width)); + (This.Void_Ptr, + Interfaces.C.int (Width)); end Set_Linenumber_Width; + function Get_Linenumber_Format + (This : in Text_Display) + return String + is + 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 + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_Linenumber_Format; + + + procedure Set_Linenumber_Format + (This : in out Text_Display; + Value : in String) is + begin + fl_text_display_set_linenumber_format (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Linenumber_Format; + + + + + -- Text Measurement -- + + function Measure_Character + (This : in Text_Display; + Text : in String; + X : in Integer; + Index : in Positive) + return Long_Float is + begin + return Long_Float (fl_text_display_measure_proportional_character + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.int (X), + Interfaces.C.int (Index) - 1)); + end Measure_Character; + + + function Measure_Visible_Line + (This : in Text_Display; + Line : in Natural) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_measure_vline + (This.Void_Ptr, + Interfaces.C.int (Line)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::measure_vline returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Measure_Visible_Line; + + + function Measure_String + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index) + return Long_Float is + begin + return Long_Float (fl_text_display_string_width + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Text'Length, + Character'Pos (Character (Style)))); + end Measure_String; + + + -- Movement -- + procedure Move_Down - (This : in out Text_Display) is + (This : in out Text_Display) + is + Result : constant Interfaces.C.int := fl_text_display_move_down (This.Void_Ptr); begin - if fl_text_display_move_down (This.Void_Ptr) = 0 then - raise Bounds_Error; - end if; + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_down returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Down; + + + function Move_Down + (This : in out Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_move_down (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_down returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Move_Down; procedure Move_Left - (This : in out Text_Display) is + (This : in out Text_Display) + is + Result : constant Interfaces.C.int := fl_text_display_move_left (This.Void_Ptr); begin - if fl_text_display_move_left (This.Void_Ptr) = 0 then - raise Bounds_Error; - end if; + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_left returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Left; + + + function Move_Left + (This : in out Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_move_left (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_left returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Move_Left; procedure Move_Right - (This : in out Text_Display) is + (This : in out Text_Display) + is + Result : constant Interfaces.C.int := fl_text_display_move_right (This.Void_Ptr); begin - if fl_text_display_move_right (This.Void_Ptr) = 0 then - raise Bounds_Error; - end if; + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_right returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Right; + + + function Move_Right + (This : in out Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_move_right (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_right returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Move_Right; procedure Move_Up - (This : in out Text_Display) is + (This : in out Text_Display) + is + Result : constant Interfaces.C.int := fl_text_display_move_up (This.Void_Ptr); begin - if fl_text_display_move_up (This.Void_Ptr) = 0 then - raise Bounds_Error; - end if; + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_up returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Move_Up; + function Move_Up + (This : in out Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_move_up (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_up returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Up; + + + -- Scrolling -- + procedure Scroll_To - (This : in out Text_Display; - Line : in Natural) is + (This : in out Text_Display; + Line : in Natural; + Column : in Natural := 0) is + begin + fl_text_display_scroll + (This.Void_Ptr, + Interfaces.C.int (Line), + Interfaces.C.int (Column)); + end Scroll_To; + + + function Scroll_To + (This : in out Text_Display; + Line : in Natural; + Pixel : in Natural := 0) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_scroll2 + (This.Void_Ptr, + Interfaces.C.int (Line), + Interfaces.C.int (Pixel)); begin - fl_text_display_scroll (This.Void_Ptr, Interfaces.C.int (Line)); + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::scroll_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Scroll_To; @@ -1096,8 +2131,8 @@ package body FLTK.Widgets.Groups.Text_Displays is Align : in Alignment) is begin fl_text_display_set_scrollbar_align - (This.Void_Ptr, - Interfaces.C.unsigned (Align)); + (This.Void_Ptr, + Interfaces.C.unsigned (Align)); end Set_Scrollbar_Alignment; @@ -1114,11 +2149,86 @@ package body FLTK.Widgets.Groups.Text_Displays is Width : in Natural) is begin fl_text_display_set_scrollbar_width - (This.Void_Ptr, - Interfaces.C.int (Width)); + (This.Void_Ptr, + Interfaces.C.int (Width)); end Set_Scrollbar_Width; + procedure Update_Horizontal_Scrollbar + (This : in out Text_Display) is + begin + fl_text_display_update_h_scrollbar (This.Void_Ptr); + end Update_Horizontal_Scrollbar; + + + procedure Update_Vertical_Scrollbar + (This : in out Text_Display) is + begin + fl_text_display_update_v_scrollbar (This.Void_Ptr); + end Update_Vertical_Scrollbar; + + + + + -- Shortcuts -- + + function Get_Shortcut + (This : in Text_Display) + return Key_Combo is + begin + return To_Ada (Interfaces.C.unsigned (fl_text_display_get_shortcut (This.Void_Ptr))); + end Get_Shortcut; + + + procedure Set_Shortcut + (This : in out Text_Display; + Value : in Key_Combo) is + begin + fl_text_display_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (Value))); + end Set_Shortcut; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Text_Display; + X, Y, W, H : in Integer) is + begin + fl_text_display_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Drawing, Events -- + + procedure Clear_Rect + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y, W, H : in Integer) is + begin + fl_text_display_clear_rect + (This.Void_Ptr, + Style_Info_To_Cint (Style), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Clear_Rect; + + + procedure Display_Insert + (This : in out Text_Display) is + begin + fl_text_display_display_insert (This.Void_Ptr); + end Display_Insert; procedure Redisplay_Range @@ -1139,6 +2249,84 @@ package body FLTK.Widgets.Groups.Text_Displays is end Draw; + procedure Draw_Cursor + (This : in out Text_Display; + X, Y : in Integer) is + begin + fl_text_display_draw_cursor + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw_Cursor; + + + procedure Draw_Line_Numbers + (This : in out Text_Display; + Clear : in Boolean := False) is + begin + fl_text_display_draw_line_numbers (This.Void_Ptr, Boolean'Pos (Clear)); + end Draw_Line_Numbers; + + + procedure Draw_Range + (This : in out Text_Display; + Start, Finish : in Natural) is + begin + fl_text_display_draw_range + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + end Draw_Range; + + + procedure Draw_String + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y : in Integer; + Right : in Integer; + Text : in String; + Num_Chars : in Natural) is + begin + fl_text_display_draw_string + (This.Void_Ptr, + Style_Info_To_Cint (Style), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (Right), + Interfaces.C.To_C (Text), + Interfaces.C.int (Num_Chars)); + end Draw_String; + + + procedure Draw_Text + (This : in out Text_Display; + X, Y, W, H : in Integer) is + begin + fl_text_display_draw_text + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Text; + + + procedure Draw_Visible_Line + (This : in out Text_Display; + Line : in Natural; + Left_Clip, Right_Clip : in Integer; + Left_Char, Right_Char : in Natural) is + begin + fl_text_display_draw_vline + (This.Void_Ptr, + Interfaces.C.int (Line), + Interfaces.C.int (Left_Clip), + Interfaces.C.int (Right_Clip), + Interfaces.C.int (Left_Char), + Interfaces.C.int (Right_Char)); + end Draw_Visible_Line; + + function Handle (This : in out Text_Display; Event : in Event_Kind) diff --git a/body/fltk-widgets-groups-tiled.adb b/body/fltk-widgets-groups-tiled.adb index 9bbf394..a169e0e 100644 --- a/body/fltk-widgets-groups-tiled.adb +++ b/body/fltk-widgets-groups-tiled.adb @@ -16,6 +16,8 @@ package body FLTK.Widgets.Groups.Tiled is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_tile (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -31,6 +33,8 @@ package body FLTK.Widgets.Groups.Tiled is + -- Dimensions -- + procedure fl_tile_position (T : in Storage.Integer_Address; OX, OY, NX, NY : in Interfaces.C.int); @@ -46,6 +50,8 @@ package body FLTK.Widgets.Groups.Tiled is + -- Drawing, Events -- + procedure fl_tile_draw (W : in Storage.Integer_Address); pragma Import (C, fl_tile_draw, "fl_tile_draw"); @@ -115,11 +121,11 @@ package body FLTK.Widgets.Groups.Tiled is begin return This : Tiled_Group do This.Void_Ptr := new_fl_tile - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -145,6 +151,8 @@ package body FLTK.Widgets.Groups.Tiled is -- API Subprograms -- ----------------------- + -- Dimensions -- + procedure Position (This : in out Tiled_Group; Old_X, Old_Y : in Integer; @@ -172,6 +180,8 @@ package body FLTK.Widgets.Groups.Tiled is + -- Events -- + function Handle (This : in out Tiled_Group; Event : in Event_Kind) diff --git a/body/fltk-widgets-groups-windows-double-cairo.adb b/body/fltk-widgets-groups-windows-double-cairo.adb index 897c206..1560c20 100644 --- a/body/fltk-widgets-groups-windows-double-cairo.adb +++ b/body/fltk-widgets-groups-windows-double-cairo.adb @@ -23,6 +23,8 @@ package body FLTK.Widgets.Groups.Windows.Double.Cairo is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_cairo_window (W, H : in Interfaces.C.int) return Storage.Integer_Address; @@ -37,6 +39,8 @@ package body FLTK.Widgets.Groups.Windows.Double.Cairo is + -- Cairo Callback -- + procedure fl_cairo_window_set_draw_cb (W, F : in Storage.Integer_Address); pragma Import (C, fl_cairo_window_set_draw_cb, "fl_cairo_window_set_draw_cb"); @@ -45,6 +49,8 @@ package body FLTK.Widgets.Groups.Windows.Double.Cairo is + -- Drawing, Events -- + procedure fl_cairo_window_draw (W : in Storage.Integer_Address); pragma Import (C, fl_cairo_window_draw, "fl_cairo_window_draw"); @@ -75,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); @@ -85,7 +91,8 @@ package body FLTK.Widgets.Groups.Windows.Double.Cairo is Ada_Object.My_Func (Cairo_Window (Ada_Object.all), Storage.To_Address (Cairo_Addr)); end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Cairo_Window draw hook received Widget with no user_data reference back to Ada"; end Cairo_Draw_Hook; @@ -222,9 +229,11 @@ package body FLTK.Widgets.Groups.Windows.Double.Cairo is - ------------------------ - -- Cairo Window API -- - ------------------------ + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Cairo Callback -- procedure Set_Cairo_Draw (This : in out Cairo_Window; @@ -236,6 +245,8 @@ package body FLTK.Widgets.Groups.Windows.Double.Cairo is + -- Drawing -- + procedure Draw (This : in out Cairo_Window) is begin diff --git a/body/fltk-widgets-groups-windows-double-overlay.adb b/body/fltk-widgets-groups-windows-double-overlay.adb index c4460f1..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; @@ -22,6 +22,8 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_overlay_window (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -44,6 +46,8 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is + -- Visibility -- + procedure fl_overlay_window_show (W : in Storage.Integer_Address); pragma Import (C, fl_overlay_window_show, "fl_overlay_window_show"); @@ -69,6 +73,8 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is + -- Settings -- + function fl_overlay_window_can_do_overlay (W : in Storage.Integer_Address) return Interfaces.C.int; @@ -84,6 +90,8 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is + -- Drawing, Events -- + procedure fl_overlay_window_draw (W : in Storage.Integer_Address); pragma Import (C, fl_overlay_window_draw, "fl_overlay_window_draw"); @@ -117,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; @@ -233,9 +241,11 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is - --------------- - -- Display -- - --------------- + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Visibility -- procedure Show (This : in out Overlay_Window) is @@ -247,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; @@ -267,9 +277,7 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is - ------------- - -- Other -- - ------------- + -- Settings -- function Can_Do_Overlay (This : in Overlay_Window) @@ -294,9 +302,7 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is - ---------------------------------- - -- Drawing and Event Handling -- - ---------------------------------- + -- Drawing, Events -- procedure Draw_Overlay (This : in out Overlay_Window) is diff --git a/body/fltk-widgets-groups-windows-double.adb b/body/fltk-widgets-groups-windows-double.adb index 90a17f3..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; @@ -17,6 +17,8 @@ package body FLTK.Widgets.Groups.Windows.Double is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_double_window (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -39,6 +41,8 @@ package body FLTK.Widgets.Groups.Windows.Double is + -- Visibility -- + procedure fl_double_window_show (W : in Storage.Integer_Address); pragma Import (C, fl_double_window_show, "fl_double_window_show"); @@ -70,6 +74,8 @@ package body FLTK.Widgets.Groups.Windows.Double is + -- Dimensions -- + procedure fl_double_window_resize (DW : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int); @@ -79,6 +85,8 @@ package body FLTK.Widgets.Groups.Windows.Double is + -- Drawing, Events -- + procedure fl_double_window_draw (W : in Storage.Integer_Address); pragma Import (C, fl_double_window_draw, "fl_double_window_draw"); @@ -148,11 +156,11 @@ package body FLTK.Widgets.Groups.Windows.Double is begin return This : Double_Window do This.Void_Ptr := new_fl_double_window - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -177,9 +185,9 @@ package body FLTK.Widgets.Groups.Windows.Double is begin return This : Double_Window do This.Void_Ptr := new_fl_double_window2 - (Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); end return; end Create; @@ -205,6 +213,8 @@ package body FLTK.Widgets.Groups.Windows.Double is -- API Subprograms -- ----------------------- + -- Visibility -- + procedure Show (This : in out Double_Window) is begin @@ -215,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; @@ -242,6 +252,8 @@ package body FLTK.Widgets.Groups.Windows.Double is + -- Dimensions -- + procedure Resize (This : in out Double_Window; X, Y, W, H : in Integer) is diff --git a/body/fltk-widgets-groups-windows-opengl.adb b/body/fltk-widgets-groups-windows-opengl.adb index da2434c..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 @@ -24,6 +23,8 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_gl_window (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -46,6 +47,8 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is + -- Visibility -- + procedure fl_gl_window_show (S : in Storage.Integer_Address); pragma Import (C, fl_gl_window_show, "fl_gl_window_show"); @@ -76,6 +79,8 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is + -- Dimensions -- + function fl_gl_window_pixel_h (S : in Storage.Integer_Address) return Interfaces.C.int; @@ -103,6 +108,8 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is + -- OpenGL Modes -- + function fl_gl_window_get_mode (S : in Storage.Integer_Address) return Mode_Mask; @@ -136,6 +143,8 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is + -- OpenGL Contexts -- + function fl_gl_window_get_context (S : in Storage.Integer_Address) return Storage.Integer_Address; @@ -190,6 +199,8 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is + -- Drawing, Events -- + procedure fl_gl_window_ortho (W : in Storage.Integer_Address); pragma Import (C, fl_gl_window_ortho, "fl_gl_window_ortho"); @@ -327,9 +338,11 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is - --------------- - -- Display -- - --------------- + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Visibility -- procedure Show (This : in out GL_Window) is @@ -341,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; @@ -368,9 +381,7 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is - ------------------ -- Dimensions -- - ------------------ function Pixel_H (This : in GL_Window) @@ -411,9 +422,7 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is - -------------------- -- OpenGL Modes -- - -------------------- function Get_Mode (This : in GL_Window) @@ -457,9 +466,7 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is - ----------------------- -- OpenGL Contexts -- - ----------------------- function Get_Context (This : in GL_Window) @@ -534,9 +541,7 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is - ---------------------------------- - -- Drawing and Event Handling -- - ---------------------------------- + -- Drawing, Events -- procedure Ortho (This : in out GL_Window) is diff --git a/body/fltk-widgets-groups-windows-single-menu.adb b/body/fltk-widgets-groups-windows-single-menu.adb index 063961e..a6997c9 100644 --- a/body/fltk-widgets-groups-windows-single-menu.adb +++ b/body/fltk-widgets-groups-windows-single-menu.adb @@ -20,6 +20,8 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_menu_window (X, Y, W, H : in Interfaces.C.int; Label : in Interfaces.C.char_array) @@ -42,6 +44,8 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is + -- Visibility -- + procedure fl_menu_window_show (M : in Storage.Integer_Address); pragma Import (C, fl_menu_window_show, "fl_menu_window_show"); @@ -65,6 +69,8 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is + -- Overlay -- + procedure fl_menu_window_set_overlay (M : in Storage.Integer_Address); pragma Import (C, fl_menu_window_set_overlay, "fl_menu_window_set_overlay"); @@ -84,6 +90,8 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is + -- Drawing, Events -- + procedure fl_menu_window_draw (W : in Storage.Integer_Address); pragma Import (C, fl_menu_window_draw, "fl_menu_window_draw"); @@ -153,11 +161,11 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is begin return This : Menu_Window do This.Void_Ptr := new_fl_menu_window - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -182,9 +190,9 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is begin return This : Menu_Window do This.Void_Ptr := new_fl_menu_window2 - (Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); end return; end Create; @@ -210,6 +218,8 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is -- API Subprograms -- ----------------------- + -- Visibility -- + procedure Show (This : in out Menu_Window) is begin @@ -240,6 +250,8 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is + -- Overlay -- + function Is_Overlay (This : in Menu_Window) return Boolean is diff --git a/body/fltk-widgets-groups-windows-single.adb b/body/fltk-widgets-groups-windows-single.adb index 109c07e..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; @@ -17,6 +17,8 @@ package body FLTK.Widgets.Groups.Windows.Single is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_single_window (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -39,6 +41,8 @@ package body FLTK.Widgets.Groups.Windows.Single is + -- Visibility -- + procedure fl_single_window_show (S : in Storage.Integer_Address); pragma Import (C, fl_single_window_show, "fl_single_window_show"); @@ -59,6 +63,8 @@ package body FLTK.Widgets.Groups.Windows.Single is + -- Current -- + procedure fl_single_window_make_current (S : in Storage.Integer_Address); pragma Import (C, fl_single_window_make_current, "fl_single_window_make_current"); @@ -67,6 +73,8 @@ package body FLTK.Widgets.Groups.Windows.Single is + -- Drawing, Events -- + procedure fl_single_window_draw (W : in Storage.Integer_Address); pragma Import (C, fl_single_window_draw, "fl_single_window_draw"); @@ -136,11 +144,11 @@ package body FLTK.Widgets.Groups.Windows.Single is begin return This : Single_Window do This.Void_Ptr := new_fl_single_window - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -165,9 +173,9 @@ package body FLTK.Widgets.Groups.Windows.Single is begin return This : Single_Window do This.Void_Ptr := new_fl_single_window2 - (Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); end return; end Create; @@ -193,6 +201,8 @@ package body FLTK.Widgets.Groups.Windows.Single is -- API Subprograms -- ----------------------- + -- Visibility -- + procedure Show (This : in out Single_Window) is begin @@ -203,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; @@ -216,6 +226,8 @@ package body FLTK.Widgets.Groups.Windows.Single is + -- Current -- + procedure Make_Current (This : in out Single_Window) is begin diff --git a/body/fltk-widgets-groups-windows.adb b/body/fltk-widgets-groups-windows.adb index 3a07d96..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 @@ -25,6 +23,8 @@ package body FLTK.Widgets.Groups.Windows is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_window (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -47,6 +47,8 @@ package body FLTK.Widgets.Groups.Windows is + -- Visibility -- + procedure fl_window_show (W : in Storage.Integer_Address); pragma Import (C, fl_window_show, "fl_window_show"); @@ -85,13 +87,10 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_make_current, "fl_window_make_current"); pragma Inline (fl_window_make_current); - procedure fl_window_free_position - (W : in Storage.Integer_Address); - pragma Import (C, fl_window_free_position, "fl_window_free_position"); - pragma Inline (fl_window_free_position); + -- Fullscreen -- function fl_window_fullscreen_active (W : in Storage.Integer_Address) @@ -124,16 +123,30 @@ package body FLTK.Widgets.Groups.Windows is + -- Icons, Cursors -- + procedure fl_window_set_icon (W, P : in Storage.Integer_Address); pragma Import (C, fl_window_set_icon, "fl_window_set_icon"); pragma Inline (fl_window_set_icon); + procedure fl_window_icons + (W, P : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_window_icons, "fl_window_icons"); + pragma Inline (fl_window_icons); + procedure fl_window_default_icon (P : in Storage.Integer_Address); pragma Import (C, fl_window_default_icon, "fl_window_default_icon"); pragma Inline (fl_window_default_icon); + procedure fl_window_default_icons + (P : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_window_default_icons, "fl_window_default_icons"); + pragma Inline (fl_window_default_icons); + function fl_window_get_iconlabel (W : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -167,6 +180,8 @@ package body FLTK.Widgets.Groups.Windows is + -- Settings -- + function fl_window_get_border (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -179,6 +194,11 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_set_border, "fl_window_set_border"); pragma Inline (fl_window_set_border); + procedure fl_window_clear_border + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_clear_border, "fl_window_clear_border"); + pragma Inline (fl_window_clear_border); + function fl_window_get_override (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -202,11 +222,6 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_non_modal, "fl_window_non_modal"); pragma Inline (fl_window_non_modal); - procedure fl_window_clear_modal_states - (W : in Storage.Integer_Address); - pragma Import (C, fl_window_clear_modal_states, "fl_window_clear_modal_states"); - pragma Inline (fl_window_clear_modal_states); - procedure fl_window_set_modal (W : in Storage.Integer_Address); pragma Import (C, fl_window_set_modal, "fl_window_set_modal"); @@ -217,20 +232,27 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_set_non_modal, "fl_window_set_non_modal"); pragma Inline (fl_window_set_non_modal); + procedure fl_window_clear_modal_states + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_clear_modal_states, "fl_window_clear_modal_states"); + pragma Inline (fl_window_clear_modal_states); + + -- Labels, Hotspot, Shape -- + function fl_window_get_label (W : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_window_get_label, "fl_window_get_label"); pragma Inline (fl_window_get_label); - procedure fl_window_set_label + procedure fl_window_copy_label (W : in Storage.Integer_Address; T : in Interfaces.C.char_array); - pragma Import (C, fl_window_set_label, "fl_window_set_label"); - pragma Inline (fl_window_set_label); + pragma Import (C, fl_window_copy_label, "fl_window_copy_label"); + pragma Inline (fl_window_copy_label); procedure fl_window_hotspot (W : in Storage.Integer_Address; @@ -244,19 +266,39 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_hotspot2, "fl_window_hotspot2"); pragma Inline (fl_window_hotspot2); + procedure fl_window_shape + (W, P : in Storage.Integer_Address); + pragma Import (C, fl_window_shape, "fl_window_shape"); + pragma Inline (fl_window_shape); + + + + + -- Dimensions -- + procedure fl_window_size_range (W : in Storage.Integer_Address; LW, LH, HW, HH, DW, DH, A : in Interfaces.C.int); pragma Import (C, fl_window_size_range, "fl_window_size_range"); pragma Inline (fl_window_size_range); - procedure fl_window_shape - (W, P : in Storage.Integer_Address); - pragma Import (C, fl_window_shape, "fl_window_shape"); - pragma Inline (fl_window_shape); - + procedure fl_window_resize + (N : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_window_resize, "fl_window_resize"); + pragma Inline (fl_window_resize); + function fl_window_get_force_position + (N : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_window_get_force_position, "fl_window_get_force_position"); + pragma Inline (fl_window_get_force_position); + procedure fl_window_set_force_position + (N : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_window_set_force_position, "fl_window_set_force_position"); + pragma Inline (fl_window_set_force_position); function fl_window_get_x_root (W : in Storage.Integer_Address) @@ -285,11 +327,57 @@ package body FLTK.Widgets.Groups.Windows is + -- Class Info -- + + function fl_window_get_xclass + (W : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_window_get_xclass, "fl_window_get_xclass"); + pragma Inline (fl_window_get_xclass); + + procedure fl_window_set_xclass + (W : in Storage.Integer_Address; + C : in Interfaces.C.char_array); + pragma Import (C, fl_window_set_xclass, "fl_window_set_xclass"); + pragma Inline (fl_window_set_xclass); + + function fl_window_get_default_xclass + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_window_get_default_xclass, "fl_window_get_default_xclass"); + pragma Inline (fl_window_get_default_xclass); + + procedure fl_window_set_default_xclass + (C : in Interfaces.C.char_array); + pragma Import (C, fl_window_set_default_xclass, "fl_window_set_default_xclass"); + pragma Inline (fl_window_set_default_xclass); + + function fl_window_menu_window + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_menu_window, "fl_window_menu_window"); + pragma Inline (fl_window_menu_window); + + function fl_window_tooltip_window + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_tooltip_window, "fl_window_tooltip_window"); + pragma Inline (fl_window_tooltip_window); + + + + + -- Drawing, Events -- + procedure fl_window_draw (W : in Storage.Integer_Address); pragma Import (C, fl_window_draw, "fl_window_draw"); pragma Inline (fl_window_draw); + procedure fl_window_flush + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_flush, "fl_window_flush"); + pragma Inline (fl_window_flush); + function fl_window_handle (W : in Storage.Integer_Address; E : in Interfaces.C.int) @@ -354,11 +442,11 @@ package body FLTK.Widgets.Groups.Windows is begin return This : Window do This.Void_Ptr := new_fl_window - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -383,9 +471,9 @@ package body FLTK.Widgets.Groups.Windows is begin return This : Window do This.Void_Ptr := new_fl_window2 - (Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); end return; end Create; @@ -411,6 +499,8 @@ package body FLTK.Widgets.Groups.Windows is -- API Subprograms -- ----------------------- + -- Visibility -- + procedure Show (This : in out Window) is begin @@ -421,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; @@ -469,14 +559,9 @@ package body FLTK.Widgets.Groups.Windows is end Last_Made_Current; - procedure Free_Position - (This : in out Window) is - begin - fl_window_free_position (This.Void_Ptr); - end Free_Position; - + -- Fullscreen -- function Is_Fullscreen (This : in Window) @@ -528,28 +613,77 @@ package body FLTK.Widgets.Groups.Windows is + -- Icons, Cursors -- + procedure Set_Icon (This : in out Window; - Pic : in out FLTK.Images.RGB.RGB_Image'Class) is + Pic : in FLTK.Images.RGB.RGB_Image'Class) is begin fl_window_set_icon - (This.Void_Ptr, - Wrapper (Pic).Void_Ptr); + (This.Void_Ptr, + Wrapper (Pic).Void_Ptr); end Set_Icon; + procedure Set_Icons + (This : in out Window; + Pics : in FLTK.Images.RGB.RGB_Image_Array) + is + Pointers : array (Pics'First .. Pics'Last) of aliased Storage.Integer_Address; + begin + for Index in Pointers'Range loop + Pointers (Index) := Wrapper (Pics (Index)).Void_Ptr; + end loop; + fl_window_icons + (This.Void_Ptr, + (if Pointers'Length > 0 + then Storage.To_Integer (Pointers (Pointers'First)'Address) + else Null_Pointer), + Pointers'Length); + end Set_Icons; + + + procedure Reset_Icons + (This : in out Window) is + begin + fl_window_icons (This.Void_Ptr, Null_Pointer, 0); + end Reset_Icons; + + procedure Set_Default_Icon - (Pic : in out FLTK.Images.RGB.RGB_Image'Class) is + (Pic : in FLTK.Images.RGB.RGB_Image'Class) is begin fl_window_default_icon (Wrapper (Pic).Void_Ptr); end Set_Default_Icon; + procedure Set_Default_Icons + (Pics : in FLTK.Images.RGB.RGB_Image_Array) + is + Pointers : array (Pics'First .. Pics'Last) of aliased Storage.Integer_Address; + begin + for Index in Pointers'Range loop + Pointers (Index) := Wrapper (Pics (Index)).Void_Ptr; + end loop; + fl_window_default_icons + ((if Pointers'Length > 0 + then Storage.To_Integer (Pointers (Pointers'First)'Address) + else Null_Pointer), + Pointers'Length); + end Set_Default_Icons; + + + procedure Reset_Default_Icons is + begin + fl_window_default_icons (Null_Pointer, 0); + end Reset_Default_Icons; + + function Get_Icon_Label (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 ""; @@ -578,7 +712,7 @@ package body FLTK.Widgets.Groups.Windows is procedure Set_Cursor (This : in out Window; - Pic : in out FLTK.Images.RGB.RGB_Image'Class; + Pic : in FLTK.Images.RGB.RGB_Image'Class; Hot_X, Hot_Y : in Integer) is begin fl_window_set_cursor2 @@ -599,20 +733,29 @@ package body FLTK.Widgets.Groups.Windows is - function Get_Border_State + -- Settings -- + + function Has_Border (This : in Window) - return Border_State is + return Boolean is begin - return Border_State'Val (fl_window_get_border (This.Void_Ptr)); - end Get_Border_State; + return fl_window_get_border (This.Void_Ptr) /= 0; + end Has_Border; - procedure Set_Border_State - (This : in out Window; - To : in Border_State) is + procedure Set_Border + (This : in out Window; + Value : in Boolean := True) is + begin + fl_window_set_border (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Border; + + + procedure Clear_Border + (This : in out Window) is begin - fl_window_set_border (This.Void_Ptr, Border_State'Pos (To)); - end Set_Border_State; + fl_window_clear_border (This.Void_Ptr); + end Clear_Border; function Is_Override @@ -630,6 +773,22 @@ package body FLTK.Widgets.Groups.Windows is end Set_Override; + function Is_Modal + (This : in Window) + return Boolean is + begin + return fl_window_modal (This.Void_Ptr) /= 0; + end Is_Modal; + + + function Is_Non_Modal + (This : in Window) + return Boolean is + begin + return fl_window_non_modal (This.Void_Ptr) /= 0; + end Is_Non_Modal; + + function Get_Modal_State (This : in Window) return Modal_State is @@ -644,28 +803,48 @@ package body FLTK.Widgets.Groups.Windows is end Get_Modal_State; + procedure Set_Modal + (This : in out Window) is + begin + fl_window_set_modal (This.Void_Ptr); + end Set_Modal; + + + procedure Set_Non_Modal + (This : in out Window) is + begin + fl_window_set_non_modal (This.Void_Ptr); + end Set_Non_Modal; + + procedure Set_Modal_State - (This : in out Window; - To : in Modal_State) is - begin - case To is - when Normal => - fl_window_clear_modal_states (This.Void_Ptr); - when Non_Modal => - fl_window_set_non_modal (This.Void_Ptr); - when Modal => - fl_window_set_modal (This.Void_Ptr); + (This : in out Window; + Value : in Modal_State) is + begin + case Value is + when Normal => fl_window_clear_modal_states (This.Void_Ptr); + when Non_Modal => fl_window_set_non_modal (This.Void_Ptr); + when Modal => fl_window_set_modal (This.Void_Ptr); end case; end Set_Modal_State; + procedure Clear_Modal_State + (This : in out Window) is + begin + fl_window_clear_modal_states (This.Void_Ptr); + end Clear_Modal_State; + + + + -- Labels, Hotspot, Shape -- function Get_Label (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 ""; @@ -680,10 +859,19 @@ package body FLTK.Widgets.Groups.Windows is (This : in out Window; Text : in String) is begin - fl_window_set_label (This.Void_Ptr, Interfaces.C.To_C (Text)); + fl_window_copy_label (This.Void_Ptr, Interfaces.C.To_C (Text)); end Set_Label; + procedure Set_Labels + (This : in out Window; + Text, Icon_Text : in String) is + begin + This.Set_Label (Text); + This.Set_Icon_Label (Icon_Text); + end Set_Labels; + + procedure Hotspot (This : in out Window; X, Y : in Integer; @@ -709,6 +897,18 @@ package body FLTK.Widgets.Groups.Windows is end Hotspot; + procedure Shape + (This : in out Window; + Pic : in FLTK.Images.Image'Class) is + begin + fl_window_shape (This.Void_Ptr, Wrapper (Pic).Void_Ptr); + end Shape; + + + + + -- Dimensions -- + procedure Set_Size_Range (This : in out Window; Min_W, Min_H : in Integer; @@ -716,25 +916,50 @@ package body FLTK.Widgets.Groups.Windows is Keep_Aspect : in Boolean := False) is begin fl_window_size_range - (This.Void_Ptr, - Interfaces.C.int (Min_W), - Interfaces.C.int (Min_H), - Interfaces.C.int (Max_W), - Interfaces.C.int (Max_H), - Interfaces.C.int (Incre_W), - Interfaces.C.int (Incre_H), - Boolean'Pos (Keep_Aspect)); + (This.Void_Ptr, + Interfaces.C.int (Min_W), + Interfaces.C.int (Min_H), + Interfaces.C.int (Max_W), + Interfaces.C.int (Max_H), + Interfaces.C.int (Incre_W), + Interfaces.C.int (Incre_H), + Boolean'Pos (Keep_Aspect)); end Set_Size_Range; - procedure Shape - (This : in out Window; - Pic : in out FLTK.Images.Image'Class) is + procedure Resize + (This : in out Window; + X, Y, W, H : in Integer) is begin - fl_window_shape (This.Void_Ptr, Wrapper (Pic).Void_Ptr); - end Shape; + fl_window_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + function Is_Position_Forced + (This : in Window) + return Boolean + is + Result : constant Interfaces.C.int := fl_window_get_force_position (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Window::force_position returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Is_Position_Forced; + + + procedure Force_Position + (This : in out Window; + State : in Boolean := True) is + begin + fl_window_set_force_position (This.Void_Ptr, Boolean'Pos (State)); + end Force_Position; function Get_X_Root @@ -771,6 +996,70 @@ package body FLTK.Widgets.Groups.Windows is + -- Class Info -- + + function Get_X_Class + (This : in Window) + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_window_get_xclass (This.Void_Ptr); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_X_Class; + + + procedure Set_X_Class + (This : in out Window; + Value : in String) is + begin + fl_window_set_xclass (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_X_Class; + + + function Get_Default_X_Class + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_window_get_default_xclass; + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_Default_X_Class; + + + procedure Set_Default_X_Class + (Value : in String) is + begin + fl_window_set_default_xclass (Interfaces.C.To_C (Value)); + end Set_Default_X_Class; + + + function Is_Menu_Window + (This : in Window) + return Boolean is + begin + return fl_window_menu_window (This.Void_Ptr) /= 0; + end Is_Menu_Window; + + + function Is_Tooltip_Window + (This : in Window) + return Boolean is + begin + return fl_window_tooltip_window (This.Void_Ptr) /= 0; + end Is_Tooltip_Window; + + + + + -- Drawing, Events -- + procedure Draw (This : in out Window) is begin @@ -778,6 +1067,13 @@ package body FLTK.Widgets.Groups.Windows is end Draw; + procedure Flush + (This : in out Window) is + begin + fl_window_flush (This.Void_Ptr); + end Flush; + + function Handle (This : in out Window; Event : in Event_Kind) diff --git a/body/fltk-widgets-groups-wizards.adb b/body/fltk-widgets-groups-wizards.adb index eb604a1..513c50f 100644 --- a/body/fltk-widgets-groups-wizards.adb +++ b/body/fltk-widgets-groups-wizards.adb @@ -22,6 +22,8 @@ package body FLTK.Widgets.Groups.Wizards is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_wizard (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -37,6 +39,8 @@ package body FLTK.Widgets.Groups.Wizards is + -- Navigation -- + procedure fl_wizard_next (W : in Storage.Integer_Address); pragma Import (C, fl_wizard_next, "fl_wizard_next"); @@ -50,6 +54,8 @@ package body FLTK.Widgets.Groups.Wizards is + -- Visibility -- + function fl_wizard_get_visible (W : in Storage.Integer_Address) return Storage.Integer_Address; @@ -64,6 +70,8 @@ package body FLTK.Widgets.Groups.Wizards is + -- Drawing, Events -- + procedure fl_wizard_draw (W : in Storage.Integer_Address); pragma Import (C, fl_wizard_draw, "fl_wizard_draw"); @@ -133,11 +141,11 @@ package body FLTK.Widgets.Groups.Wizards is begin return This : Wizard do This.Void_Ptr := new_fl_wizard - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -163,6 +171,8 @@ package body FLTK.Widgets.Groups.Wizards is -- API Subprograms -- ----------------------- + -- Navigation -- + procedure Next (This : in out Wizard) is begin @@ -179,6 +189,8 @@ package body FLTK.Widgets.Groups.Wizards is + -- Visibility -- + function Get_Visible (This : in Wizard) return access Widget'Class @@ -193,7 +205,8 @@ package body FLTK.Widgets.Groups.Wizards is end if; return Actual_Widget; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Wizard::value returned Widget with no user_data reference back to Ada"; end Get_Visible; @@ -207,6 +220,8 @@ package body FLTK.Widgets.Groups.Wizards is + -- Drawing -- + procedure Draw (This : in out Wizard) is begin diff --git a/body/fltk-widgets-groups.adb b/body/fltk-widgets-groups.adb index 3b2e287..d6b51d4 100644 --- a/body/fltk-widgets-groups.adb +++ b/body/fltk-widgets-groups.adb @@ -26,6 +26,8 @@ package body FLTK.Widgets.Groups is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_group (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -41,6 +43,8 @@ package body FLTK.Widgets.Groups is + -- Contents Modification -- + procedure fl_group_add (G, W : in Storage.Integer_Address); pragma Import (C, fl_group_add, "fl_group_add"); @@ -71,6 +75,8 @@ package body FLTK.Widgets.Groups is + -- Contents Query -- + function fl_group_child (G : in Storage.Integer_Address; I : in Interfaces.C.int) @@ -93,6 +99,8 @@ package body FLTK.Widgets.Groups is + -- Clipping -- + function fl_group_get_clip_children (G : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -108,6 +116,8 @@ package body FLTK.Widgets.Groups is + -- Dimensions -- + procedure fl_group_add_resizable (G, W : in Storage.Integer_Address); pragma Import (C, fl_group_add_resizable, "fl_group_add_resizable"); @@ -138,6 +148,8 @@ package body FLTK.Widgets.Groups is + -- Current -- + function fl_group_get_current return Storage.Integer_Address; pragma Import (C, fl_group_get_current, "fl_group_get_current"); @@ -161,6 +173,8 @@ package body FLTK.Widgets.Groups is + -- Drawing, Events -- + procedure fl_group_draw (W : in Storage.Integer_Address); pragma Import (C, fl_group_draw, "fl_group_draw"); @@ -203,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; @@ -252,11 +268,11 @@ package body FLTK.Widgets.Groups is begin return This : Group do This.Void_Ptr := new_fl_group - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -282,6 +298,8 @@ package body FLTK.Widgets.Groups is -- API Subprograms -- ----------------------- + -- Contents Modification -- + procedure Add (This : in out Group; Item : in out Widget'Class) is @@ -296,9 +314,9 @@ package body FLTK.Widgets.Groups is Place : in Index) is begin fl_group_insert - (This.Void_Ptr, - Item.Void_Ptr, - Interfaces.C.int (Place) - 1); + (This.Void_Ptr, + Item.Void_Ptr, + Interfaces.C.int (Place) - 1); end Insert; @@ -308,9 +326,9 @@ package body FLTK.Widgets.Groups is Before : in Widget'Class) is begin fl_group_insert2 - (This.Void_Ptr, - Item.Void_Ptr, - Before.Void_Ptr); + (This.Void_Ptr, + Item.Void_Ptr, + Before.Void_Ptr); end Insert; @@ -343,6 +361,8 @@ package body FLTK.Widgets.Groups is + -- Contents Query -- + function Has_Child (This : in Group; Place : in Index) @@ -374,7 +394,8 @@ package body FLTK.Widgets.Groups is Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Widget_Ptr)); return (Data => Actual_Widget); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Group::child returned Widget with no user_data reference back to Ada"; end Child; @@ -392,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; @@ -411,11 +432,13 @@ package body FLTK.Widgets.Groups is + -- Iteration -- + function Iterate (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; @@ -423,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; @@ -437,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; @@ -447,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; @@ -461,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; @@ -469,13 +492,19 @@ package body FLTK.Widgets.Groups is + -- Clipping -- + function Get_Clip_Mode (This : in Group) - return Clip_Mode is + return Clip_Mode + is + Result : constant Interfaces.C.unsigned := fl_group_get_clip_children (This.Void_Ptr); begin - return Clip_Mode'Val (fl_group_get_clip_children (This.Void_Ptr)); + return Clip_Mode'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Group::clip_children returned unexpected unsigned int value of " & + Interfaces.C.unsigned'Image (Result); end Get_Clip_Mode; @@ -489,6 +518,8 @@ package body FLTK.Widgets.Groups is + -- Dimensions -- + procedure Add_Resizable (This : in out Group; Item : in out Widget'Class) is @@ -511,7 +542,8 @@ package body FLTK.Widgets.Groups is end if; return Actual_Widget; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Group::resizable returned Widget with no user_data reference back to Ada"; end Get_Resizable; @@ -545,6 +577,8 @@ package body FLTK.Widgets.Groups is + -- Current -- + function Get_Current return access Group'Class is @@ -558,7 +592,8 @@ package body FLTK.Widgets.Groups is end if; return Actual_Group; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Group::current returned Widget with no user_data reference back to Ada"; end Get_Current; @@ -585,6 +620,8 @@ package body FLTK.Widgets.Groups is + -- Drawing, Events -- + procedure Draw (This : in out Group) is begin diff --git a/body/fltk-widgets-inputs-text-file.adb b/body/fltk-widgets-inputs-text-file.adb index c7e4919..42c4961 100644 --- a/body/fltk-widgets-inputs-text-file.adb +++ b/body/fltk-widgets-inputs-text-file.adb @@ -28,6 +28,8 @@ package body FLTK.Widgets.Inputs.Text.File is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_file_input (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -43,6 +45,8 @@ package body FLTK.Widgets.Inputs.Text.File is + -- Settings -- + function fl_file_input_get_down_box (F : in Storage.Integer_Address) return Interfaces.C.int; @@ -70,6 +74,8 @@ package body FLTK.Widgets.Inputs.Text.File is + -- Text Field -- + function fl_file_input_get_value (F : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -87,6 +93,8 @@ package body FLTK.Widgets.Inputs.Text.File is + -- Drawing, Events -- + procedure fl_file_input_draw (W : in Storage.Integer_Address); pragma Import (C, fl_file_input_draw, "fl_file_input_draw"); @@ -156,11 +164,11 @@ package body FLTK.Widgets.Inputs.Text.File is begin return This : File_Input do This.Void_Ptr := new_fl_file_input - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -186,6 +194,8 @@ package body FLTK.Widgets.Inputs.Text.File is -- API Subprograms -- ----------------------- + -- Settings -- + function Get_Down_Box (This : in File_Input) return Box_Kind is @@ -220,11 +230,13 @@ package body FLTK.Widgets.Inputs.Text.File is + -- Text Field -- + function Get_Value (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 ""; @@ -239,18 +251,22 @@ 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 pragma Assert (Result /= 0); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Input::value returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_Value; + -- Drawing, Events -- + procedure Draw (This : in out File_Input) is begin diff --git a/body/fltk-widgets-inputs-text-floating_point.adb b/body/fltk-widgets-inputs-text-floating_point.adb index c7982d2..6a7925c 100644 --- a/body/fltk-widgets-inputs-text-floating_point.adb +++ b/body/fltk-widgets-inputs-text-floating_point.adb @@ -21,6 +21,8 @@ package body FLTK.Widgets.Inputs.Text.Floating_Point is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_float_input (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -36,6 +38,8 @@ package body FLTK.Widgets.Inputs.Text.Floating_Point is + -- Drawing, Events -- + procedure fl_float_input_draw (W : in Storage.Integer_Address); pragma Import (C, fl_float_input_draw, "fl_float_input_draw"); @@ -105,11 +109,11 @@ package body FLTK.Widgets.Inputs.Text.Floating_Point is begin return This : Float_Input do This.Void_Ptr := new_fl_float_input - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -135,11 +139,13 @@ package body FLTK.Widgets.Inputs.Text.Floating_Point is -- API Subprograms -- ----------------------- + -- Text Field -- + function Get_Value (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 27e0def..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Inputs.Text.Multiline is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_multiline_input (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Inputs.Text.Multiline is + -- Drawing, Events -- + procedure fl_multiline_input_draw (W : in Storage.Integer_Address); pragma Import (C, fl_multiline_input_draw, "fl_multiline_input_draw"); @@ -101,11 +104,11 @@ package body FLTK.Widgets.Inputs.Text.Multiline is begin return This : Multiline_Input do This.Void_Ptr := new_fl_multiline_input - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-inputs-text-outputs-multiline.adb b/body/fltk-widgets-inputs-text-outputs-multiline.adb index 4d8ade8..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Inputs.Text.Outputs.Multiline is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_multiline_output (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Inputs.Text.Outputs.Multiline is + -- Drawing, Events -- + procedure fl_multiline_output_draw (W : in Storage.Integer_Address); pragma Import (C, fl_multiline_output_draw, "fl_multiline_output_draw"); @@ -101,11 +104,11 @@ package body FLTK.Widgets.Inputs.Text.Outputs.Multiline is begin return This : Multiline_Output do This.Void_Ptr := new_fl_multiline_output - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-inputs-text-outputs.adb b/body/fltk-widgets-inputs-text-outputs.adb index 48e697f..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Inputs.Text.Outputs is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_output (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Inputs.Text.Outputs is + -- Drawing, Events -- + procedure fl_output_draw (W : in Storage.Integer_Address); pragma Import (C, fl_output_draw, "fl_output_draw"); @@ -101,11 +104,11 @@ package body FLTK.Widgets.Inputs.Text.Outputs is begin return This : Output do This.Void_Ptr := new_fl_output - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-inputs-text-secret.adb b/body/fltk-widgets-inputs-text-secret.adb index ab821d4..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Inputs.Text.Secret is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_secret_input (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Inputs.Text.Secret is + -- Drawing, Events -- + procedure fl_secret_input_draw (W : in Storage.Integer_Address); pragma Import (C, fl_secret_input_draw, "fl_secret_input_draw"); @@ -101,11 +104,11 @@ package body FLTK.Widgets.Inputs.Text.Secret is begin return This : Secret_Input do This.Void_Ptr := new_fl_secret_input - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -131,6 +134,8 @@ package body FLTK.Widgets.Inputs.Text.Secret is -- API Subprograms -- ----------------------- + -- Events -- + function Handle (This : in out Secret_Input; Event : in Event_Kind) diff --git a/body/fltk-widgets-inputs-text-whole_number.adb b/body/fltk-widgets-inputs-text-whole_number.adb index e5b0f85..070dc0f 100644 --- a/body/fltk-widgets-inputs-text-whole_number.adb +++ b/body/fltk-widgets-inputs-text-whole_number.adb @@ -21,6 +21,8 @@ package body FLTK.Widgets.Inputs.Text.Whole_Number is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_int_input (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -36,6 +38,8 @@ package body FLTK.Widgets.Inputs.Text.Whole_Number is + -- Drawing, Events -- + procedure fl_int_input_draw (W : in Storage.Integer_Address); pragma Import (C, fl_int_input_draw, "fl_int_input_draw"); @@ -105,11 +109,11 @@ package body FLTK.Widgets.Inputs.Text.Whole_Number is begin return This : Integer_Input do This.Void_Ptr := new_fl_int_input - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -135,11 +139,13 @@ package body FLTK.Widgets.Inputs.Text.Whole_Number is -- API Subprograms -- ----------------------- + -- Text Field -- + function Get_Value (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 efed39c..ddac5d9 100644 --- a/body/fltk-widgets-inputs-text.adb +++ b/body/fltk-widgets-inputs-text.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Inputs.Text is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_text_input (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Inputs.Text is + -- Drawing, Events -- + procedure fl_text_input_draw (T : in Storage.Integer_Address); pragma Import (C, fl_text_input_draw, "fl_text_input_draw"); @@ -51,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 @@ -171,6 +159,8 @@ package body FLTK.Widgets.Inputs.Text is -- API Subprograms -- ----------------------- + -- Drawing, Events -- + procedure Draw (This : in out Text_Input) is begin diff --git a/body/fltk-widgets-inputs.adb b/body/fltk-widgets-inputs.adb index 0d3a3fe..2057f96 100644 --- a/body/fltk-widgets-inputs.adb +++ b/body/fltk-widgets-inputs.adb @@ -28,6 +28,8 @@ package body FLTK.Widgets.Inputs is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_input (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -43,6 +45,8 @@ package body FLTK.Widgets.Inputs is + -- Clipboard -- + function fl_input_copy (I : in Storage.Integer_Address; C : in Interfaces.C.int) @@ -85,6 +89,8 @@ package body FLTK.Widgets.Inputs is + -- Readonly, Tabs, Wrap -- + function fl_input_get_readonly (I : in Storage.Integer_Address) return Interfaces.C.int; @@ -124,6 +130,8 @@ package body FLTK.Widgets.Inputs is + -- Shortcut, Input Position -- + function fl_input_get_input_type (I : in Storage.Integer_Address) return Interfaces.C.int; @@ -184,6 +192,8 @@ package body FLTK.Widgets.Inputs is + -- Text Field -- + function fl_input_index (I : in Storage.Integer_Address; P : in Interfaces.C.int) @@ -219,6 +229,8 @@ package body FLTK.Widgets.Inputs is + -- Input Size -- + function fl_input_get_maximum_size (I : in Storage.Integer_Address) return Interfaces.C.int; @@ -240,6 +252,8 @@ package body FLTK.Widgets.Inputs is + -- Cursors, Text Settings -- + function fl_input_get_cursor_color (I : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -291,6 +305,8 @@ package body FLTK.Widgets.Inputs is + -- Dimensions -- + procedure fl_input_set_size (I : in Storage.Integer_Address; W, H : in Interfaces.C.int); @@ -306,6 +322,8 @@ package body FLTK.Widgets.Inputs is + -- Drawing, Events -- + procedure fl_input_draw (W : in Storage.Integer_Address); pragma Import (C, fl_input_draw, "fl_input_draw"); @@ -375,11 +393,11 @@ package body FLTK.Widgets.Inputs is begin return This : Input do This.Void_Ptr := new_fl_input - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -405,16 +423,20 @@ package body FLTK.Widgets.Inputs is -- API Subprograms -- ----------------------- + -- Clipboard -- + procedure Copy (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); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Input_::copy returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Copy; @@ -423,20 +445,22 @@ 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); return Boolean'Val (Result); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Input_::copy returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Copy; 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; @@ -454,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 @@ -477,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)); @@ -501,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; @@ -511,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; @@ -520,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; @@ -536,6 +560,8 @@ package body FLTK.Widgets.Inputs is + -- Readonly, Tabs, Wrap -- + function Is_Readonly (This : in Input) return Boolean is @@ -586,11 +612,13 @@ package body FLTK.Widgets.Inputs is + -- Shortcut, Input Position -- + function Get_Kind (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 @@ -601,20 +629,20 @@ package body FLTK.Widgets.Inputs is end Get_Kind; - function Get_Shortcut_Key + function Get_Shortcut (This : in Input) return Key_Combo is begin - return To_Ada (fl_input_get_shortcut (This.Void_Ptr)); - end Get_Shortcut_Key; + return To_Ada (Interfaces.C.unsigned (fl_input_get_shortcut (This.Void_Ptr))); + end Get_Shortcut; - procedure Set_Shortcut_Key + procedure Set_Shortcut (This : in out Input; To : in Key_Combo) is begin - fl_input_set_shortcut (This.Void_Ptr, To_C (To)); - end Set_Shortcut_Key; + fl_input_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (To))); + end Set_Shortcut; function Get_Mark @@ -629,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 @@ -660,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 @@ -684,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)); @@ -708,6 +736,8 @@ package body FLTK.Widgets.Inputs is + -- Text Field -- + function Index (This : in Input; Place : in Integer) @@ -721,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); @@ -747,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), @@ -777,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 ""; @@ -792,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; @@ -813,6 +843,8 @@ package body FLTK.Widgets.Inputs is + -- Input Size -- + function Get_Maximum_Size (This : in Input) return Natural is @@ -839,6 +871,8 @@ package body FLTK.Widgets.Inputs is + -- Cursors, Text Settings -- + function Get_Cursor_Color (This : in Input) return Color is @@ -905,6 +939,8 @@ package body FLTK.Widgets.Inputs is + -- Dimensions -- + procedure Resize (This : in out Input; W, H : in Integer) is @@ -928,6 +964,8 @@ package body FLTK.Widgets.Inputs is + -- Changing Input Type -- + package body Extra is procedure Set_Kind diff --git a/body/fltk-widgets-menus-choices.adb b/body/fltk-widgets-menus-choices.adb index e4b52ad..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 @@ -22,6 +21,8 @@ package body FLTK.Widgets.Menus.Choices is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_choice (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -37,6 +38,8 @@ package body FLTK.Widgets.Menus.Choices is + -- Selection -- + function fl_choice_value (M : in Storage.Integer_Address) return Interfaces.C.int; @@ -59,6 +62,8 @@ package body FLTK.Widgets.Menus.Choices is + -- Drawing, Events -- + procedure fl_choice_draw (W : in Storage.Integer_Address); pragma Import (C, fl_choice_draw, "fl_choice_draw"); @@ -74,6 +79,8 @@ package body FLTK.Widgets.Menus.Choices is + -- Initialize -- + function fl_menu_get_item (M : in Storage.Integer_Address; I : in Interfaces.C.int) @@ -140,11 +147,11 @@ package body FLTK.Widgets.Menus.Choices is begin return This : Choice do This.Void_Ptr := new_fl_choice - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -170,6 +177,8 @@ package body FLTK.Widgets.Menus.Choices is -- API Subprograms -- ----------------------- + -- Selection -- + function Chosen_Index (This : in Choice) return Extended_Index is @@ -218,6 +227,8 @@ package body FLTK.Widgets.Menus.Choices is + -- Drawing, Events -- + procedure Draw (This : in out Choice) is begin diff --git a/body/fltk-widgets-menus-menu_bars-systemwide.adb b/body/fltk-widgets-menus-menu_bars-systemwide.adb index bccdc2e..88792bb 100644 --- a/body/fltk-widgets-menus-menu_bars-systemwide.adb +++ b/body/fltk-widgets-menus-menu_bars-systemwide.adb @@ -31,6 +31,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_sys_menu_bar (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -46,6 +48,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Menu Items -- + function fl_sys_menu_bar_add (M : in Storage.Integer_Address; T : in Interfaces.C.char_array) @@ -119,6 +123,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Item Query -- + function fl_sys_menu_bar_get_item (M : in Storage.Integer_Address; I : in Interfaces.C.int) @@ -129,6 +135,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Label, Shortcut, Flags -- + procedure fl_sys_menu_bar_setonly (M, I : in Storage.Integer_Address); pragma Import (C, fl_sys_menu_bar_setonly, "fl_sys_menu_bar_setonly"); @@ -165,6 +173,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Global -- + procedure fl_sys_menu_bar_global (M : in Storage.Integer_Address); pragma Import (C, fl_sys_menu_bar_global, "fl_sys_menu_bar_global"); @@ -178,6 +188,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Drawing, Events -- + procedure fl_sys_menu_bar_draw (M : in Storage.Integer_Address); pragma Import (C, fl_sys_menu_bar_draw, "fl_sys_menu_bar_draw"); @@ -193,6 +205,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Initialize -- + function fl_menu_value (M : in Storage.Integer_Address) return Interfaces.C.int; @@ -288,11 +302,13 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is -- API Subprograms -- ----------------------- + -- Menu Items -- + procedure Add (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; @@ -304,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; @@ -319,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; @@ -338,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); @@ -357,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; @@ -376,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); @@ -396,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; @@ -417,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); @@ -438,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; @@ -459,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); @@ -506,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 @@ -525,6 +541,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Item Query -- + function Item (This : in System_Menu_Bar; Place : in Index) @@ -536,6 +554,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Label, Shortcut, Flags -- + procedure Set_Only (This : in out System_Menu_Bar; Item : in out FLTK.Menu_Items.Menu_Item) is @@ -564,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; @@ -573,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; @@ -585,12 +606,14 @@ 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; + -- Global -- + procedure Make_Global (This : in out System_Menu_Bar) is begin @@ -607,6 +630,8 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Drawing -- + procedure Draw (This : in out System_Menu_Bar) is begin diff --git a/body/fltk-widgets-menus-menu_bars.adb b/body/fltk-widgets-menus-menu_bars.adb index f1dba40..ec865c8 100644 --- a/body/fltk-widgets-menus-menu_bars.adb +++ b/body/fltk-widgets-menus-menu_bars.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Menus.Menu_Bars is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_menu_bar (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Menus.Menu_Bars is + -- Drawing, Events -- + procedure fl_menu_bar_draw (W : in Storage.Integer_Address); pragma Import (C, fl_menu_bar_draw, "fl_menu_bar_draw"); @@ -47,6 +51,8 @@ package body FLTK.Widgets.Menus.Menu_Bars is + -- Initialize -- + function fl_menu_get_item (M : in Storage.Integer_Address; I : in Interfaces.C.int) @@ -119,11 +125,11 @@ package body FLTK.Widgets.Menus.Menu_Bars is begin return This : Menu_Bar do This.Void_Ptr := new_fl_menu_bar - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -149,6 +155,8 @@ package body FLTK.Widgets.Menus.Menu_Bars is -- API Subprograms -- ----------------------- + -- Drawing, Events -- + procedure Draw (This : in out Menu_Bar) is begin diff --git a/body/fltk-widgets-menus-menu_buttons.adb b/body/fltk-widgets-menus-menu_buttons.adb index b526e49..c305320 100644 --- a/body/fltk-widgets-menus-menu_buttons.adb +++ b/body/fltk-widgets-menus-menu_buttons.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Menus.Menu_Buttons is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_menu_button (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Menus.Menu_Buttons is + -- Popup -- + function fl_menu_button_popup (M : in Storage.Integer_Address) return Storage.Integer_Address; @@ -47,6 +51,8 @@ package body FLTK.Widgets.Menus.Menu_Buttons is + -- Drawing, Events -- + procedure fl_menu_button_draw (W : in Storage.Integer_Address); pragma Import (C, fl_menu_button_draw, "fl_menu_button_draw"); @@ -62,6 +68,8 @@ package body FLTK.Widgets.Menus.Menu_Buttons is + -- Initialize -- + function fl_menu_get_item (M : in Storage.Integer_Address; I : in Interfaces.C.int) @@ -82,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 @@ -174,11 +166,11 @@ package body FLTK.Widgets.Menus.Menu_Buttons is begin return This : Menu_Button do This.Void_Ptr := new_fl_menu_button - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -204,11 +196,13 @@ package body FLTK.Widgets.Menus.Menu_Buttons is -- API Subprograms -- ----------------------- + -- Popup -- + function Get_Popup_Kind (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 @@ -231,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; @@ -239,6 +233,8 @@ package body FLTK.Widgets.Menus.Menu_Buttons is + -- Drawing, Events -- + procedure Draw (This : in out Menu_Button) is begin diff --git a/body/fltk-widgets-menus.adb b/body/fltk-widgets-menus.adb index 034cd4c..1295d76 100644 --- a/body/fltk-widgets-menus.adb +++ b/body/fltk-widgets-menus.adb @@ -32,6 +32,8 @@ package body FLTK.Widgets.Menus is -- Functions From C -- ------------------------ + -- Allocation -- + function null_fl_menu_item return Storage.Integer_Address; pragma Import (C, null_fl_menu_item, "null_fl_menu_item"); @@ -57,6 +59,8 @@ package body FLTK.Widgets.Menus is + -- Menu Items -- + function fl_menu_add (M : in Storage.Integer_Address; T : in Interfaces.C.char_array) @@ -135,6 +139,8 @@ package body FLTK.Widgets.Menus is + -- Item Query -- + function fl_menu_get_item (M : in Storage.Integer_Address; I : in Interfaces.C.int) @@ -179,6 +185,8 @@ package body FLTK.Widgets.Menus is + -- Selection -- + function fl_menu_text (M : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -207,6 +215,8 @@ package body FLTK.Widgets.Menus is + -- Label, Shortcut, Flags -- + procedure fl_menu_setonly (M, I : in Storage.Integer_Address); pragma Import (C, fl_menu_setonly, "fl_menu_setonly"); @@ -250,6 +260,8 @@ package body FLTK.Widgets.Menus is + -- Text Settings -- + function fl_menu_get_textcolor (M : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -289,6 +301,8 @@ package body FLTK.Widgets.Menus is + -- Miscellaneous -- + function fl_menu_get_down_box (M : in Storage.Integer_Address) return Interfaces.C.int; @@ -317,6 +331,8 @@ package body FLTK.Widgets.Menus is + -- Menu Item Methods -- + function fl_menu_popup (M : in Storage.Integer_Address; X, Y : in Interfaces.C.int; @@ -356,6 +372,8 @@ package body FLTK.Widgets.Menus is + -- Dimensions -- + procedure fl_menu_size2 (M : in Storage.Integer_Address; W, H : in Interfaces.C.int); @@ -365,6 +383,8 @@ package body FLTK.Widgets.Menus is + -- Drawing, Events -- + procedure fl_menu_draw_item (M : in Storage.Integer_Address; I : in Interfaces.C.int; @@ -395,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)); @@ -426,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)); @@ -542,11 +562,13 @@ package body FLTK.Widgets.Menus is -- API Subprograms -- ----------------------- + -- Menu Items -- + procedure Add (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; @@ -557,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); @@ -571,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; @@ -590,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); @@ -609,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; @@ -628,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); @@ -648,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; @@ -669,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); @@ -690,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; @@ -711,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); @@ -728,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 @@ -774,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 @@ -793,6 +817,8 @@ package body FLTK.Widgets.Menus is + -- Item Query -- + function Has_Item (This : in Menu; Place : in Index) @@ -842,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; @@ -856,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; @@ -870,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; @@ -881,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; @@ -907,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), @@ -935,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), @@ -969,11 +997,13 @@ package body FLTK.Widgets.Menus is + -- Iteration -- + function Iterate (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; @@ -981,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; @@ -992,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; @@ -1002,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; @@ -1013,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; @@ -1021,11 +1051,13 @@ package body FLTK.Widgets.Menus is + -- Selection -- + function Chosen (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; @@ -1038,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 ""; @@ -1102,6 +1134,8 @@ package body FLTK.Widgets.Menus is + -- Label, Shortcut, Flags -- + procedure Set_Only (This : in out Menu; Item : in out FLTK.Menu_Items.Menu_Item) is @@ -1115,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 @@ -1147,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; @@ -1156,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; @@ -1168,12 +1202,14 @@ 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; + -- Text Settings -- + function Get_Text_Color (This : in Menu) return Color is @@ -1194,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 @@ -1216,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 @@ -1236,11 +1272,13 @@ package body FLTK.Widgets.Menus is + -- Miscellaneous -- + function Get_Down_Box (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 @@ -1279,6 +1317,8 @@ package body FLTK.Widgets.Menus is + -- Menu Item Methods -- + function Popup (This : in Menu; X, Y : in Integer; @@ -1287,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), @@ -1306,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), @@ -1335,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)); @@ -1356,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)); @@ -1376,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; @@ -1389,6 +1429,8 @@ package body FLTK.Widgets.Menus is + -- Dimensions -- + procedure Resize (This : in out Menu; W, H : in Integer) is @@ -1402,6 +1444,8 @@ package body FLTK.Widgets.Menus is + -- Drawing -- + procedure Draw_Item (This : in out Menu; Item : in Index; diff --git a/body/fltk-widgets-positioners.adb b/body/fltk-widgets-positioners.adb index 053d731..29246cd 100644 --- a/body/fltk-widgets-positioners.adb +++ b/body/fltk-widgets-positioners.adb @@ -23,6 +23,8 @@ package body FLTK.Widgets.Positioners is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_positioner (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -38,6 +40,8 @@ package body FLTK.Widgets.Positioners is + -- Targeting -- + function fl_positioner_set_value (P : in Storage.Integer_Address; X, Y : in Interfaces.C.double) @@ -48,6 +52,8 @@ package body FLTK.Widgets.Positioners is + -- X Axis -- + procedure fl_positioner_xbounds (P : in Storage.Integer_Address; L, H : in Interfaces.C.double); @@ -100,6 +106,8 @@ package body FLTK.Widgets.Positioners is + -- Y Axis -- + procedure fl_positioner_ybounds (P : in Storage.Integer_Address; L, H : in Interfaces.C.double); @@ -152,6 +160,8 @@ package body FLTK.Widgets.Positioners is + -- Drawing, Events -- + procedure fl_positioner_draw (P : in Storage.Integer_Address); pragma Import (C, fl_positioner_draw, "fl_positioner_draw"); @@ -264,6 +274,8 @@ package body FLTK.Widgets.Positioners is -- API Subprograms -- ----------------------- + -- Targeting -- + procedure Get_Coords (This : in Positioner; X, Y : out Long_Float) is @@ -277,14 +289,16 @@ 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)); begin pragma Assert (Result in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Positioner::value returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_Coords; @@ -293,19 +307,23 @@ 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)); begin return Boolean'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Positioner::value returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_Coords; + -- X Axis -- + procedure Set_Ecks_Bounds (This : in out Positioner; Low, High : in Long_Float) is @@ -369,13 +387,15 @@ 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 pragma Assert (Result in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Positioner::xvalue returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_Ecks; @@ -384,18 +404,22 @@ 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 return Boolean'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Positioner::xvalue returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_Ecks; + -- Y Axis -- + procedure Set_Why_Bounds (This : in out Positioner; Low, High : in Long_Float) is @@ -459,13 +483,15 @@ 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 pragma Assert (Result in 0 .. 1); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Positioner::yvalue returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_Why; @@ -474,18 +500,22 @@ 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 return Boolean'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Positioner::yvalue returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Set_Why; + -- Drawing, Events -- + procedure Draw (This : in out Positioner) is begin @@ -519,17 +549,21 @@ package body FLTK.Widgets.Positioners is (This : in out Positioner; Event : in Event_Kind; X, Y, W, H : in Integer) - return Event_Outcome is - begin - return Event_Outcome'Val (fl_positioner_handle2 + return Event_Outcome + is + Result : constant Interfaces.C.int := fl_positioner_handle2 (This.Void_Ptr, Event_Kind'Pos (Event), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), - Interfaces.C.int (H))); + Interfaces.C.int (H)); + begin + return Event_Outcome'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Positioner::handle returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Handle; diff --git a/body/fltk-widgets-progress_bars.adb b/body/fltk-widgets-progress_bars.adb index b82fef6..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Progress_Bars is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_progress (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Progress_Bars is + -- Values -- + function fl_progress_get_minimum (P : in Storage.Integer_Address) return Interfaces.C.C_float; @@ -71,6 +75,8 @@ package body FLTK.Widgets.Progress_Bars is + -- Drawing, Events -- + procedure fl_progress_draw (P : in Storage.Integer_Address); pragma Import (C, fl_progress_draw, "fl_progress_draw"); @@ -140,11 +146,11 @@ package body FLTK.Widgets.Progress_Bars is begin return This : Progress_Bar do This.Void_Ptr := new_fl_progress - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -170,6 +176,8 @@ package body FLTK.Widgets.Progress_Bars is -- API Subprograms -- ----------------------- + -- Values -- + function Get_Minimum (This : in Progress_Bar) return Float is @@ -220,6 +228,8 @@ package body FLTK.Widgets.Progress_Bars is + -- Drawing -- + procedure Draw (This : in out Progress_Bar) is begin diff --git a/body/fltk-widgets-valuators-adjusters.adb b/body/fltk-widgets-valuators-adjusters.adb index 89294e0..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 @@ -21,6 +21,8 @@ package body FLTK.Widgets.Valuators.Adjusters is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_adjuster (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -36,6 +38,8 @@ package body FLTK.Widgets.Valuators.Adjusters is + -- Allow Outside Range -- + function fl_adjuster_is_soft (A : in Storage.Integer_Address) return Interfaces.C.int; @@ -51,6 +55,8 @@ package body FLTK.Widgets.Valuators.Adjusters is + -- Drawing, Events -- + procedure fl_adjuster_value_damage (A : in Storage.Integer_Address); pragma Import (C, fl_adjuster_value_damage, "fl_adjuster_value_damage"); @@ -125,11 +131,11 @@ package body FLTK.Widgets.Valuators.Adjusters is begin return This : Adjuster do This.Void_Ptr := new_fl_adjuster - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -155,6 +161,8 @@ package body FLTK.Widgets.Valuators.Adjusters is -- API Subprograms -- ----------------------- + -- Allow Outside Range -- + function Is_Soft (This : in Adjuster) return Boolean is @@ -173,6 +181,8 @@ package body FLTK.Widgets.Valuators.Adjusters is + -- Drawing, Events -- + procedure Value_Damage (This : in out Adjuster) is begin diff --git a/body/fltk-widgets-valuators-counters-simple.adb b/body/fltk-widgets-valuators-counters-simple.adb index f1d39b8..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Valuators.Counters.Simple is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_simple_counter (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Valuators.Counters.Simple is + -- Drawing, Events -- + procedure fl_simple_counter_draw (W : in Storage.Integer_Address); pragma Import (C, fl_simple_counter_draw, "fl_simple_counter_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Valuators.Counters.Simple is begin return This : Simple_Counter do This.Void_Ptr := new_fl_simple_counter - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-valuators-counters.adb b/body/fltk-widgets-valuators-counters.adb index e04e180..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Valuators.Counters is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_counter (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Valuators.Counters is + -- Button Steps -- + function fl_counter_get_step (C : in Storage.Integer_Address) return Interfaces.C.double; @@ -59,6 +62,8 @@ package body FLTK.Widgets.Valuators.Counters is + -- Text Settings -- + function fl_counter_get_textcolor (C : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -98,6 +103,8 @@ package body FLTK.Widgets.Valuators.Counters is + -- Drawing, Events -- + procedure fl_counter_draw (W : in Storage.Integer_Address); pragma Import (C, fl_counter_draw, "fl_counter_draw"); @@ -167,11 +174,11 @@ package body FLTK.Widgets.Valuators.Counters is begin return This : Counter do This.Void_Ptr := new_fl_counter - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -197,6 +204,8 @@ package body FLTK.Widgets.Valuators.Counters is -- API Subprograms -- ----------------------- + -- Button Steps -- + function Get_Step (This : in Counter) return Long_Float is @@ -243,6 +252,8 @@ package body FLTK.Widgets.Valuators.Counters is + -- Text Settings -- + function Get_Text_Color (This : in Counter) return Color is @@ -293,6 +304,8 @@ package body FLTK.Widgets.Valuators.Counters is + -- Drawing, Events -- + procedure Draw (This : in out Counter) is begin @@ -311,11 +324,13 @@ package body FLTK.Widgets.Valuators.Counters is + -- Counter Type -- + function Get_Kind (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 ba378be..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Valuators.Dials.Fill is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_fill_dial (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Valuators.Dials.Fill is + -- Drawing, Events -- + procedure fl_fill_dial_draw (W : in Storage.Integer_Address); pragma Import (C, fl_fill_dial_draw, "fl_fill_dial_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Valuators.Dials.Fill is begin return This : Fill_Dial do This.Void_Ptr := new_fl_fill_dial - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-valuators-dials-line.adb b/body/fltk-widgets-valuators-dials-line.adb index c20a828..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Valuators.Dials.Line is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_line_dial (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Valuators.Dials.Line is + -- Drawing, Events -- + procedure fl_line_dial_draw (W : in Storage.Integer_Address); pragma Import (C, fl_line_dial_draw, "fl_line_dial_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Valuators.Dials.Line is begin return This : Line_Dial do This.Void_Ptr := new_fl_line_dial - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-valuators-dials.adb b/body/fltk-widgets-valuators-dials.adb index 6dc9e69..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Valuators.Dials is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_dial (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Valuators.Dials is + -- Limit Angles -- + function fl_dial_get_angle1 (D : in Storage.Integer_Address) return Interfaces.C.short; @@ -65,6 +68,8 @@ package body FLTK.Widgets.Valuators.Dials is + -- Drawing, Events -- + procedure fl_dial_draw (W : in Storage.Integer_Address); pragma Import (C, fl_dial_draw, "fl_dial_draw"); @@ -93,6 +98,8 @@ package body FLTK.Widgets.Valuators.Dials is + -- Dial Type -- + function fl_widget_get_type (D : in Storage.Integer_Address) return Interfaces.C.unsigned_char; @@ -162,11 +169,11 @@ package body FLTK.Widgets.Valuators.Dials is begin return This : Dial do This.Void_Ptr := new_fl_dial - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -192,6 +199,8 @@ package body FLTK.Widgets.Valuators.Dials is -- API Subprograms -- ----------------------- + -- Limit Angles -- + function Get_First_Angle (This : in Dial) return Short_Integer is @@ -237,6 +246,8 @@ package body FLTK.Widgets.Valuators.Dials is + -- Drawing, Events -- + procedure Draw (This : in out Dial) is begin @@ -270,27 +281,33 @@ package body FLTK.Widgets.Valuators.Dials is (This : in out Dial; Event : in Event_Kind; X, Y, W, H : in Integer) - return Event_Outcome is - begin - return Event_Outcome'Val (fl_dial_handle2 + return Event_Outcome + is + Result : constant Interfaces.C.int := fl_dial_handle2 (This.Void_Ptr, Event_Kind'Pos (Event), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), - Interfaces.C.int (H))); + Interfaces.C.int (H)); + begin + return Event_Outcome'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Dial::handle returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Handle; + -- Dial Type -- + function Get_Kind (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 912d374..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Valuators.Rollers is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_roller (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Valuators.Rollers is + -- Drawing, Events -- + procedure fl_roller_draw (W : in Storage.Integer_Address); pragma Import (C, fl_roller_draw, "fl_roller_draw"); @@ -101,11 +104,11 @@ package body FLTK.Widgets.Valuators.Rollers is begin return This : Roller do This.Void_Ptr := new_fl_roller - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -131,6 +134,8 @@ package body FLTK.Widgets.Valuators.Rollers is -- API Subprograms -- ----------------------- + -- Drawing, Events -- + procedure Draw (This : in out Roller) is begin diff --git a/body/fltk-widgets-valuators-sliders-fill.adb b/body/fltk-widgets-valuators-sliders-fill.adb index faeef64..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Valuators.Sliders.Fill is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_fill_slider (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Valuators.Sliders.Fill is + -- Drawing, Events -- + procedure fl_fill_slider_draw (W : in Storage.Integer_Address); pragma Import (C, fl_fill_slider_draw, "fl_fill_slider_draw"); @@ -101,11 +104,11 @@ package body FLTK.Widgets.Valuators.Sliders.Fill is begin return This : Fill_Slider do This.Void_Ptr := new_fl_fill_slider - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-valuators-sliders-horizontal.adb b/body/fltk-widgets-valuators-sliders-horizontal.adb index fdb722c..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Valuators.Sliders.Horizontal is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_horizontal_slider (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Valuators.Sliders.Horizontal is + -- Drawing, Events -- + procedure fl_horizontal_slider_draw (W : in Storage.Integer_Address); pragma Import (C, fl_horizontal_slider_draw, "fl_horizontal_slider_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Valuators.Sliders.Horizontal is begin return This : Horizontal_Slider do This.Void_Ptr := new_fl_horizontal_slider - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-valuators-sliders-horizontal_fill.adb b/body/fltk-widgets-valuators-sliders-horizontal_fill.adb index 5b681a3..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Valuators.Sliders.Horizontal_Fill is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_hor_fill_slider (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Valuators.Sliders.Horizontal_Fill is + -- Drawing, Events -- + procedure fl_hor_fill_slider_draw (W : in Storage.Integer_Address); pragma Import (C, fl_hor_fill_slider_draw, "fl_hor_fill_slider_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Valuators.Sliders.Horizontal_Fill is begin return This : Horizontal_Fill_Slider do This.Void_Ptr := new_fl_hor_fill_slider - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-valuators-sliders-horizontal_nice.adb b/body/fltk-widgets-valuators-sliders-horizontal_nice.adb index 3e3d89d..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Valuators.Sliders.Horizontal_Nice is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_hor_nice_slider (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Valuators.Sliders.Horizontal_Nice is + -- Drawing, Events -- + procedure fl_hor_nice_slider_draw (W : in Storage.Integer_Address); pragma Import (C, fl_hor_nice_slider_draw, "fl_hor_nice_slider_draw"); @@ -101,11 +104,11 @@ package body FLTK.Widgets.Valuators.Sliders.Horizontal_Nice is begin return This : Horizontal_Nice_Slider do This.Void_Ptr := new_fl_hor_nice_slider - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-valuators-sliders-nice.adb b/body/fltk-widgets-valuators-sliders-nice.adb index b9bc449..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 @@ -17,6 +16,8 @@ package body FLTK.Widgets.Valuators.Sliders.Nice is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_nice_slider (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +33,8 @@ package body FLTK.Widgets.Valuators.Sliders.Nice is + -- Drawing, Events -- + procedure fl_nice_slider_draw (W : in Storage.Integer_Address); pragma Import (C, fl_nice_slider_draw, "fl_nice_slider_draw"); @@ -101,11 +104,11 @@ package body FLTK.Widgets.Valuators.Sliders.Nice is begin return This : Nice_Slider do This.Void_Ptr := new_fl_nice_slider - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-valuators-sliders-scrollbars.adb b/body/fltk-widgets-valuators-sliders-scrollbars.adb index 26d9049..660970a 100644 --- a/body/fltk-widgets-valuators-sliders-scrollbars.adb +++ b/body/fltk-widgets-valuators-sliders-scrollbars.adb @@ -17,6 +17,8 @@ package body FLTK.Widgets.Valuators.Sliders.Scrollbars is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_scrollbar (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Valuators.Sliders.Scrollbars is + -- Line Position -- + function fl_scrollbar_get_linesize (S : in Storage.Integer_Address) return Interfaces.C.int; @@ -65,6 +69,8 @@ package body FLTK.Widgets.Valuators.Sliders.Scrollbars is + -- Drawing, Events -- + procedure fl_scrollbar_draw (W : in Storage.Integer_Address); pragma Import (C, fl_scrollbar_draw, "fl_scrollbar_draw"); @@ -84,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 @@ -174,11 +164,11 @@ package body FLTK.Widgets.Valuators.Sliders.Scrollbars is begin return This : Scrollbar do This.Void_Ptr := new_fl_scrollbar - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -204,6 +194,8 @@ package body FLTK.Widgets.Valuators.Sliders.Scrollbars is -- API Subprograms -- ----------------------- + -- Line Position -- + function Get_Line_Size (This : in Scrollbar) return Natural is @@ -254,6 +246,8 @@ package body FLTK.Widgets.Valuators.Sliders.Scrollbars is + -- Drawing, Events -- + procedure Draw (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 fd91800..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Valuators.Sliders.Value.Horizontal is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_hor_value_slider (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Valuators.Sliders.Value.Horizontal is + -- Drawing, Events -- + procedure fl_hor_value_slider_draw (W : in Storage.Integer_Address); pragma Import (C, fl_hor_value_slider_draw, "fl_hor_value_slider_draw"); @@ -101,11 +105,11 @@ package body FLTK.Widgets.Valuators.Sliders.Value.Horizontal is begin return This : Horizontal_Value_Slider do This.Void_Ptr := new_fl_hor_value_slider - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; diff --git a/body/fltk-widgets-valuators-sliders-value.adb b/body/fltk-widgets-valuators-sliders-value.adb index 9d32529..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Valuators.Sliders.Value is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_value_slider (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -32,6 +34,8 @@ package body FLTK.Widgets.Valuators.Sliders.Value is + -- Text Settings -- + function fl_value_slider_get_textcolor (S : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -71,6 +75,8 @@ package body FLTK.Widgets.Valuators.Sliders.Value is + -- Drawing, Events -- + procedure fl_value_slider_draw (W : in Storage.Integer_Address); pragma Import (C, fl_value_slider_draw, "fl_value_slider_draw"); @@ -140,11 +146,11 @@ package body FLTK.Widgets.Valuators.Sliders.Value is begin return This : Value_Slider do This.Void_Ptr := new_fl_value_slider - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -170,6 +176,8 @@ package body FLTK.Widgets.Valuators.Sliders.Value is -- API Subprograms -- ----------------------- + -- Text Settings -- + function Get_Text_Color (This : in Value_Slider) return Color is @@ -220,6 +228,8 @@ package body FLTK.Widgets.Valuators.Sliders.Value is + -- Drawing, Events -- + procedure Draw (This : in out Value_Slider) is begin diff --git a/body/fltk-widgets-valuators-sliders.adb b/body/fltk-widgets-valuators-sliders.adb index b81729f..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 @@ -17,6 +17,8 @@ package body FLTK.Widgets.Valuators.Sliders is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_slider (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -40,6 +42,8 @@ package body FLTK.Widgets.Valuators.Sliders is + -- Settings -- + procedure fl_slider_set_bounds (S : in Storage.Integer_Address; A, B : in Interfaces.C.double); @@ -80,6 +84,8 @@ package body FLTK.Widgets.Valuators.Sliders is + -- Drawing, Events -- + procedure fl_slider_draw (W : in Storage.Integer_Address); pragma Import (C, fl_slider_draw, "fl_slider_draw"); @@ -108,6 +114,8 @@ package body FLTK.Widgets.Valuators.Sliders is + -- Slider Type -- + function fl_widget_get_type (S : in Storage.Integer_Address) return Interfaces.C.unsigned_char; @@ -177,11 +185,11 @@ package body FLTK.Widgets.Valuators.Sliders is begin return This : Slider do This.Void_Ptr := new_fl_slider - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -239,6 +247,8 @@ package body FLTK.Widgets.Valuators.Sliders is -- API Subprograms -- ----------------------- + -- Settings -- + procedure Set_Bounds (This : in out Slider; Min, Max : in Long_Float) is @@ -302,6 +312,8 @@ package body FLTK.Widgets.Valuators.Sliders is + -- Drawing, Events -- + procedure Draw (This : in out Slider) is begin @@ -349,11 +361,13 @@ package body FLTK.Widgets.Valuators.Sliders is + -- Slider Type -- + function Get_Kind (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 6091d55..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 @@ -21,6 +21,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_value_input (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -36,6 +38,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Attributes -- + function fl_value_input_get_input (V : in Storage.Integer_Address) return Storage.Integer_Address; @@ -45,6 +49,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Cursors -- + function fl_value_input_get_cursor_color (TD : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -60,6 +66,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Shortcut -- + function fl_value_input_get_shortcut (B : in Storage.Integer_Address) return Interfaces.C.int; @@ -75,6 +83,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Allow Outside Range -- + function fl_value_input_is_soft (A : in Storage.Integer_Address) return Interfaces.C.int; @@ -90,6 +100,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Text Settings -- + function fl_value_input_get_text_color (TD : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -129,6 +141,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Dimensions -- + procedure fl_value_input_resize (TD : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int); @@ -138,6 +152,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Drawing, Events -- + procedure fl_value_input_draw (W : in Storage.Integer_Address); pragma Import (C, fl_value_input_draw, "fl_value_input_draw"); @@ -157,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; @@ -233,11 +241,11 @@ package body FLTK.Widgets.Valuators.Value_Inputs is begin return This : Value_Input do This.Void_Ptr := new_fl_value_input - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -259,9 +267,11 @@ package body FLTK.Widgets.Valuators.Value_Inputs is - ------------------ + ----------------------- + -- API Subprograms -- + ----------------------- + -- Attributes -- - ------------------ function Text_Field (This : in out Value_Input) @@ -273,9 +283,7 @@ package body FLTK.Widgets.Valuators.Value_Inputs is - ----------------------- - -- API Subprograms -- - ----------------------- + -- Cursors -- function Get_Cursor_Color (This : in Value_Input) @@ -295,11 +303,13 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Shortcut -- + function Get_Shortcut (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; @@ -313,6 +323,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Allow Outside Range -- + function Is_Soft (This : in Value_Input) return Boolean is @@ -331,6 +343,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Text Settings -- + function Get_Text_Color (This : in Value_Input) return Color is @@ -381,6 +395,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Dimensions -- + procedure Resize (This : in out Value_Input; X, Y, W, H : in Integer) is @@ -396,6 +412,8 @@ package body FLTK.Widgets.Valuators.Value_Inputs is + -- Drawing, Events -- + procedure Draw (This : in out Value_Input) is begin diff --git a/body/fltk-widgets-valuators-value_outputs.adb b/body/fltk-widgets-valuators-value_outputs.adb index 935e021..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 @@ -21,6 +21,8 @@ package body FLTK.Widgets.Valuators.Value_Outputs is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_value_output (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -36,6 +38,8 @@ package body FLTK.Widgets.Valuators.Value_Outputs is + -- Allow Outside Range -- + function fl_value_output_is_soft (A : in Storage.Integer_Address) return Interfaces.C.int; @@ -51,6 +55,8 @@ package body FLTK.Widgets.Valuators.Value_Outputs is + -- Text Settings -- + function fl_value_output_get_text_color (TD : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -90,6 +96,8 @@ package body FLTK.Widgets.Valuators.Value_Outputs is + -- Drawing, Events -- + procedure fl_value_output_draw (W : in Storage.Integer_Address); pragma Import (C, fl_value_output_draw, "fl_value_output_draw"); @@ -159,11 +167,11 @@ package body FLTK.Widgets.Valuators.Value_Outputs is begin return This : Value_Output do This.Void_Ptr := new_fl_value_output - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -189,6 +197,8 @@ package body FLTK.Widgets.Valuators.Value_Outputs is -- API Subprograms -- ----------------------- + -- Allow Outside Range -- + function Is_Soft (This : in Value_Output) return Boolean is @@ -207,6 +217,8 @@ package body FLTK.Widgets.Valuators.Value_Outputs is + -- Text Settings -- + function Get_Text_Color (This : in Value_Output) return Color is @@ -257,6 +269,8 @@ package body FLTK.Widgets.Valuators.Value_Outputs is + -- Drawing, Events -- + procedure Draw (This : in out Value_Output) is begin diff --git a/body/fltk-widgets-valuators.adb b/body/fltk-widgets-valuators.adb index 0cf8d65..c762fe4 100644 --- a/body/fltk-widgets-valuators.adb +++ b/body/fltk-widgets-valuators.adb @@ -26,6 +26,8 @@ package body FLTK.Widgets.Valuators is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_valuator (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -41,6 +43,8 @@ package body FLTK.Widgets.Valuators is + -- Formatting -- + function fl_valuator_format (V : in Storage.Integer_Address; B : out Interfaces.C.char_array) @@ -51,6 +55,8 @@ package body FLTK.Widgets.Valuators is + -- Calculation -- + function fl_valuator_clamp (V : in Storage.Integer_Address; D : in Interfaces.C.double) @@ -76,6 +82,8 @@ package body FLTK.Widgets.Valuators is + -- Settings, Value -- + function fl_valuator_get_minimum (V : in Storage.Integer_Address) return Interfaces.C.double; @@ -158,6 +166,8 @@ package body FLTK.Widgets.Valuators is + -- Drawing, Events -- + procedure fl_valuator_value_damage (V : in Storage.Integer_Address); pragma Import (C, fl_valuator_value_damage, "fl_valuator_value_damage"); @@ -200,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); @@ -273,11 +283,11 @@ package body FLTK.Widgets.Valuators is begin return This : Valuator do This.Void_Ptr := new_fl_valuator - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -303,13 +313,15 @@ package body FLTK.Widgets.Valuators is -- API Subprograms -- ----------------------- + -- Formatting -- + function Format (This : in Valuator) return String 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; @@ -317,6 +329,8 @@ package body FLTK.Widgets.Valuators is + -- Calculation -- + function Clamp (This : in Valuator; Input : in Long_Float) @@ -350,6 +364,8 @@ package body FLTK.Widgets.Valuators is + -- Settings, Value -- + function Get_Minimum (This : in Valuator) return Long_Float is @@ -470,6 +486,8 @@ package body FLTK.Widgets.Valuators is + -- Drawing -- + procedure Value_Damage (This : in out Valuator) is begin diff --git a/body/fltk-widgets.adb b/body/fltk-widgets.adb index a312641..f4409e4 100644 --- a/body/fltk-widgets.adb +++ b/body/fltk-widgets.adb @@ -8,14 +8,13 @@ with Ada.Assertions, Interfaces.C.Strings, - System.Address_To_Access_Conversions, - FLTK.Widgets.Groups.Windows, - FLTK.Images; + FLTK.Widgets.Groups.Windows; use type Interfaces.C.int, Interfaces.C.unsigned, + Interfaces.C.unsigned_char, Interfaces.C.Strings.chars_ptr; @@ -25,14 +24,6 @@ package body FLTK.Widgets is package Chk renames Ada.Assertions; - function "+" - (Left, Right : in Callback_Flag) - return Callback_Flag is - begin - return Left or Right; - end "+"; - - package Group_Convert is new System.Address_To_Access_Conversions (FLTK.Widgets.Groups.Group'Class); @@ -46,6 +37,8 @@ package body FLTK.Widgets is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_widget (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -61,6 +54,8 @@ package body FLTK.Widgets is + -- Activity -- + procedure fl_widget_activate (W : in Storage.Integer_Address); pragma Import (C, fl_widget_activate, "fl_widget_activate"); @@ -96,6 +91,8 @@ package body FLTK.Widgets is + -- Changed and Output -- + function fl_widget_changed (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -128,6 +125,11 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_clear_output, "fl_widget_clear_output"); pragma Inline (fl_widget_clear_output); + + + + -- Visibility -- + function fl_widget_visible (W : in Storage.Integer_Address) return Interfaces.C.int; @@ -150,21 +152,43 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_clear_visible, "fl_widget_clear_visible"); pragma Inline (fl_widget_clear_visible); + procedure fl_widget_show + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_show, "fl_widget_show"); + pragma Inline (fl_widget_show); + + procedure fl_widget_hide + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_hide, "fl_widget_hide"); + pragma Inline (fl_widget_hide); + + -- Focus -- + function fl_widget_get_visible_focus (W : in Storage.Integer_Address) return Interfaces.C.int; pragma Import (C, fl_widget_get_visible_focus, "fl_widget_get_visible_focus"); pragma Inline (fl_widget_get_visible_focus); + procedure fl_widget_set_visible_focus2 + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_visible_focus2, "fl_widget_set_visible_focus2"); + pragma Inline (fl_widget_set_visible_focus2); + procedure fl_widget_set_visible_focus (W : in Storage.Integer_Address; T : in Interfaces.C.int); pragma Import (C, fl_widget_set_visible_focus, "fl_widget_set_visible_focus"); pragma Inline (fl_widget_set_visible_focus); + procedure fl_widget_clear_visible_focus + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_clear_visible_focus, "fl_widget_clear_visible_focus"); + pragma Inline (fl_widget_clear_visible_focus); + function fl_widget_take_focus (W : in Storage.Integer_Address) return Interfaces.C.int; @@ -180,6 +204,8 @@ package body FLTK.Widgets is + -- Colors -- + function fl_widget_get_color (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -204,9 +230,17 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_set_selection_color, "fl_widget_set_selection_color"); pragma Inline (fl_widget_set_selection_color); + procedure fl_widget_set_colors + (W : in Storage.Integer_Address; + B, S : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_set_colors, "fl_widget_set_colors"); + pragma Inline (fl_widget_set_colors); + + -- Relatives -- + function fl_widget_get_parent (W : in Storage.Integer_Address) return Storage.Integer_Address; @@ -247,6 +281,8 @@ package body FLTK.Widgets is + -- Alignment, Box, Tooltip -- + function fl_widget_get_align (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -286,6 +322,8 @@ package body FLTK.Widgets is + -- Labels -- + function fl_widget_get_label (W : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -349,26 +387,35 @@ package body FLTK.Widgets is + -- Callbacks -- + procedure fl_widget_set_callback (W, C : in Storage.Integer_Address); pragma Import (C, fl_widget_set_callback, "fl_widget_set_callback"); pragma Inline (fl_widget_set_callback); + procedure fl_widget_default_callback + (W, U : in Storage.Integer_Address); + pragma Import (C, fl_widget_default_callback, "fl_widget_default_callback"); + pragma Inline (fl_widget_default_callback); + function fl_widget_get_when (W : in Storage.Integer_Address) - return Interfaces.C.unsigned; + return Interfaces.C.unsigned_char; pragma Import (C, fl_widget_get_when, "fl_widget_get_when"); pragma Inline (fl_widget_get_when); procedure fl_widget_set_when (W : in Storage.Integer_Address; - T : in Interfaces.C.unsigned); + T : in Interfaces.C.unsigned_char); pragma Import (C, fl_widget_set_when, "fl_widget_set_when"); pragma Inline (fl_widget_set_when); + -- Dimensions -- + function fl_widget_get_x (W : in Storage.Integer_Address) return Interfaces.C.int; @@ -399,6 +446,12 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_size, "fl_widget_size"); pragma Inline (fl_widget_size); + procedure fl_widget_resize + (O : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_widget_resize, "fl_widget_resize"); + pragma Inline (fl_widget_resize); + procedure fl_widget_position (W : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -408,6 +461,8 @@ package body FLTK.Widgets is + -- Images -- + procedure fl_widget_set_image (W, I : in Storage.Integer_Address); pragma Import (C, fl_widget_set_image, "fl_widget_set_image"); @@ -421,31 +476,90 @@ package body FLTK.Widgets is + -- Damage, Drawing, Events -- + function fl_widget_damage (W : in Storage.Integer_Address) - return Interfaces.C.int; + return Interfaces.C.unsigned_char; pragma Import (C, fl_widget_damage, "fl_widget_damage"); pragma Inline (fl_widget_damage); procedure fl_widget_set_damage (W : in Storage.Integer_Address; - T : in Interfaces.C.int); + M : in Interfaces.C.unsigned_char); pragma Import (C, fl_widget_set_damage, "fl_widget_set_damage"); pragma Inline (fl_widget_set_damage); procedure fl_widget_set_damage2 - (W : in Storage.Integer_Address; - T : in Interfaces.C.int; + (W : in Storage.Integer_Address; + M : in Interfaces.C.unsigned_char; X, Y, D, H : in Interfaces.C.int); pragma Import (C, fl_widget_set_damage2, "fl_widget_set_damage2"); pragma Inline (fl_widget_set_damage2); + procedure fl_widget_clear_damage + (W : in Storage.Integer_Address; + M : in Interfaces.C.unsigned_char); + pragma Import (C, fl_widget_clear_damage, "fl_widget_clear_damage"); + pragma Inline (fl_widget_clear_damage); + + procedure fl_widget_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw, "fl_widget_draw"); + pragma Inline (fl_widget_draw); + procedure fl_widget_draw_label + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_label, "fl_widget_draw_label"); + pragma Inline (fl_widget_draw_label); + + procedure fl_widget_draw_label2 + (O : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_widget_draw_label2, "fl_widget_draw_label2"); + pragma Inline (fl_widget_draw_label2); + + procedure fl_widget_draw_label3 (W : in Storage.Integer_Address; X, Y, D, H : in Interfaces.C.int; A : in Interfaces.C.unsigned); - pragma Import (C, fl_widget_draw_label, "fl_widget_draw_label"); - pragma Inline (fl_widget_draw_label); + pragma Import (C, fl_widget_draw_label3, "fl_widget_draw_label3"); + pragma Inline (fl_widget_draw_label3); + + procedure fl_widget_draw_backdrop + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_backdrop, "fl_widget_draw_backdrop"); + pragma Inline (fl_widget_draw_backdrop); + + procedure fl_widget_draw_box + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_box, "fl_widget_draw_box"); + pragma Inline (fl_widget_draw_box); + + procedure fl_widget_draw_box2 + (W : in Storage.Integer_Address; + K : in Interfaces.C.int; + H : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_draw_box2, "fl_widget_draw_box2"); + pragma Inline (fl_widget_draw_box2); + + procedure fl_widget_draw_box3 + (O : in Storage.Integer_Address; + K, X, Y, W, H : in Interfaces.C.int; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_draw_box3, "fl_widget_draw_box3"); + pragma Inline (fl_widget_draw_box3); + + procedure fl_widget_draw_focus + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_focus, "fl_widget_draw_focus"); + pragma Inline (fl_widget_draw_focus); + + procedure fl_widget_draw_focus2 + (O : in Storage.Integer_Address; + K, X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_widget_draw_focus2, "fl_widget_draw_focus2"); + pragma Inline (fl_widget_draw_focus2); procedure fl_widget_redraw (W : in Storage.Integer_Address); @@ -457,14 +571,6 @@ package body FLTK.Widgets is pragma Import (C, fl_widget_redraw_label, "fl_widget_redraw_label"); pragma Inline (fl_widget_redraw_label); - - - - procedure fl_widget_draw - (W : in Storage.Integer_Address); - pragma Import (C, fl_widget_draw, "fl_widget_draw"); - pragma Inline (fl_widget_draw); - function fl_widget_handle (W : in Storage.Integer_Address; E : in Interfaces.C.int) @@ -475,6 +581,17 @@ package body FLTK.Widgets is + -- Miscellaneous -- + + function fl_widget_use_accents_menu + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_use_accents_menu, "fl_widget_use_accents_menu"); + pragma Inline (fl_widget_use_accents_menu); + + + + ---------------------- -- Exported Hooks -- ---------------------- @@ -482,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); @@ -492,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; @@ -504,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))); @@ -520,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; @@ -574,11 +694,11 @@ package body FLTK.Widgets is begin return This : Widget do This.Void_Ptr := new_fl_widget - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -604,6 +724,8 @@ package body FLTK.Widgets is -- API Subprograms -- ----------------------- + -- Activity -- + procedure Activate (This : in out Widget) is begin @@ -635,6 +757,13 @@ package body FLTK.Widgets is procedure Set_Active + (This : in out Widget) is + begin + fl_widget_set_active (This.Void_Ptr); + end Set_Active; + + + procedure Set_Active (This : in out Widget; To : in Boolean) is begin @@ -646,8 +775,17 @@ package body FLTK.Widgets is end Set_Active; + procedure Clear_Active + (This : in out Widget) is + begin + fl_widget_clear_active (This.Void_Ptr); + end Clear_Active; + + + -- Changed and Output -- + function Has_Changed (This : in Widget) return Boolean is @@ -657,6 +795,13 @@ package body FLTK.Widgets is procedure Set_Changed + (This : in out Widget) is + begin + fl_widget_set_changed (This.Void_Ptr); + end Set_Changed; + + + procedure Set_Changed (This : in out Widget; To : in Boolean) is begin @@ -668,6 +813,13 @@ package body FLTK.Widgets is end Set_Changed; + procedure Clear_Changed + (This : in out Widget) is + begin + fl_widget_clear_changed (This.Void_Ptr); + end Clear_Changed; + + function Is_Output_Only (This : in Widget) return Boolean is @@ -677,6 +829,13 @@ package body FLTK.Widgets is procedure Set_Output_Only + (This : in out Widget) is + begin + fl_widget_set_output (This.Void_Ptr); + end Set_Output_Only; + + + procedure Set_Output_Only (This : in out Widget; To : in Boolean) is begin @@ -688,6 +847,17 @@ package body FLTK.Widgets is end Set_Output_Only; + procedure Clear_Output_Only + (This : in out Widget) is + begin + fl_widget_clear_output (This.Void_Ptr); + end Clear_Output_Only; + + + + + -- Visibility -- + function Is_Visible (This : in Widget) return Boolean is @@ -705,6 +875,13 @@ package body FLTK.Widgets is procedure Set_Visible + (This : in out Widget) is + begin + fl_widget_set_visible (This.Void_Ptr); + end Set_Visible; + + + procedure Set_Visible (This : in out Widget; To : in Boolean) is begin @@ -716,7 +893,30 @@ package body FLTK.Widgets is end Set_Visible; + procedure Clear_Visible + (This : in out Widget) is + begin + fl_widget_clear_visible (This.Void_Ptr); + end Clear_Visible; + + + procedure Show + (This : in out Widget) is + begin + fl_widget_show (This.Void_Ptr); + end Show; + + + procedure Hide + (This : in out Widget) is + begin + fl_widget_hide (This.Void_Ptr); + end Hide; + + + + -- Focus -- function Has_Visible_Focus (This : in Widget) @@ -727,6 +927,13 @@ package body FLTK.Widgets is procedure Set_Visible_Focus + (This : in out Widget) is + begin + fl_widget_set_visible_focus2 (This.Void_Ptr); + end Set_Visible_Focus; + + + procedure Set_Visible_Focus (This : in out Widget; To : in Boolean) is begin @@ -734,6 +941,13 @@ package body FLTK.Widgets is end Set_Visible_Focus; + procedure Clear_Visible_Focus + (This : in out Widget) is + begin + fl_widget_clear_visible_focus (This.Void_Ptr); + end Clear_Visible_Focus; + + function Take_Focus (This : in out Widget) return Boolean is @@ -752,6 +966,8 @@ package body FLTK.Widgets is + -- Colors -- + function Get_Background_Color (This : in Widget) return Color is @@ -784,7 +1000,20 @@ package body FLTK.Widgets is end Set_Selection_Color; + procedure Set_Colors + (This : in out Widget; + Back, Sel : in Color) is + begin + fl_widget_set_colors + (This.Void_Ptr, + Interfaces.C.unsigned (Back), + Interfaces.C.unsigned (Sel)); + end Set_Colors; + + + + -- Relatives -- function Parent (This : in Widget) @@ -795,12 +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; end Parent; @@ -836,7 +1066,8 @@ package body FLTK.Widgets is end if; return Actual_Window; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Widget::window has no user_data reference back to Ada"; end Nearest_Window; @@ -854,13 +1085,14 @@ package body FLTK.Widgets is end if; return Actual_Window; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Widget::top_window has no user_data reference back to Ada"; end Top_Window; function Top_Window_Offset - (This : in Widget; - Offset_X, Offset_Y : out Integer) + (This : in Widget; + Offset_X, Offset_Y : out Integer) return access FLTK.Widgets.Groups.Windows.Window'Class is Window_Ptr : Storage.Integer_Address := fl_widget_top_window_offset @@ -876,12 +1108,15 @@ package body FLTK.Widgets is end if; return Actual_Window; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Widget::top_window_offset has no user_data reference back to Ada"; end Top_Window_Offset; + -- Alignment, Box, Tooltip -- + function Get_Alignment (This : in Widget) return Alignment is @@ -900,9 +1135,15 @@ package body FLTK.Widgets is function Get_Box (This : in Widget) - return Box_Kind is + return Box_Kind + is + Result : constant Interfaces.C.int := fl_widget_get_box (This.Void_Ptr); begin - return Box_Kind'Val (fl_widget_get_box (This.Void_Ptr)); + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Widget::box returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Get_Box; @@ -918,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 ""; @@ -939,11 +1180,13 @@ package body FLTK.Widgets is + -- Labels -- + function Get_Label (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 ""; @@ -961,6 +1204,16 @@ package body FLTK.Widgets is end Set_Label; + procedure Set_Label + (This : in out Widget; + Kind : in Label_Kind; + Text : in String) is + begin + This.Set_Label_Kind (Kind); + This.Set_Label (Text); + end Set_Label; + + function Get_Label_Color (This : in Widget) return Color is @@ -1013,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 @@ -1044,6 +1297,8 @@ package body FLTK.Widgets is + -- Callbacks -- + function Get_Callback (This : in Widget) return Widget_Callback is @@ -1072,11 +1327,30 @@ package body FLTK.Widgets is end Do_Callback; + procedure Do_Callback + (This : in Widget; + Using : in out Widget) is + begin + if This.Callback /= null then + This.Callback.all (Using); + end if; + end Do_Callback; + + + procedure Default_Callback + (This : in out Widget'Class) is + begin + fl_widget_default_callback + (This.Void_Ptr, + fl_widget_get_user_data (This.Void_Ptr)); + end Default_Callback; + + function Get_When (This : in Widget) return Callback_Flag is begin - return Callback_Flag (fl_widget_get_when (This.Void_Ptr)); + return UChar_To_Flag (fl_widget_get_when (This.Void_Ptr)); end Get_When; @@ -1084,12 +1358,14 @@ package body FLTK.Widgets is (This : in out Widget; To : in Callback_Flag) is begin - fl_widget_set_when (This.Void_Ptr, Interfaces.C.unsigned (To)); + fl_widget_set_when (This.Void_Ptr, Flag_To_UChar (To)); end Set_When; + -- Dimensions -- + function Get_X (This : in Widget) return Integer is @@ -1127,9 +1403,22 @@ package body FLTK.Widgets is W, H : in Integer) is begin fl_widget_size - (This.Void_Ptr, - Interfaces.C.int (W), - Interfaces.C.int (H)); + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Resize + (This : in out Widget; + X, Y, W, H : in Integer) is + begin + fl_widget_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); end Resize; @@ -1138,14 +1427,16 @@ package body FLTK.Widgets is X, Y : in Integer) is begin fl_widget_position - (This.Void_Ptr, - Interfaces.C.int (X), - Interfaces.C.int (Y)); + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); end Reposition; + -- Images -- + function Get_Image (This : in Widget) return access FLTK.Images.Image'Class is @@ -1186,6 +1477,8 @@ package body FLTK.Widgets is + -- Damage, Drawing, Events -- + function Is_Damaged (This : in Widget) return Boolean is @@ -1194,27 +1487,43 @@ package body FLTK.Widgets is end Is_Damaged; - procedure Set_Damaged + function Get_Damage + (This : in Widget) + return Damage_Mask is + begin + return UChar_To_Mask (fl_widget_damage (This.Void_Ptr)); + end Get_Damage; + + + procedure Set_Damage (This : in out Widget; - To : in Boolean) is + Mask : in Damage_Mask) is begin - fl_widget_set_damage (This.Void_Ptr, Boolean'Pos (To)); - end Set_Damaged; + fl_widget_set_damage (This.Void_Ptr, Mask_To_UChar (Mask)); + end Set_Damage; - procedure Set_Damaged + procedure Set_Damage (This : in out Widget; - To : in Boolean; + Mask : in Damage_Mask; X, Y, W, H : in Integer) is begin fl_widget_set_damage2 (This.Void_Ptr, - Boolean'Pos (To), + Mask_To_UChar (Mask), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H)); - end Set_Damaged; + end Set_Damage; + + + procedure Clear_Damage + (This : in out Widget; + Mask : in Damage_Mask := Damage_None) is + begin + fl_widget_clear_damage (This.Void_Ptr, Mask_To_UChar (Mask)); + end Clear_Damage; procedure Draw @@ -1230,11 +1539,31 @@ package body FLTK.Widgets is procedure Draw_Label - (This : in Widget; - X, Y, W, H : in Integer; - Align : in Alignment) is + (This : in out Widget) is + begin + fl_widget_draw_label (This.Void_Ptr); + end Draw_Label; + + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer) is + begin + fl_widget_draw_label2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Label; + + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer; + Align : in Alignment) is begin - fl_widget_draw_label + fl_widget_draw_label3 (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y), @@ -1244,6 +1573,71 @@ package body FLTK.Widgets is end Draw_Label; + procedure Draw_Backdrop + (This : in out Widget) is + begin + fl_widget_draw_backdrop (This.Void_Ptr); + end Draw_Backdrop; + + + procedure Draw_Box + (This : in out Widget) is + begin + fl_widget_draw_box (This.Void_Ptr); + end Draw_Box; + + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + Hue : in Color) is + begin + fl_widget_draw_box2 + (This.Void_Ptr, + Box_Kind'Pos (Kind), + Interfaces.C.unsigned (Hue)); + end Draw_Box; + + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Hue : in Color) is + begin + fl_widget_draw_box3 + (This.Void_Ptr, + Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Hue)); + end Draw_Box; + + + procedure Draw_Focus + (This : in out Widget) is + begin + fl_widget_draw_focus (This.Void_Ptr); + end Draw_Focus; + + + procedure Draw_Focus + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer) is + begin + fl_widget_draw_focus2 + (This.Void_Ptr, + Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Focus; + + procedure Redraw (This : in out Widget) is begin @@ -1269,12 +1663,29 @@ package body FLTK.Widgets is return Interfaces.C.int; for my_handle'Address use This.Handle_Ptr; pragma Import (Ada, my_handle); + + Result : constant Interfaces.C.int := my_handle (This.Void_Ptr, Event_Kind'Pos (Event)); begin - return Event_Outcome'Val (my_handle (This.Void_Ptr, Event_Kind'Pos (Event))); + return Event_Outcome'Val (Result); exception - when Constraint_Error => raise Internal_FLTK_Error; + when Constraint_Error => raise Internal_FLTK_Error with + "Dispatched handle function returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Handle; + + + -- Miscellaneous -- + + function Uses_Accents_Menu + (This : in Widget) + return Boolean is + begin + return fl_widget_use_accents_menu (This.Void_Ptr) /= 0; + end Uses_Accents_Menu; + + end FLTK.Widgets; + diff --git a/body/fltk.adb b/body/fltk.adb index d729364..49d9048 100644 --- a/body/fltk.adb +++ b/body/fltk.adb @@ -11,20 +11,149 @@ 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 (V : in Interfaces.C.int) @@ -50,18 +179,7 @@ package body FLTK is - 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 return Interfaces.C.int; @@ -80,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); @@ -92,6 +210,12 @@ package body FLTK is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Implementation Details -- + function Is_Valid (Object : in Wrapper) return Boolean is @@ -100,13 +224,28 @@ package body FLTK is end Is_Valid; - procedure Initialize - (This : in out Wrapper) is + + + -- Color -- + + function RGB_Color + (Light : in Greyscale) + return Color is begin - This.Void_Ptr := Null_Pointer; - end Initialize; + 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 @@ -120,7 +259,83 @@ 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 + begin + return Color (fl_enum_contrast + (Interfaces.C.unsigned (Fore), + Interfaces.C.unsigned (Back))); + 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 -- function "+" (Left, Right : in Alignment) @@ -134,12 +349,14 @@ package body FLTK is (Left, Right : in Alignment) return Alignment is begin - return Left and (not Right); + return Left and not Right; end "-"; + -- Keyboard and Mouse Input -- + function Press (Key : in Pressable_Key) return Keypress is @@ -250,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 @@ -270,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); @@ -286,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); @@ -302,42 +519,181 @@ 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 -- + function ABI_Check (ABI_Ver : in Version_Number) return Boolean is @@ -369,20 +725,14 @@ package body FLTK is - 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; function Check @@ -408,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; @@ -423,3 +773,4 @@ package body FLTK is end FLTK; + diff --git a/doc/enumerations.html b/doc/enumerations.html new file mode 100644 index 0000000..6e4f521 --- /dev/null +++ b/doc/enumerations.html @@ -0,0 +1,302 @@ +<!DOCTYPE html> + +<html lang="en"> + <head> + <meta charset="utf-8"> + <title>Enumerations Binding Map</title> + <link href="map.css" rel="stylesheet"> + </head> + + <body> + + +<h2>Enumerations Binding Map</h2> + + +<a href="index.html">Back to Index</a> + + +<table class="package"> + <tr><th colspan="2">Package name</th></tr> + + <tr> + <td>Enumerations</td> + <td>FLTK</td> + </tr> + + <tr> + <td>fl_types</td> + <td> </td> + </tr> + +</table> + + + +<table class="type"> + <tr><th colspan="2">Types</th></tr> + + <tr> + <td>Fl_Color</td> + <td>Greyscale</td> + </tr> + + <tr> + <td>Fl_Color</td> + <td>Color</td> + </tr> + + <tr> + <td>unsigned char</td> + <td>Color_Component</td> + </tr> + + <tr> + <td>unsigned char *</td> + <td>Color_Component_Array</td> + </tr> + + <tr> + <td>float</td> + <td>Blend</td> + </tr> + + <tr> + <td>Fl_Align</td> + <td>Alignment</td> + </tr> + + <tr> + <td>Fl_Cursor</td> + <td>Mouse_Cursor_Kind</td> + </tr> + + <tr> + <td>short</td> + <td>Keypress</td> + </tr> + + <tr> + <td> + #define FL_BUTTON1 0x01000000<br /> + #define FL_BUTTON2 0x02000000<br /> + #define FL_BUTTON3 0x04000000<br /> + #define FL_BUTTONS 0x7f000000 + </td> + <td>Mouse_Button</td> + </tr> + + <tr> + <td>short</td> + <td>Modifier</td> + </tr> + + <tr> + <td>Fl_Shortcut</td> + <td>Key_Combo</td> + </tr> + + <tr> + <td>Fl_Boxtype</td> + <td>Box_Kind</td> + </tr> + + <tr> + <td>Fl_Font</td> + <td>Font_Kind</td> + </tr> + + <tr> + <td>Fl_Fontsize</td> + <td>Font_Size</td> + </tr> + + <tr> + <td>Fl_Fontsize *</td> + <td>Font_Size_Array</td> + </tr> + + <tr> + <td>Fl_Labeltype</td> + <td>Label_Kind</td> + </tr> + + <tr> + <td>Fl_Event</td> + <td>Event_Kind</td> + </tr> + + <tr> + <td>int</td> + <td>Event_Outcome</td> + </tr> + + <tr> + <td>Fl_When</td> + <td>Callback_Flag</td> + </tr> + + <tr> + <td>Fl_Damage</td> + <td>Damage_Mask</td> + </tr> + + <tr> + <td>int</td> + <td>Version_Number</td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Static Functions and Procedures</th></tr> + + <tr> +<td><pre> +inline Fl_Boxtype fl_box(Fl_Boxtype b); +</pre></td> +<td><pre> +function Filled + (Box : in Box_Kind) + return Box_Kind; +</pre></td> + </tr> + + <tr> +<td><pre> +Fl_Color fl_color_average(Fl_Color c1, Fl_Color c2, float weight); +</pre></td> +<td><pre> +function Color_Average + (Tone1, Tone2 : in Color; + Weight : in Blend := 0.5) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +inline Fl_Color fl_color_cube(int r, int g, int b); +</pre></td> +<td><pre> +function Color_Cube + (R, G, B : in Color_Component) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +Fl_Color fl_contrast(Fl_Color fg, Fl_Color bg); +</pre></td> +<td><pre> +function Contrast + (Fore, Back : in Color) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +inline Fl_Color fl_darker(Fl_Color c); +</pre></td> +<td><pre> +function Darker + (Tone : in Color) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +inline Fl_Boxtype fl_down(Fl_Boxtype b); +</pre></td> +<td><pre> +function Down + (Box : in Box_Kind) + return Box_Kind; +</pre></td> + </tr> + + <tr> +<td><pre> +inline Fl_Boxtype fl_frame(Fl_Boxtype b); +</pre></td> +<td><pre> +function Frame + (Box : in Box_Kind) + return Box_Kind; +</pre></td> + </tr> + + <tr> +<td><pre> +inline Fl_Color fl_gray_ramp(int i); +</pre></td> +<td><pre> +function Grey_Ramp + (Light : in Greyscale) + return Color; + +function Grey_Ramp + (Light : in Color_Component) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +Fl_Color fl_inactive(Fl_Color c); +</pre></td> +<td><pre> +function Inactive + (Tone : in Color) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +inline Fl_Color fl_lighter(Fl_Color c); +</pre></td> +<td><pre> +function Lighter + (Tone : in Color) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +inline Fl_Color fl_rgb_color(uchar g); +</pre></td> +<td><pre> +function RGB_Color + (Light : in Greyscale) + return Color; + +function RGB_Color + (Light : in Color_Component) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +inline Fl_Color fl_rgb_color(uchar r, uchar g, uchar b); +</pre></td> +<td><pre> +function RGB_Color + (R, G, B : in Color_Component) + return Color; +</pre></td> + </tr> + +</table> + + + </body> +</html> + diff --git a/doc/fl.html b/doc/fl.html index db60f5b..96bb11d 100644 --- a/doc/fl.html +++ b/doc/fl.html @@ -24,31 +24,6 @@ <td>FLTK</td> </tr> - <tr> - <td> </td> - <td>FLTK.Errors</td> - </tr> - - <tr> - <td> </td> - <td>FLTK.Event</td> - </tr> - - <tr> - <td> </td> - <td>FLTK.Screen</td> - </tr> - - <tr> - <td> </td> - <td>FLTK.Static</td> - </tr> - - <tr> - <td>Enumerations</td> - <td> </td> - </tr> - </table> @@ -57,183 +32,33 @@ <tr><th colspan="2">Types</th></tr> <tr> - <td>Fl_Option</td> - <td>Option</td> - </tr> - - <tr> - <td>Fl_Color</td> - <td>Color</td> - </tr> - - <tr> - <td>Fl_Align</td> - <td>Alignment</td> - </tr> - - <tr> - <td> </td> - <td>Keypress</td> - </tr> - - <tr> - <td> </td> - <td>Mouse_Button</td> - </tr> - - <tr> - <td> </td> - <td>Modifier</td> - </tr> - - <tr> - <td>Fl_Shortcut</td> - <td>Key_Combo</td> + <td>void *</td> + <td>Wrapper</td> </tr> <tr> - <td>Fl_Boxtype</td> - <td>Box_Kind</td> - </tr> - - <tr> - <td>Fl_Font</td> - <td>Font_Kind</td> - </tr> - - <tr> - <td>Fl_Fontsize</td> - <td>Font_Size</td> - </tr> - - <tr> - <td> </td> - <td>Font_Size_Array</td> - </tr> - - <tr> - <td>Fl_Labeltype</td> - <td>Label_Kind</td> - </tr> - - <tr> - <td> </td> - <td>Event_Kind</td> - </tr> - - <tr> - <td> </td> - <td>Event_Outcome</td> - </tr> - - <tr> - <td> </td> + <td>enum {<br /> + FL_MENU_INACTIVE = 1,<br /> + FL_MENU_TOGGLE = 2,<br /> + FL_MENU_VALUE = 4,<br /> + FL_MENU_RADIO = 8,<br /> + FL_MENU_INVISIBLE = 0x10,<br /> + FL_SUBMENU_POINTER = 0x20,<br /> + FL_SUBMENU = 0x40,<br /> + FL_MENU_DIVIDER = 0x80,<br /> + FL_MENU_HORIZONTAL = 0x100 }<br /> + </td> <td>Menu_Flag</td> </tr> <tr> - <td> </td> - <td>Version_Number</td> - </tr> - - <tr> - <td>Fl_Event_Handler</td> - <td>Event_Handler</td> - </tr> - - <tr> - <td>Fl_Event_Dispatch</td> - <td>TBA</td> - </tr> - - <tr> - <td>Fl_Awake_Handler</td> - <td>Awake_Handler</td> + <td>size_t</td> + <td>Size_Type</td> </tr> <tr> - <td>Fl_Timeout_Handler</td> - <td>Timeout_Handler</td> - </tr> - - <tr> - <td>Fl_Idle_Handler</td> - <td>Idle_Handler</td> - </tr> - - <tr> - <td> </td> - <td>Buffer_Kind</td> - </tr> - - <tr> - <td>Fl_Clipboard_Notify_Handler</td> - <td>Clipboard_Notify_Handler</td> - </tr> - - <tr> - <td>FL_SOCKET</td> - <td>File_Descriptor</td> - </tr> - - <tr> - <td> </td> - <td>File_Mode</td> - </tr> - - <tr> - <td>Fl_FD_Handler</td> - <td>File_Handler</td> - </tr> - - <tr> - <td>Fl_Box_Draw_F</td> - <td>Box_Draw_Function</td> - </tr> - - <tr> - <td>Fl_Abort_Handler</td> - <td> </td> - </tr> - - <tr> - <td>Fl_Args_Handler</td> - <td> </td> - </tr> - - <tr> - <td>Fl_Atclose_Handler</td> - <td> </td> - </tr> - - <tr> - <td>Fl_Label_Draw_F</td> - <td> </td> - </tr> - - <tr> - <td>Fl_Label_Measure_F</td> - <td> </td> - </tr> - - <tr> - <td>Fl_Old_Idle_Handler</td> - <td> </td> - </tr> - - <tr> - <td>Fl_System_Handler</td> - <td> </td> - </tr> - - <tr> - <td>Fl_Cursor</td> - <td>Mouse_Cursor</td> - </tr> - - <tr> - <td> </td> - <td>Error_Function</td> + <td>size_t</td> + <td>Positive_Size</td> </tr> </table> @@ -253,77 +78,24 @@ <table class="function"> - <tr><th colspan="2">Attributes</th></tr> - - <tr> -<td><pre> -static void (*atclose)(Fl_Window *, void *); -</pre></td> -<td>Deprecated, set the callback for the Window instead</td> - </tr> + <tr><th colspan="2">Static Attributes</th></tr> <tr> <td><pre> static char const * const clipboard_image = "image"; </pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static char const * const clipboard_plain_text = "text/plain"; -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void (*error)(const char *, ...) = ::error; -</pre></td> -<td><pre> -procedure Default_Error - (Message : in String); - -Current_Error : Error_Function := Default_Error'Access; -</pre>(In FLTK.Errors)</td> - </tr> - - <tr> -<td><pre> -static void (*fatal)(const char *, ...) = ::fatal; -</pre></td> -<td><pre> -procedure Default_Fatal - (Message : in String); - -Current_Fatal : Error_Function := Default_Fatal'Access; -</pre>(In FLTK.Errors)</td> - </tr> - - <tr> <td><pre> -static const char * const help = helpmsg + 13; +Clipboard_Image : constant String; </pre></td> -<td> </td> </tr> <tr> <td><pre> -static void (*idle)(); +static char const * const clipboard_plain_text = "text/plain"; </pre></td> -<td>Should not be used directly</td> - </tr> - - <tr> <td><pre> -static void (*warning)(const char *, ...) = ::warning; +Clipboard_Plain_Text : constant String; </pre></td> -<td><pre> -procedure Default_Warning - (Message : in String); - -Current_Warning : Error_Function := Default_Warning'Access; -</pre>(In FLTK.Errors)</td> </tr> </table> @@ -331,7 +103,7 @@ Current_Warning : Error_Function := Default_Warning'Access; <table class="function"> - <tr><th colspan="2">Functions and Procedures</th></tr> + <tr><th colspan="2">Static Functions and Procedures</th></tr> <tr> <td><pre> @@ -356,97 +128,6 @@ function ABI_Version <tr> <td><pre> -static int add_awake_handler_(Fl_Awake_Handler, void *); -</pre></td> -<td><pre> -procedure Add_Awake_Handler - (Func : in Awake_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void add_check(Fl_Timeout_Handler, void *=0); -</pre></td> -<td><pre> -procedure Add_Check - (Func : in Timeout_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void add_clipboard_notify(Fl_Clipboard_Notify_Handler h, void *data=0); -</pre></td> -<td><pre> -procedure Add_Clipboard_Notify - (Func : in Clipboard_Notify_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void add_fd(int fd, int when, Fl_FD_Handler cb, void *=0); -</pre></td> -<td><pre> -procedure Add_File_Descriptor - (FD : in File_Descriptor; - Mode : in File_Mode; - Func : in File_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void add_fd(int fd, Fl_FD_Handler cb, void *=0); -</pre></td> -<td><pre> -procedure Add_File_Descriptor - (FD : in File_Descriptor; - Func : in File_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void add_handler(Fl_Event_Handler h); -</pre></td> -<td><pre> -procedure Add_Handler - (Func : in Event_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void add_idle(Fl_Idle_Handler cb, void *data=0); -</pre></td> -<td><pre> -procedure Add_Idle - (Func : in Idle_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void add_system_handler(Fl_System_Handler h, void *data); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void add_timeout(double t, Fl_Timeout_Handler, void *=0); -</pre></td> -<td><pre> -procedure Add_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> static int api_version(); </pre></td> <td><pre> @@ -457,134 +138,6 @@ function API_Version <tr> <td><pre> -static int arg(int argc, char **argv, int &i); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int args(int argc, char **argv, int &i, Fl_Args_Handler cb=0); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void args(int argc, char **argv); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void awake(void *message=0); -</pre></td> -<td><pre> -procedure Awake; -</pre></td> - </tr> - - <tr> -<td><pre> -static int awake(Fl_Awake_Handler cb, void *message=0); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void background(uchar, uchar, uchar); -</pre></td> -<td><pre> -procedure Set_Background - (R, G, B : in Color_Component); -</pre></td> - </tr> - - <tr> -<td><pre> -static void background2(uchar, uchar, uchar); -</pre></td> -<td><pre> -procedure Set_Alt_Background - (R, G, B : in Color_Component); -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Widget * belowmouse(); -</pre></td> -<td><pre> -function Get_Below_Mouse - return access FLTK.Widgets.Widget'Class; -</pre></td> - </tr> - - <tr> -<td><pre> -static void belowmouse(Fl_Widget *); -</pre></td> -<td><pre> -procedure Set_Below_Mouse - (To : in FLTK.Widgets.Widget'Class); -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Color box_color(Fl_Color); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int box_dh(Fl_Boxtype); -</pre></td> -<td><pre> -function Get_Box_Height_Offset - (Kind : in Box_Kind) - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int box_dw(Fl_Boxtype); -</pre></td> -<td><pre> -function Get_Box_Width_Offset - (Kind : in Box_Kind) - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int box_dx(Fl_Boxtype); -</pre></td> -<td><pre> -function Get_Box_X_Offset - (Kind : in Box_Kind) - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int box_dy(Fl_Boxtype); -</pre></td> -<td><pre> -function Get_Box_Y_Offset - (Kind : in Box_Kind) - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> static void cairo_autolink_context(bool alink); </pre></td> <td> </td> @@ -623,6 +176,8 @@ static cairo_t * cairo_make_current(Fl_Window *w); static int check(); </pre></td> <td><pre> +procedure Check; + function Check return Boolean; </pre></td> @@ -632,637 +187,21 @@ function Check <td><pre> static void clear_widget_pointer(Fl_Widget const *w); </pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int clipboard_contains(const char *type); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int compose(int &del); -</pre></td> -<td><pre> -function Compose - (Del : out Natural) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static void compose_reset(); -</pre></td> -<td><pre> -procedure Compose_Reset; -</pre></td> - </tr> - - <tr> -<td><pre> -static void copy - (const char *stuff, int len, int destination=0, - const char *type=Fl::clipboard_plain_text); -</pre></td> -<td><pre> -procedure Copy - (Text : in String; - Dest : in Buffer_Kind); -</pre></td> - </tr> - - <tr> -<td><pre> -static void damage(int d); -</pre></td> -<td><pre> -procedure Set_Damaged - (To : in Boolean); -</pre></td> - </tr> - - <tr> -<td><pre> -static int damage(); -</pre></td> -<td><pre> -function Is_Damaged - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static void default_atclose(Fl_Window *, void *); -</pre></td> -<td><pre> -procedure Default_Window_Close - (Item : in out FLTK.Widgets.Widget'Class); -</pre></td> +<td>Marked as internal use only.</td> </tr> <tr> <td><pre> static void delete_widget(Fl_Widget *w); </pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void disable_im(); -</pre></td> -<td><pre> -procedure Disable_System_Input; -</pre></td> - </tr> - - <tr> -<td><pre> -static void display(const char *); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int dnd(); -</pre></td> -<td><pre> -procedure Drag_Drop_Start; -</pre></td> - </tr> - - <tr> -<td><pre> -static void dnd_text_ops(int v); -</pre></td> -<td><pre> -procedure Set_Drag_Drop_Text_Support - (To : in Boolean); -</pre></td> - </tr> - - <tr> -<td><pre> -static int dnd_text_ops(); -</pre></td> -<td><pre> -function Get_Drag_Drop_Text_Support - return Boolean; -</pre></td> +<td>Used automatically as appropriate by the binding.</td> </tr> <tr> <td><pre> static void do_widget_deletion(); </pre></td> -<td><pre> -procedure Do_Widget_Deletion; -</pre></td> - </tr> - - <tr> -<td><pre> -static int draw_box_active(); -</pre></td> -<td><pre> -function Draw_Box_Active - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static void enable_im(); -</pre></td> -<td><pre> -procedure Enable_System_Input; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event(); -</pre></td> -<td><pre> -function Last - return Event_Kind; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_alt(); -</pre></td> -<td><pre> -function Key_Alt - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_button(); -</pre></td> -<td><pre> -function Last_Button - return Mouse_Button; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_button1(); -</pre></td> -<td><pre> -function Mouse_Left - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_button2(); -</pre></td> -<td><pre> -function Mouse_Middle - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_button3(); -</pre></td> -<td><pre> -function Mouse_Right - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_buttons(); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int event_clicks(); -</pre></td> -<td><pre> -function Is_Multi_Click - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static void event_clicks(int i); -</pre></td> -<td><pre> -procedure Set_Clicks - (To : in Natural); -</pre></td> - </tr> - - <tr> -<td><pre> -static void * event_clipboard(); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static const char * event_clipboard_type(); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int event_command(); -</pre></td> -<td><pre> -function Key_Command - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_ctrl(); -</pre></td> -<td><pre> -function Key_Ctrl - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static void event_dispatch(Fl_Event_Dispatch d); -</pre></td> -<td>TBA</td> - </tr> - - <tr> -<td><pre> -static Fl_Event_Dispatch event_dispatch(); -</pre></td> -<td>TBA</td> - </tr> - - <tr> -<td><pre> -static int event_dx(); -</pre></td> -<td><pre> -function Mouse_DX - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_dy(); -</pre></td> -<td><pre> -function Mouse_DY - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_inside(int, int, int, int); -</pre></td> -<td><pre> -function Is_Inside - (X, Y, W, H : in Integer) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_inside(const Fl_Widget *); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int event_is_click(); -</pre></td> -<td><pre> -function Is_Click - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static void event_is_click(int i); -</pre></td> -<td>See static void event_clicks(int i);</td> - </tr> - - <tr> -<td><pre> -static int event_key(); -</pre></td> -<td><pre> -function Last_Key - return Keypress; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_key(int key); -</pre></td> -<td><pre> -function Pressed_During - (Key : in Keypress) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_length(); -</pre></td> -<td><pre> -function Text_Length - return Natural; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_original_key(); -</pre></td> -<td><pre> -function Original_Last_Key - return Keypress; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_shift(); -</pre></td> -<td><pre> -function Key_Shift - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_state(); -</pre></td> -<td><pre> -function Last_Modifier - return Modifier; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_state(int mask); -</pre></td> -<td><pre> -function Last_Modifier - (Had : in Modifier) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static const char * event_text(); -</pre></td> -<td><pre> -function Text - return String; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_x(); -</pre></td> -<td><pre> -function Mouse_X - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_x_root(); -</pre></td> -<td><pre> -function Mouse_X_Root - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_y(); -</pre></td> -<td><pre> -function Mouse_Y - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int event_y_root(); -</pre></td> -<td><pre> -function Mouse_Y_Root - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Window * first_window(); -</pre></td> -<td><pre> -function Get_First_Window - return access FLTK.Widgets.Groups.Windows.Window'Class; -</pre></td> - </tr> - - <tr> -<td><pre> -static void first_window(Fl_Window *); -</pre></td> -<td><pre> -procedure Set_First_Window - (To : in FLTK.Widgets.Groups.Windows.Window'Class); -</pre></td> - </tr> - - <tr> -<td><pre> -static void flush(); -</pre></td> -<td><pre> -procedure Flush; -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Widget * focus(); -</pre></td> -<td><pre> -function Get_Focus - return access FLTK.Widgets.Widget'Class; -</pre></td> - </tr> - - <tr> -<td><pre> -static void focus(Fl_Widget *); -</pre></td> -<td><pre> -procedure Set_Focus - (To : in FLTK.Widgets.Widget'Class); -</pre></td> - </tr> - - <tr> -<td><pre> -static void foreground(uchar, uchar, uchar); -</pre></td> -<td><pre> -procedure Set_Foreground - (R, G, B : in Color_Component); -</pre></td> - </tr> - - <tr> -<td><pre> -static void free_color(Fl_Color i, int overlay=0); -</pre></td> -<td><pre> -procedure Free_Color - (Value : in Color; - Overlay : in Boolean := False); -</pre></td> - </tr> - - <tr> -<td><pre> -static int get_awake_handler_(Fl_Awake_Handler &, void *&); -</pre></td> -<td><pre> -function Get_Awake_Handler - return Awake_Handler; -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Box_Draw_F * get_boxtype(Fl_Boxtype); -</pre></td> -<td>TBA</td> - </tr> - - <tr> -<td><pre> -static unsigned get_color(Fl_Color i); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void get_color(Fl_Color i, uchar &red, uchar &green, uchar &blue); -</pre></td> -<td><pre> -procedure Get_Color - (From : in Color; - R, G, B : out Color_Component); -</pre></td> - </tr> - - <tr> -<td><pre> -static const char * get_font(Fl_Font); -</pre></td> -<td><pre> -function Font_Image - (Kind : in Font_Kind) - return String; -</pre></td> - </tr> - - <tr> -<td><pre> -static const char * get_font_name(Fl_Font, int *attributes=0); -</pre></td> -<td><pre> -function Font_Family_Image - (Kind : in Font_Kind) - return String; -</pre></td> - </tr> - - <tr> -<td><pre> -static int get_font_sizes(Fl_Font, int *&sizep); -</pre></td> -<td><pre> -function Font_Sizes - (Kind : in Font_Kind) - return Font_Size_Array; -</pre></td> - </tr> - - <tr> -<td><pre> -static int get_key(int key); -</pre></td> -<td><pre> -function Key_Now - (Key : in Keypress) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static void get_mouse(int &, int &); -</pre></td> -<td><pre> -procedure Get_Mouse - (X, Y : out Integer); -</pre></td> - </tr> - - <tr> -<td><pre> -static void get_system_colors(); -</pre></td> -<td><pre> -procedure System_Colors; -</pre></td> +<td>Marked as internal use only.</td> </tr> <tr> @@ -1274,200 +213,6 @@ static int gl_visual(int, int *alist=0); <tr> <td><pre> -static Fl_Window * grab(); -</pre></td> -<td><pre> -function Get_Grab - return access FLTK.Widgets.Groups.Windows.Window'Class; -</pre></td> - </tr> - - <tr> -<td><pre> -static void grab(Fl_Window *); -static void grab(Fl_Window &win); -</pre></td> -<td><pre> -procedure Set_Grab - (To : in FLTK.Widgets.Groups.Windows.Window'Class); -</pre></td> - </tr> - - <tr> -<td><pre> -static int h(); -</pre></td> -<td><pre> -function Get_H - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int handle(int, Fl_Window *); -static int handle_(int, Fl_Window *); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int has_check(Fl_Timeout_Handler, void *=0); -</pre></td> -<td><pre> -function Has_Check - (Func : in Timeout_Handler) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int has_idle(Fl_Idle_Handler cb, void *data=0); -</pre></td> -<td><pre> -function Has_Idle - (Func : in Idle_Handler) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int has_timeout(Fl_Timeout_Handler, void *=0); -</pre></td> -<td><pre> -function Has_Timeout - (Func : in Timeout_Handler) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int is_scheme(const char *name); -</pre></td> -<td><pre> -function Is_Scheme - (Scheme : in String) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int lock(); -</pre></td> -<td><pre> -procedure Lock; -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Window * modal(); -</pre></td> -<td><pre> -function Get_Top_Modal - return access FLTK.Widgets.Groups.Windows.Window'Class; -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Window * next_window(const Fl_Window *); -</pre></td> -<td><pre> -function Get_Next_Window - (From : in FLTK.Widgets.Groups.Windows.Window'Class) - return access FLTK.Widgets.Groups.Windows.Window'Class; -</pre></td> - </tr> - - <tr> -<td><pre> -static bool option(Fl_Option opt); -</pre></td> -<td><pre> -function Get_Option - (Opt : in Option) - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static void option(Fl_Option opt, bool val); -</pre></td> -<td><pre> -procedure Set_Option - (Opt : in Option; - To : in Boolean); -</pre></td> - </tr> - - <tr> -<td><pre> -static void own_colormap(); -</pre></td> -<td><pre> -procedure Own_Colormap; -</pre></td> - </tr> - - <tr> -<td><pre> -static void paste - (Fl_Widget &receiver, int source, - const char *type=Fl::clipboard_plain_text); -</pre></td> -<td><pre> -procedure Paste - (Receiver : in FLTK.Widgets.Widget'Class; - Source : in Buffer_Kind); -</pre></td> - </tr> - - <tr> -<td><pre> -static void paste(Fl_Widget &receiver); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static Fl_Widget * pushed(); -</pre></td> -<td><pre> -function Get_Pushed - return access FLTK.Widgets.Widget'Class; -</pre></td> - </tr> - - <tr> -<td><pre> -static void pushed(Fl_Widget *); -</pre></td> -<td><pre> -procedure Set_Pushed - (To : in FLTK.Widgets.Widget'Class); -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Widget * readqueue(); -</pre></td> -<td><pre> -function Read_Queue - return access FLTK.Widgets.Widget'Class; -</pre></td> - </tr> - - <tr> -<td><pre> static int ready(); </pre></td> <td><pre> @@ -1478,125 +223,9 @@ function Ready <tr> <td><pre> -static void redraw(); -</pre></td> -<td><pre> -procedure Redraw; -</pre></td> - </tr> - - <tr> -<td><pre> -static void release(); -</pre></td> -<td><pre> -procedure Release_Grab; -</pre></td> - </tr> - - <tr> -<td><pre> static void release_widget_pointer(Fl_Widget *&w); </pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int reload_scheme(); -</pre></td> -<td><pre> -procedure Reload_Scheme; -</pre></td> - </tr> - - <tr> -<td><pre> -static void remove_check(Fl_Timeout_Handler, void *=0); -</pre></td> -<td><pre> -procedure Remove_Check - (Func : in Timeout_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void remove_clipboard_notify(Fl_Clipboard_Notify_Handler h); -</pre></td> -<td><pre> -procedure Remove_Clipboard_Notify - (Func : in Clipboard_Notify_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void remove_fd(int, int when); -</pre></td> -<td><pre> -procedure Remove_File_Descriptor - (FD : in File_Descriptor; - Mode : in File_Mode); -</pre></td> - </tr> - - <tr> -<td><pre> -static void remove_fd(int); -</pre></td> -<td><pre> -procedure Remove_File_Descriptor - (FD : in File_Descriptor); -</pre></td> - </tr> - - <tr> -<td><pre> -static void remove_handler(Fl_Event_Handler h); -</pre></td> -<td><pre> -procedure Remove_Handler - (Func : in Event_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void remove_idle(Fl_Idle_Handler cb, void *data=0); -</pre></td> -<td><pre> -procedure Remove_Idle - (Func : in Idle_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static void remove_system_handler(Fl_System_Handler h); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void remove_timeout(Fl_Timeout_Handler, void *=0); -</pre></td> -<td><pre> -procedure Remove_Timeout - (Func : in Timeout_Handler); -</pre></td> - </tr> - - <tr> -<td><pre> -static repeat_timeout(double t, Fl_Timeout_Handler, void *=0); -</pre></td> -<td><pre> -procedure Repeat_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler); -</pre></td> +<td>Marked as internal use only.</td> </tr> <tr> @@ -1611,326 +240,25 @@ function Run <tr> <td><pre> -static int scheme(const char *name); -</pre></td> -<td><pre> -procedure Set_Scheme - (To : in String); -</pre></td> - </tr> - - <tr> -<td><pre> -static const char * scheme(); -</pre></td> -<td><pre> -function Get_Scheme - return String; -</pre></td> - </tr> - - <tr> -<td><pre> -static int screen_count(); -</pre></td> -<td><pre> -function Count - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static void screen_dpi(float &h, float &v, int n=0); -</pre></td> -<td><pre> -procedure DPI - (Horizontal, Vertical : out Float; - Screen_Number : in Integer := 1); -</pre></td> - </tr> - - <tr> -<td><pre> -static int screen_num(int x, int y); -</pre></td> -<td><pre> -function Containing - (X, Y : in Integer) - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int screen_num(int x, int y, int w, int h); -</pre></td> -<td><pre> -function Containing - (X, Y, W, H : in Integer) - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static void screen_work_area(int &X, int &Y, int &W, int &H, int mx, int my); -</pre></td> -<td><pre> -procedure Work_Area - (X, Y, W, H : out Integer; - Pos_X, Pos_Y : in Integer); -</pre></td> - </tr> - - <tr> -<td><pre> -static void screen_work_area(int &X, int &Y, int &W, int &H, int n); -</pre></td> -<td><pre> -procedure Work_Area - (X, Y, W, H : out Integer; - Screen_Num : in Integer); -</pre></td> - </tr> - - <tr> -<td><pre> -static void screen_work_area(int &X, int &Y, int &W, int &H); -</pre></td> -<td><pre> -procedure Work_Area - (X, Y, W, H : out Integer); -</pre></td> - </tr> - - <tr> -<td><pre> -static void screen_xywh(int &X, int &Y, int &W, int &H); -</pre></td> -<td><pre> -procedure Bounding_Rect - (X, Y, W, H : out Integer); -</pre></td> - </tr> - - <tr> -<td><pre> -static void screen_xywh(int &X, int &Y, int &W, int &H, int mx, int my); -</pre></td> -<td><pre> -procedure Bounding_Rect - (X, Y, W, H : out Integer; - Pos_X, Pos_Y : in Integer); -</pre></td> - </tr> - - <tr> -<td><pre> -static void screen_xywh(int &X, int &Y, int &W, int &H, int n); -</pre></td> -<td><pre> -procedure Bounding_Rect - (X, Y, W, H : out Integer; - Screen_Num : in Integer); -</pre></td> - </tr> - - <tr> -<td><pre> -static void screen_xywh(int &X, int &Y, int &W, int &H, int mx, int my, int mw, int mh); -</pre></td> -<td><pre> -procedure Bounding_Rect - (X, Y, W, H : out Integer; - PX, PY, PW, PH : in Integer); -</pre></td> - </tr> - - <tr> -<td><pre> -static int scrollbar_size(); -</pre></td> -<td><pre> -function Get_Default_Scrollbar_Size - return Natural; -</pre></td> - </tr> - - <tr> -<td><pre> -static void scrollbar_size(int W); -</pre></td> -<td><pre> -procedure Set_Default_Scrollbar_Size - (To : in Natural); -</pre></td> - </tr> - - <tr> -<td><pre> -static void selection(Fl_Widget &owner, const char *, int len); -</pre></td> -<td><pre> -procedure Selection - (Owner : in FLTK.Widgets.Widget'Class; - Text : in String); -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Widget * selection_owner(); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void selection_owner(Fl_Widget *); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void set_abort(Fl_Abort_Handler f); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void set_atclose(Fl_Atclose_Handler f); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void set_box_color(Fl_Color); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void set_boxtype(Fl_Boxtype, Fl_Box_Draw_F *, uchar, uchar, uchar, uchar); -</pre></td> -<td>TBA</td> - </tr> - - <tr> -<td><pre> -static void set_boxtype(Fl_Boxtype, Fl_Boxtype from); -</pre></td> -<td><pre> -procedure Set_Box_Kind - (To, From : in Box_Kind); -</pre></td> - </tr> - - <tr> -<td><pre> -static void set_color(Fl_Color, uchar, uchar, uchar, uchar); -</pre></td> -<td><pre> -procedure Set_Color - (To : in Color; - R, G, B : in Color_Component); -</pre></td> - </tr> - - <tr> -<td><pre> -static void set_color(Fl_Color i, unsigned c); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void set_font(Fl_Font, const char *); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void set_font(Fl_Font, Fl_Font); -</pre></td> -<td><pre> -procedure Set_Font_Kind - (To, From : in Font_Kind); -</pre></td> - </tr> - - <tr> -<td><pre> -static Fl_Font set_fonts(const char *=0); -</pre></td> -<td><pre> -procedure Setup_Fonts - (How_Many_Set_Up : out Natural); -</pre></td> - </tr> - - <tr> -<td><pre> -static void set_idle(Fl_Old_Idle_Handler cb); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void set_labeltype(Fl_Labeltype, Fl_Label_Draw_F *, FL_Label_Measure_F *); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static void set_labeltype(Fl_Labeltype, Fl_Labeltype from); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int test_shortcut(Fl_Shortcut); +static void use_high_res_GL(int val); </pre></td> <td> </td> </tr> <tr> <td><pre> -static void * thread_message(); +static int use_high_res_GL(); </pre></td> <td> </td> </tr> <tr> -<td><pre> -static void unlock(); -</pre></td> -<td><pre> -procedure Unlock; -</pre></td> - </tr> - - <tr> -<td><pre> -static void use_high_res_GL(int val); -</pre></td> <td> </td> - </tr> - - <tr> <td><pre> -static int use_high_res_GL(); +function Is_Valid + (Object : in Wrapper) + return Boolean; </pre></td> -<td> </td> </tr> <tr> @@ -1945,43 +273,6 @@ function Version <tr> <td><pre> -static void visible_focus(int v); -</pre></td> -<td><pre> -procedure Set_Visible_Focus - (To : in Boolean); -</pre></td> - </tr> - - <tr> -<td><pre> -static int visible_focus(); -</pre></td> -<td><pre> -function Has_Visible_Focus - return Boolean; -</pre></td> - </tr> - - <tr> -<td><pre> -static int visual(int); -</pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int w(); -</pre></td> -<td><pre> -function Get_W - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> static int wait(); </pre></td> <td><pre> @@ -1997,7 +288,7 @@ static double wait(double time); <td><pre> function Wait (Seconds : in Long_Float) - return Integer; + return Long_Float; </pre></td> </tr> @@ -2005,27 +296,7 @@ function Wait <td><pre> static void watch_widget_pointer(Fl_Widget *&w); </pre></td> -<td> </td> - </tr> - - <tr> -<td><pre> -static int x(); -</pre></td> -<td><pre> -function Get_X - return Integer; -</pre></td> - </tr> - - <tr> -<td><pre> -static int y(); -</pre></td> -<td><pre> -function Get_Y - return Integer; -</pre></td> +<td>Marked as internal use only.</td> </tr> </table> diff --git a/doc/fl_(fltk-errors).html b/doc/fl_(fltk-errors).html new file mode 100644 index 0000000..7ccbe38 --- /dev/null +++ b/doc/fl_(fltk-errors).html @@ -0,0 +1,115 @@ +<!DOCTYPE html> + +<html lang="en"> + <head> + <meta charset="utf-8"> + <title>Fl (FLTK.Errors) Binding Map</title> + <link href="map.css" rel="stylesheet"> + </head> + + <body> + + +<h2>Fl (FLTK.Errors) Binding Map</h2> + + +<a href="index.html">Back to Index</a> + + +<table class="package"> + <tr><th colspan="2">Package name</th></tr> + + <tr> + <td>Fl</td> + <td>FLTK.Errors</td> + </tr> + +</table> + + + +<table class="type"> + <tr><th colspan="2">Types</th></tr> + + <tr> + <td>void (*)(const char *, ...)</td> + <td>Error_Function</td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Static Attributes</th></tr> + + <tr> +<td><pre> +static void (*error)(const char *, ...) = ::error; +</pre></td> +<td><pre> +Current_Error : Error_Function := Default_Error'Access; +</pre></td> + </tr> + + <tr> +<td><pre> +static void (*fatal)(const char *, ...) = ::fatal; +</pre></td> +<td><pre> +Current_Fatal : Error_Function := Default_Fatal'Access; +</pre></td> + </tr> + + <tr> +<td><pre> +static void (*warning)(const char *, ...) = ::warning; +</pre></td> +<td><pre> +Current_Warning : Error_Function := Default_Warning'Access; +</pre></td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Static Functions and Procedures</th></tr> + + <tr> +<td><pre> +static void error(const char *format, ...); +</pre></td> +<td><pre> +procedure Default_Error + (Message : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +static void fatal(const char *format, ...); +</pre></td> +<td><pre> +procedure Default_Fatal + (Message : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +static void warning(const char *, ...); +</pre></td> +<td><pre> +procedure Default_Warning + (Message : in String); +</pre></td> + </tr> + +</table> + + + </body> +</html> + diff --git a/doc/fl_(fltk-events).html b/doc/fl_(fltk-events).html new file mode 100644 index 0000000..6d17e85 --- /dev/null +++ b/doc/fl_(fltk-events).html @@ -0,0 +1,650 @@ +<!DOCTYPE html> + +<html lang="en"> + <head> + <meta charset="utf-8"> + <title>Fl (FLTK.Events) Binding Map</title> + <link href="map.css" rel="stylesheet"> + </head> + + <body> + + +<h2>Fl (FLTK.Events) Binding Map</h2> + + +<a href="index.html">Back to Index</a> + + +<table class="package"> + <tr><th colspan="2">Package name</th></tr> + + <tr> + <td>Fl</td> + <td>FLTK.Events</td> + </tr> + +</table> + + + +<table class="type"> + <tr><th colspan="2">Types</th></tr> + + <tr> + <td>Fl_Event_Handler</td> + <td>Event_Handler</td> + </tr> + + <tr> + <td>Fl_Event_Dispatch</td> + <td>Event_Dispatch</td> + </tr> + + <tr> + <td>void *</td> + <td>System_Event</td> + </tr> + + <tr> + <td>Fl_System_Handler</td> + <td>System_Handler</td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Static Functions and Procedures</th></tr> + + <tr> +<td><pre> +static void add_handler(Fl_Event_Handler h); +</pre></td> +<td><pre> +procedure Add_Handler + (Func : in not null Event_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void add_system_handler(Fl_System_Handler h, + void *data); +</pre></td> +<td><pre> +procedure Add_System_Handler + (Func : in not null System_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Widget * belowmouse(); +</pre></td> +<td><pre> +function Get_Below_Mouse + return access FLTK.Widgets.Widget'Class; +</pre></td> + </tr> + + <tr> +<td><pre> +static void belowmouse(Fl_Widget *); +</pre></td> +<td><pre> +procedure Set_Below_Mouse + (To : in FLTK.Widgets.Widget'Class); +</pre></td> + </tr> + + <tr> +<td><pre> +static int compose(int &del); +</pre></td> +<td><pre> +function Compose + (Del : out Natural) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static void compose_reset(); +</pre></td> +<td><pre> +procedure Compose_Reset; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event(); +</pre></td> +<td><pre> +function Last + return Event_Kind; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_alt(); +</pre></td> +<td><pre> +function Key_Alt + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_button(); +</pre></td> +<td><pre> +function Last_Button + return Mouse_Button; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_button1(); +</pre></td> +<td><pre> +function Mouse_Left + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_button2(); +</pre></td> +<td><pre> +function Mouse_Middle + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_button3(); +</pre></td> +<td><pre> +function Mouse_Right + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_button4(); +</pre></td> +<td><pre> +function Mouse_Back + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_button5(); +</pre></td> +<td><pre> +function Mouse_Forward + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_buttons(); +</pre></td> +<td><pre> +procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean); +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_clicks(); +</pre></td> +<td><pre> +function Is_Multi_Click + return Boolean; + +function Get_Clicks + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +static void event_clicks(int i); +</pre></td> +<td><pre> +procedure Set_Clicks + (To : in Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +static void * event_clipboard(); +</pre></td> +<td><pre> +function Clipboard_Text + return String; +</pre></td> + </tr> + + <tr> +<td><pre> +static const char * event_clipboard_type(); +</pre></td> +<td><pre> +function Clipboard_Kind + return String; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_command(); +</pre></td> +<td><pre> +function Key_Command + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_ctrl(); +</pre></td> +<td><pre> +function Key_Ctrl + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Event_Dispatch event_dispatch(); +</pre></td> +<td><pre> +function Get_Dispatch + return Event_Dispatch; +</pre></td> + </tr> + + <tr> +<td><pre> +static void event_dispatch(Fl_Event_Dispatch d); +</pre></td> +<td><pre> +procedure Set_Dispatch + (Func : in Event_Dispatch); +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_dx(); +</pre></td> +<td><pre> +function Mouse_DX + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_dy(); +</pre></td> +<td><pre> +function Mouse_DY + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_inside(const Fl_Widget *); +</pre></td> +<td><pre> +function Is_Inside + (Child : in FLTK.Widgets.Widget'Class) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_inside(int, int, int, int); +</pre></td> +<td><pre> +function Is_Inside + (X, Y, W, H : in Integer) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_is_click(); +</pre></td> +<td><pre> +function Is_Click + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static void event_is_click(int i); +</pre></td> +<td><pre> +procedure Clear_Click; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_key(); +</pre></td> +<td><pre> +function Last_Key + return Keypress; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_key(int key); +</pre></td> +<td><pre> +function Pressed_During + (Key : in Keypress) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_length(); +</pre></td> +<td><pre> +function Text_Length + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_original_key(); +</pre></td> +<td><pre> +function Original_Last_Key + return Keypress; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_shift(); +</pre></td> +<td><pre> +function Key_Shift + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_state(); +</pre></td> +<td><pre> +function Last_Modifier + return Modifier; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_state(int mask); +</pre></td> +<td><pre> +function Last_Modifier + (Had : in Modifier) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static const char * event_text(); +</pre></td> +<td><pre> +function Text + return String; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_x(); +</pre></td> +<td><pre> +function Mouse_X + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_x_root(); +</pre></td> +<td><pre> +function Mouse_X_Root + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_y(); +</pre></td> +<td><pre> +function Mouse_Y + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int event_y_root(); +</pre></td> +<td><pre> +function Mouse_Y_Root + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Widget * focus(); +</pre></td> +<td><pre> +function Get_Focus + return access FLTK.Widgets.Widget'Class; +</pre></td> + </tr> + + <tr> +<td><pre> +static void focus(Fl_Widget *); +</pre></td> +<td><pre> +procedure Set_Focus + (To : in FLTK.Widgets.Widget'Class); +</pre></td> + </tr> + + <tr> +<td><pre> +static int get_key(int key); +</pre></td> +<td><pre> +function Key_Now + (Key : in Keypress) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static void get_mouse(int &, int &); +</pre></td> +<td><pre> +procedure Get_Mouse + (X, Y : out Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Window * grab(); +</pre></td> +<td><pre> +function Get_Grab + return access FLTK.Widgets.Groups.Windows.Window'Class; +</pre></td> + </tr> + + <tr> +<td><pre> +static void grab(Fl_Window *); + +static void grab(Fl_Window &win); +</pre></td> +<td><pre> +procedure Set_Grab + (To : in FLTK.Widgets.Groups.Windows.Window'Class); +</pre></td> + </tr> + + <tr> +<td><pre> +static int handle(int, Fl_Window *); +</pre></td> +<td><pre> +function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; +</pre></td> + </tr> + + <tr> +<td><pre> +static int handle_(int, Fl_Window *); +</pre></td> +<td><pre> +function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Widget * pushed(); +</pre></td> +<td><pre> +function Get_Pushed + return access FLTK.Widgets.Widget'Class; +</pre></td> + </tr> + + <tr> +<td><pre> +static void pushed(Fl_Widget *); +</pre></td> +<td><pre> +procedure Set_Pushed + (To : in FLTK.Widgets.Widget'Class); +</pre></td> + </tr> + + <tr> +<td><pre> +static void release(); +</pre></td> +<td><pre> +procedure Release_Grab; +</pre></td> + </tr> + + <tr> +<td><pre> +static void remove_handler(Fl_Event_Handler h); +</pre></td> +<td><pre> +procedure Remove_Handler + (Func : in not null Event_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void remove_system_handler(Fl_System_Handler h); +</pre></td> +<td><pre> +procedure Remove_System_Handler + (Func : in not null System_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static int test_shortcut(Fl_Shortcut); +</pre></td> +<td><pre> +function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int visible_focus(); +</pre></td> +<td><pre> +function Has_Visible_Focus + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static void visible_focus(int v); +</pre></td> +<td><pre> +procedure Set_Visible_Focus + (To : in Boolean); +</pre></td> + </tr> + +</table> + + + </body> +</html> + diff --git a/doc/fl_(fltk-screen).html b/doc/fl_(fltk-screen).html new file mode 100644 index 0000000..7d44273 --- /dev/null +++ b/doc/fl_(fltk-screen).html @@ -0,0 +1,278 @@ +<!DOCTYPE html> + +<html lang="en"> + <head> + <meta charset="utf-8"> + <title>Fl (FLTK.Screen) Binding Map</title> + <link href="map.css" rel="stylesheet"> + </head> + + <body> + + +<h2>Fl (FLTK.Screen) Binding Map</h2> + + +<a href="index.html">Back to Index</a> + + +<table class="package"> + <tr><th colspan="2">Package name</th></tr> + + <tr> + <td>Fl</td> + <td>FLTK.Screen</td> + </tr> + +</table> + + + +<table class="type"> + <tr><th colspan="2">Types</th></tr> + + <tr> + <td>Fl_Mode</td> + <td>Visual_Mode</td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Static Functions and Procedures</th></tr> + + <tr> +<td><pre> +static int damage(); +</pre></td> +<td><pre> +function Is_Damaged + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static void damage(int d); +</pre></td> +<td><pre> +procedure Set_Damaged + (To : in Boolean); +</pre></td> + </tr> + + <tr> +<td><pre> +static void display(const char *); +</pre></td> +<td><pre> +procedure Set_Display_String + (Value : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +static void flush(); +</pre></td> +<td><pre> +procedure Flush; +</pre></td> + </tr> + + <tr> +<td><pre> +static int h(); +</pre></td> +<td><pre> +function Get_H + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static void redraw(); +</pre></td> +<td><pre> +procedure Redraw; +</pre></td> + </tr> + + <tr> +<td><pre> +static int screen_count(); +</pre></td> +<td><pre> +function Count + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static void screen_dpi(float &h, float &v, int n=0); +</pre></td> +<td><pre> +procedure DPI + (Horizontal, Vertical : out Float; + Screen_Number : in Integer := 1); +</pre></td> + </tr> + + <tr> +<td><pre> +static int screen_num(int x, int y); +</pre></td> +<td><pre> +function Containing + (X, Y : in Integer) + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int screen_num(int x, int y, int w, int h); +</pre></td> +<td><pre> +function Containing + (X, Y, W, H : in Integer) + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static void screen_work_area(int &X, int &Y, + int &W, int &H, int mx, int my); +</pre></td> +<td><pre> +procedure Work_Area + (X, Y, W, H : out Integer; + Pos_X, Pos_Y : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +static void screen_work_area(int &X, int &Y, + int &W, int &H, int n); +</pre></td> +<td><pre> +procedure Work_Area + (X, Y, W, H : out Integer; + Screen_Num : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +static void screen_xywh(int &X, int &Y, + int &W, int &H); +</pre></td> +<td><pre> +procedure Bounding_Rect + (X, Y, W, H : out Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +static void screen_xywh(int &X, int &Y, + int &W, int &H, int mx, int my); +</pre></td> +<td><pre> +procedure Bounding_Rect + (X, Y, W, H : out Integer; + Pos_X, Pos_Y : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +static void screen_xywh(int &X, int &Y, + int &W, int &H, int n); +</pre></td> +<td><pre> +procedure Bounding_Rect + (X, Y, W, H : out Integer; + Screen_Num : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +static void screen_xywh(int &X, int &Y, + int &W, int &H, int mx, int my, int mw, int mh); +</pre></td> +<td><pre> +procedure Bounding_Rect + (X, Y, W, H : out Integer; + PX, PY, PW, PH : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +static void screen_work_area(int &X, int &Y, + int &W, int &H); +</pre></td> +<td><pre> +procedure Work_Area + (X, Y, W, H : out Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +static int visual(int); +</pre></td> +<td><pre> +procedure Set_Visual_Mode + (Value : in Visual_Mode); + +function Set_Visual_Mode + (Value : in Visual_Mode) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int w(); +</pre></td> +<td><pre> +function Get_W + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int x(); +</pre></td> +<td><pre> +function Get_X + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int y(); +</pre></td> +<td><pre> +function Get_Y + return Integer; +</pre></td> + </tr> + +</table> + + + </body> +</html> + diff --git a/doc/fl_(fltk-static).html b/doc/fl_(fltk-static).html new file mode 100644 index 0000000..90e74cd --- /dev/null +++ b/doc/fl_(fltk-static).html @@ -0,0 +1,1028 @@ +<!DOCTYPE html> + +<html lang="en"> + <head> + <meta charset="utf-8"> + <title>Fl (FLTK.Static) Binding Map</title> + <link href="map.css" rel="stylesheet"> + </head> + + <body> + + +<h2>Fl (FLTK.Static) Binding Map</h2> + + +<a href="index.html">Back to Index</a> + + +<table class="package"> + <tr><th colspan="2">Package name</th></tr> + + <tr> + <td>Fl</td> + <td>FLTK.Static</td> + </tr> + +</table> + + + +<table class="type"> + <tr><th colspan="2">Types</th></tr> + + <tr> + <td>Fl_Abort_Handler</td> + <td> </td> + </tr> + + <tr> + <td>Fl_Args_Handler</td> + <td>Args_Handler</td> + </tr> + + <tr> + <td>Fl_Atclose_Handler</td> + <td> </td> + </tr> + + <tr> + <td>Fl_Awake_Handler</td> + <td>Awake_Handler</td> + </tr> + + <tr> + <td>Fl_Idle_Handler</td> + <td>Idle_Handler</td> + </tr> + + <tr> + <td>Fl_Old_Idle_Handler</td> + <td> </td> + </tr> + + <tr> + <td>Fl_Timeout_Handler</td> + <td>Timeout_Handler</td> + </tr> + + <tr> + <td>int</td> + <td>Buffer_Kind</td> + </tr> + + <tr> + <td>Fl_Clipboard_Notify_Handler</td> + <td>Clipboard_Notify_Handler</td> + </tr> + + <tr> + <td>FL_SOCKET</td> + <td>File_Descriptor</td> + </tr> + + <tr> + <td>int</td> + <td>File_Mode</td> + </tr> + + <tr> + <td>Fl_FD_Handler</td> + <td>File_Handler</td> + </tr> + + <tr> + <td>uchar</td> + <td>Byte_Integer</td> + </tr> + + <tr> + <td>Fl_Box_Draw_F</td> + <td>Box_Draw_Function</td> + </tr> + + <tr> + <td>Fl_Label_Draw_F</td> + <td>Label_Draw_Function</td> + </tr> + + <tr> + <td>Fl_Label_Measure_F</td> + <td>Label_Measure_Function</td> + </tr> + + <tr> + <td>Fl_Option</td> + <td>Option</td> + </tr> + +</table> + + + +<table class="type"> + <tr><th colspan="2">Errors</th></tr> + + <tr> + <td>int</td> + <td>Argument_Error</td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Static Attributes</th></tr> + + <tr> +<td><pre> +static void (*atclose)(Fl_Window *, void *); +</pre></td> +<td>Deprecated, set the callback for the Window instead.</td> + </tr> + + <tr> +<td><pre> +static const char * const help = helpmsg + 13; +</pre></td> +<td><pre> +Help_Message : constant String; +</pre></td> + </tr> + + <tr> +<td><pre> +static void (*idle)(); +</pre></td> +<td>Should not be used directly.</td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Static Functions and Procedures</th></tr> + + <tr> +<td><pre> +static int add_awake_handler_(Fl_Awake_Handler, void *); +</pre></td> +<td><pre> +procedure Add_Awake_Handler + (Func : in Awake_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void add_check(Fl_Timeout_Handler, void *=0); +</pre></td> +<td><pre> +procedure Add_Check + (Func : in not null Timeout_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void add_clipboard_notify(Fl_Clipboard_Notify_Handler h, + void *data=0); +</pre></td> +<td><pre> +procedure Add_Clipboard_Notify + (Func : in not null Clipboard_Notify_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void add_fd(int fd, Fl_FD_Handler cb, void *=0); +</pre></td> +<td><pre> +procedure Add_File_Descriptor + (FD : in File_Descriptor; + Func : in not null File_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void add_fd(int fd, int when, Fl_FD_Handler cb, + void *=0); +</pre></td> +<td><pre> +procedure Add_File_Descriptor + (FD : in File_Descriptor; + Mode : in File_Mode; + Func : in not null File_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void add_idle(Fl_Idle_Handler cb, void *data=0); +</pre></td> +<td><pre> +procedure Add_Idle + (Func : in not null Idle_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void add_timeout(double t, Fl_Timeout_Handler, + void *=0); +</pre></td> +<td><pre> +procedure Add_Timeout + (Seconds : in Long_Float; + Func : in not null Timeout_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static int arg(int argc, char **argv, int &i); +</pre></td> +<td><pre> +function Parse_Arg + (Index : in Positive) + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +static int args(int argc, char **argv, int &i, + Fl_Args_Handler cb=0); +</pre></td> +<td><pre> +procedure Parse_Args + (Count : out Natural; + Func : in Args_Handler := null); +</pre></td> + </tr> + + <tr> +<td><pre> +static void args(int argc, char **argv); +</pre></td> +<td><pre> +procedure Parse_Args; +</pre></td> + </tr> + + <tr> +<td><pre> +static int awake(Fl_Awake_Handler cb, void *message=0); +</pre></td> +<td><pre> +procedure Awake + (Func : in Awake_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void awake(void *message=0); +</pre></td> +<td><pre> +procedure Awake; +</pre></td> + </tr> + + <tr> +<td><pre> +static void background(uchar, uchar, uchar); +</pre></td> +<td><pre> +procedure Set_Background + (R, G, B : in Color_Component); +</pre></td> + </tr> + + <tr> +<td><pre> +static void background2(uchar, uchar, uchar); +</pre></td> +<td><pre> +procedure Set_Alt_Background + (R, G, B : in Color_Component); +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Color box_color(Fl_Color); +</pre></td> +<td><pre> +function Get_Box_Color + (Tone : in Color) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +static int box_dh(Fl_Boxtype); +</pre></td> +<td><pre> +function Get_Box_Height_Offset + (Kind : in Box_Kind) + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int box_dw(Fl_Boxtype); +</pre></td> +<td><pre> +function Get_Box_Width_Offset + (Kind : in Box_Kind) + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int box_dx(Fl_Boxtype); +</pre></td> +<td><pre> +function Get_Box_X_Offset + (Kind : in Box_Kind) + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int box_dy(Fl_Boxtype); +</pre></td> +<td><pre> +function Get_Box_Y_Offset + (Kind : in Box_Kind) + return Integer; +</pre></td> + </tr> + + <tr> +<td><pre> +static int clipboard_contains(const char *type); +</pre></td> +<td><pre> +function Clipboard_Contains + (Kind : in String) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static void copy + (const char *stuff, int len, int destination=0, + const char *type=Fl::clipboard_plain_text); +</pre></td> +<td><pre> +procedure Copy + (Text : in String; + Dest : in Buffer_Kind); +</pre></td> + </tr> + + <tr> +<td><pre> +static void default_atclose(Fl_Window *, void *); +</pre></td> +<td><pre> +procedure Default_Window_Close + (Item : in out FLTK.Widgets.Widget'Class); +</pre></td> + </tr> + + <tr> +<td><pre> +static void disable_im(); +</pre></td> +<td><pre> +procedure Disable_System_Input; +</pre></td> + </tr> + + <tr> +<td><pre> +static int dnd(); +</pre></td> +<td><pre> +procedure Drag_Drop_Start; +</pre></td> + </tr> + + <tr> +<td><pre> +static int dnd_text_ops(); +</pre></td> +<td><pre> +function Get_Drag_Drop_Text_Support + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static void dnd_text_ops(int v); +</pre></td> +<td><pre> +procedure Set_Drag_Drop_Text_Support + (To : in Boolean); +</pre></td> + </tr> + + <tr> +<td><pre> +static int draw_box_active(); +</pre></td> +<td><pre> +function Draw_Box_Active + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static void enable_im(); +</pre></td> +<td><pre> +procedure Enable_System_Input; +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Window * first_window(); +</pre></td> +<td><pre> +function Get_First_Window + return access FLTK.Widgets.Groups.Windows.Window'Class; +</pre></td> + </tr> + + <tr> +<td><pre> +static void first_window(Fl_Window *); +</pre></td> +<td><pre> +procedure Set_First_Window + (To : in FLTK.Widgets.Groups.Windows.Window'Class); +</pre></td> + </tr> + + <tr> +<td><pre> +static void foreground(uchar, uchar, uchar); +</pre></td> +<td><pre> +procedure Set_Foreground + (R, G, B : in Color_Component); +</pre></td> + </tr> + + <tr> +<td><pre> +static void free_color(Fl_Color i, int overlay=0); +</pre></td> +<td><pre> +procedure Free_Color + (Value : in Color; + Overlay : in Boolean := False); +</pre></td> + </tr> + + <tr> +<td><pre> +static int get_awake_handler_(Fl_Awake_Handler &, void *&); +</pre></td> +<td><pre> +function Get_Awake_Handler + return Awake_Handler; +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Box_Draw_F * get_boxtype(Fl_Boxtype); +</pre></td> +<td><pre> +function Get_Box_Draw_Function + (Kind : in Box_Kind) + return Box_Draw_Function; +</pre></td> + </tr> + + <tr> +<td><pre> +static unsigned get_color(Fl_Color i); +</pre></td> +<td><pre> +function Get_Color + (From : in Color) + return Color; +</pre></td> + </tr> + + <tr> +<td><pre> +static void get_color(Fl_Color i, + uchar &red, uchar &green, uchar &blue); +</pre></td> +<td><pre> +procedure Get_Color + (From : in Color; + R, G, B : out Color_Component); +</pre></td> + </tr> + + <tr> +<td><pre> +static const char * get_font(Fl_Font); +</pre></td> +<td><pre> +function Font_Image + (Kind : in Font_Kind) + return String; +</pre></td> + </tr> + + <tr> +<td><pre> +static const char * get_font_name(Fl_Font, + int *attributes=0); +</pre></td> +<td><pre> +function Font_Family_Image + (Kind : in Font_Kind) + return String; +</pre></td> + </tr> + + <tr> +<td><pre> +static int get_font_sizes(Fl_Font, int *&sizep); +</pre></td> +<td><pre> +function Font_Sizes + (Kind : in Font_Kind) + return Font_Size_Array; +</pre></td> + </tr> + + <tr> +<td><pre> +static void get_system_colors(); +</pre></td> +<td><pre> +procedure System_Colors; +</pre></td> + </tr> + + <tr> +<td><pre> +static int has_check(Fl_Timeout_Handler, void *=0); +</pre></td> +<td><pre> +function Has_Check + (Func : in not null Timeout_Handler) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int has_idle(Fl_Idle_Handler cb, void *data=0); +</pre></td> +<td><pre> +function Has_Idle + (Func : in not null Idle_Handler) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int has_timeout(Fl_Timeout_Handler, void *=0); +</pre></td> +<td><pre> +function Has_Timeout + (Func : in not null Timeout_Handler) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int is_scheme(const char *name); +</pre></td> +<td><pre> +function Is_Scheme + (Scheme : in String) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static int lock(); +</pre></td> +<td><pre> +procedure Lock; +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Window * modal(); +</pre></td> +<td><pre> +function Get_Top_Modal + return access FLTK.Widgets.Groups.Windows.Window'Class; +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Window * next_window(const Fl_Window *); +</pre></td> +<td><pre> +function Get_Next_Window + (From : in FLTK.Widgets.Groups.Windows.Window'Class) + return access FLTK.Widgets.Groups.Windows.Window'Class; +</pre></td> + </tr> + + <tr> +<td><pre> +static bool option(Fl_Option opt); +</pre></td> +<td><pre> +function Get_Option + (Opt : in Option) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +static void option(Fl_Option opt, bool val); +</pre></td> +<td><pre> +procedure Set_Option + (Opt : in Option; + To : in Boolean); +</pre></td> + </tr> + + <tr> +<td><pre> +static void own_colormap(); +</pre></td> +<td><pre> +procedure Own_Colormap; +</pre></td> + </tr> + + <tr> +<td><pre> +static void paste(Fl_Widget &receiver); +</pre></td> +<td>Marked as backwards compatibility only.</td> + </tr> + + <tr> +<td><pre> +static void paste + (Fl_Widget &receiver, int source, + const char *type=Fl::clipboard_plain_text); +</pre></td> +<td><pre> +procedure Paste + (Receiver : in FLTK.Widgets.Widget'Class; + Source : in Buffer_Kind); +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Widget * readqueue(); +</pre></td> +<td><pre> +function Read_Queue + return access FLTK.Widgets.Widget'Class; +</pre></td> + </tr> + + <tr> +<td><pre> +static int reload_scheme(); +</pre></td> +<td><pre> +procedure Reload_Scheme; +</pre></td> + </tr> + + <tr> +<td><pre> +static void remove_check(Fl_Timeout_Handler, void *=0); +</pre></td> +<td><pre> +procedure Remove_Check + (Func : in not null Timeout_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void remove_clipboard_notify + (Fl_Clipboard_Notify_Handler h); +</pre></td> +<td><pre> +procedure Remove_Clipboard_Notify + (Func : in not null Clipboard_Notify_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void remove_fd(int); +</pre></td> +<td><pre> +procedure Remove_File_Descriptor + (FD : in File_Descriptor); +</pre></td> + </tr> + + <tr> +<td><pre> +static void remove_fd(int, int when); +</pre></td> +<td><pre> +procedure Remove_File_Descriptor + (FD : in File_Descriptor; + Mode : in File_Mode); +</pre></td> + </tr> + + <tr> +<td><pre> +static void remove_idle(Fl_Idle_Handler cb, + void *data=0); +</pre></td> +<td><pre> +procedure Remove_Idle + (Func : in not null Idle_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static void remove_timeout(Fl_Timeout_Handler, + void *=0); +</pre></td> +<td><pre> +procedure Remove_Timeout + (Func : in not null Timeout_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static repeat_timeout(double t, Fl_Timeout_Handler, + void *=0); +</pre></td> +<td><pre> +procedure Repeat_Timeout + (Seconds : in Long_Float; + Func : in not null Timeout_Handler); +</pre></td> + </tr> + + <tr> +<td><pre> +static const char * scheme(); +</pre></td> +<td><pre> +function Get_Scheme + return String; +</pre></td> + </tr> + + <tr> +<td><pre> +static int scheme(const char *name); +</pre></td> +<td><pre> +procedure Set_Scheme + (To : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +static int scrollbar_size(); +</pre></td> +<td><pre> +function Get_Default_Scrollbar_Size + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +static void scrollbar_size(int W); +</pre></td> +<td><pre> +procedure Set_Default_Scrollbar_Size + (To : in Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +static void selection(Fl_Widget &owner, const char *, + int len); +</pre></td> +<td><pre> +procedure Selection + (Owner : in FLTK.Widgets.Widget'Class; + Text : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Widget * selection_owner(); +</pre></td> +<td>Marked as backwards compatibility only.</td> + </tr> + + <tr> +<td><pre> +static void selection_owner(Fl_Widget *); +</pre></td> +<td>Marked as backwards compatibility only.</td> + </tr> + + <tr> +<td><pre> +static void set_abort(Fl_Abort_Handler f); +</pre></td> +<td>Marked as backwards compatibility only.</td> + </tr> + + <tr> +<td><pre> +static void set_atclose(Fl_Atclose_Handler f); +</pre></td> +<td>Marked as backwards compatibility only.</td> + </tr> + + <tr> +<td><pre> +static void set_box_color(Fl_Color); +</pre></td> +<td><pre> +procedure Set_Box_Color + (Tone : in Color); +</pre></td> + </tr> + + <tr> +<td><pre> +static void set_boxtype(Fl_Boxtype, Fl_Box_Draw_F *, + uchar, uchar, uchar, uchar); +</pre></td> +<td><pre> +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); +</pre></td> + </tr> + + <tr> +<td><pre> +static void set_boxtype(Fl_Boxtype, Fl_Boxtype from); +</pre></td> +<td><pre> +procedure Set_Box_Kind + (To, From : in Box_Kind); +</pre></td> + </tr> + + <tr> +<td><pre> +static void set_color(Fl_Color i, unsigned c); +</pre></td> +<td><pre> +procedure Set_Color + (Target, Source : in Color); +</pre></td> + </tr> + + <tr> +<td><pre> +static void set_color(Fl_Color, + uchar, uchar, uchar, uchar); +</pre></td> +<td><pre> +procedure Set_Color + (Target : in Color; + R, G, B : in Color_Component); +</pre></td> + </tr> + + <tr> +<td><pre> +static void set_font(Fl_Font, const char *); +</pre></td> +<td><pre> +procedure Set_Font_Kind + (Target : in Font_Kind; + Source : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +static void set_font(Fl_Font, Fl_Font); +</pre></td> +<td><pre> +procedure Set_Font_Kind + (Target, Source : in Font_Kind); +</pre></td> + </tr> + + <tr> +<td><pre> +static Fl_Font set_fonts(const char *=0); +</pre></td> +<td><pre> +procedure Setup_Fonts + (How_Many_Set_Up : out Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +static void set_idle(Fl_Old_Idle_Handler cb); +</pre></td> +<td>Deprecated, use add_idle / Add_Idle instead.</td> + </tr> + + <tr> +<td><pre> +static void set_labeltype(Fl_Labeltype, Fl_Label_Draw_F *, + FL_Label_Measure_F *); +</pre></td> +<td><pre> +procedure Set_Label_Draw_Function + (Kind : in Label_Kind; + Draw_Func : in Label_Draw_Function; + Measure_Func : in Label_Measure_Function); +</pre></td> + </tr> + + <tr> +<td><pre> +static void set_labeltype(Fl_Labeltype, Fl_Labeltype from); +</pre></td> +<td><pre> +procedure Set_Label_Kind + (Target, Source : in Label_Kind); +</pre></td> + </tr> + + <tr> +<td><pre> +static void * thread_message(); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +static void unlock(); +</pre></td> +<td><pre> +procedure Unlock; +</pre></td> + </tr> + +</table> + + + </body> +</html> + diff --git a/doc/fl_ask.html b/doc/fl_ask.html index 6d72892..146c17b 100644 --- a/doc/fl_ask.html +++ b/doc/fl_ask.html @@ -24,6 +24,11 @@ <td>FLTK.Asks</td> </tr> + <tr> + <td>fl_show_colormap</td> + <td> </td> + </tr> + </table> @@ -383,6 +388,17 @@ function Password </pre></td> </tr> + <tr> +<td><pre> +Fl_Color fl_show_colormap(Fl_Color oldcol); +</pre></td> +<td><pre> +function Show_Colormap + (Old_Hue : in Color) + return Color; +</pre></td> + </tr> + </table> diff --git a/doc/fl_bitmap.html b/doc/fl_bitmap.html index 2a8cc72..edaf6a4 100644 --- a/doc/fl_bitmap.html +++ b/doc/fl_bitmap.html @@ -52,14 +52,49 @@ <td><pre> int alloc_array; </pre></td> -<td> </td> +<td>Intentionally left unbound.</td> </tr> <tr> <td><pre> const uchar * array; </pre></td> -<td> </td> +<td><pre> +function Data_Size + (This : in Bitmap) + return Size_Type; + +function Get_Datum + (This : in Bitmap; + Place : in Positive_Size) + return Color_Component +with Pre => Place <= This.Data_Size; + +procedure Set_Datum + (This : in out Bitmap; + Place : in Positive_Size; + Value : in Color_Component) +with Pre => Place <= This.Data_Size; + +function Slice + (This : in Bitmap; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array +with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Size_Type'Max (0, High - Low + 1); + +procedure Overwrite + (This : in out Bitmap; + Place : in Positive_Size; + Values : in Color_Component_Array) +with Pre => Place + Values'Length - 1 <= This.Data_Size; + +function All_Data + (This : in Bitmap) + return Color_Component_Array +with Post => All_Data'Result'Length = This.Data_Size; +</pre></td> </tr> </table> @@ -79,7 +114,25 @@ Fl_Bitmap(const char *bits, int W, int H); function Create (Data : in Color_Component_Array; Width, Height : in Natural) - return Bitmap; + return Bitmap +with Pre => + Data'Length >= Size_Type (Bytes_Needed (Width)) * Size_Type (Height); +</pre></td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Static Functions and Procedures</th></tr> + + <tr> +<td> </td> +<td><pre> +function Bytes_Needed + (Bits : in Natural) + return Natural; </pre></td> </tr> @@ -120,9 +173,9 @@ virtual void draw(int X, int Y, int W, int H, </pre></td> <td><pre> procedure Draw - (This : in Bitmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Bitmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); </pre></td> </tr> diff --git a/doc/fl_browser_.html b/doc/fl_browser_.html index 1ee2a6a..a09e2e4 100644 --- a/doc/fl_browser_.html +++ b/doc/fl_browser_.html @@ -47,7 +47,14 @@ already extended from it.</p> </tr> <tr> - <td>enum mode</td> + <td>enum {<br /> + HORIZONTAL = 1,<br /> + VERTICAL = 2,<br /> + BOTH = 3,<br /> + ALWAYS_ON = 4,<br /> + HORIZONTAL_ALWAYS = 5,<br /> + VERTICAL_ALWAYS = 6,<br /> + BOTH_ALWAYS = 7 }</td> <td>Scrollbar_Mode</td> </tr> diff --git a/doc/fl_button.html b/doc/fl_button.html index cc7b94d..05838b5 100644 --- a/doc/fl_button.html +++ b/doc/fl_button.html @@ -176,7 +176,7 @@ int shortcut() const; <td><pre> function Get_Shortcut (This : in Button) - return Shortcut_Key; + return Key_Combo; </pre></td> </tr> @@ -187,7 +187,7 @@ void shortcut(int s); <td><pre> procedure Set_Shortcut (This : in out Button; - Key : in Shortcut_Key); + Key : in Key_Combo); </pre></td> </tr> diff --git a/doc/fl_draw.html b/doc/fl_draw.html index 03c31f5..aca154a 100644 --- a/doc/fl_draw.html +++ b/doc/fl_draw.html @@ -32,52 +32,64 @@ <tr><th colspan="2">Types</th></tr> <tr> - <td>Fl_Line</td> + <td>int</td> <td>Line_Kind</td> </tr> <tr> - <td> </td> + <td>int</td> <td>Cap_Kind</td> </tr> <tr> - <td> </td> + <td>int</td> <td>Join_Kind</td> </tr> <tr> - <td> </td> + <td>char</td> <td>Dash_Length</td> </tr> <tr> - <td> </td> + <td>char *</td> <td>Dash_Gap</td> </tr> <tr> - <td> </td> + <td>char *</td> <td>Dash_Gap_Array</td> </tr> <tr> - <td> </td> - <td>Text_Draw_Function</td> + <td>Fl_Draw_Image_Cb</td> + <td>Image_Draw_Function</td> </tr> <tr> - <td> </td> + <td>void(*drawit)(Fl_Color)</td> <td>Symbol_Draw_Function</td> </tr> <tr> - <td> </td> + <td>void(*callthis)(const char *, int, int, int)</td> + <td>Text_Draw_Function</td> + </tr> + + <tr> + <td>void(*draw_area)(void *, int, int, int, int)</td> <td>Area_Draw_Function</td> </tr> +</table> + + + +<table class="type"> + <tr><th colspan="2">Errors</th></tr> + <tr> - <td> </td> + <td>int</td> <td>Draw_Error</td> </tr> @@ -96,7 +108,7 @@ int fl_add_symbol(const char *name, void(*drawit)(Fl_Color), <td><pre> procedure Add_Symbol (Text : in String; - Func : in Symbol_Drawing_Function; + Func : in Symbol_Draw_Function; Scalable : in Boolean); </pre></td> </tr> @@ -215,14 +227,14 @@ function Clip_Box <td><pre> Fl_Region fl_clip_region(); </pre></td> -<td>Left unbound due to being OS-specific</td> +<td>Left unbound due to being OS-specific.</td> </tr> <tr> <td><pre> void fl_clip_region(Fl_Region r); </pre></td> -<td>Left unbound due to being OS-specific</td> +<td>Left unbound due to being OS-specific.</td> </tr> <tr> @@ -354,14 +366,14 @@ procedure Draw_Text (X, Y, W, H : in Integer; Text : in String; Align : in Alignment; - Func : in Text_Drawing_Function; + Func : in Text_Draw_Function; Symbols : in Boolean := True); procedure Draw_Text (X, Y, W, H : in Integer; Text : in String; Align : in Alignment; - Func : in Text_Drawing_Function; + Func : in Text_Draw_Function; Picture : in FLTK.Images.Image'Class; Symbols : in Boolean := True); </pre></td> @@ -403,9 +415,12 @@ procedure Draw_Image (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); + Flip_Vertical : in Boolean := False) +with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (W) * Size_Type (H) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (H)); </pre></td> </tr> @@ -432,9 +447,12 @@ procedure Draw_Image_Mono (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); + Flip_Vertical : Boolean := False) +with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (W) * Size_Type (H) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (H)); </pre></td> </tr> @@ -455,19 +473,23 @@ procedure Draw_Image_Mono <td><pre> int fl_draw_pixmap(char * const *data, int x, int y, Fl_Color=FL_GRAY); -</pre></td> -<td><pre> - -</pre></td> - </tr> - <tr> -<td><pre> int fl_draw_pixmap(const char * const *cdata, int x, int y, Fl_Color=FL_GRAY); </pre></td> <td><pre> - +procedure Draw_Pixmap + (Values : in FLTK.Images.Pixmaps.Header; + Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; + Pixels : in FLTK.Images.Pixmaps.Pixmap_Data; + X, Y : in Integer; + Tone : in Color := Grey0_Color) +with Pre => + Colors'Length = Values.Colors and + Pixels'Length (1) = Values.Height and + (for all Definition of Colors => + Ada.Strings.Unbounded.Length (Definition.Name) = Values.Per_Pixel) and + Pixels'Length (2) = Values.Width * Values.Per_Pixel; </pre></td> </tr> @@ -535,7 +557,14 @@ const char * fl_expand_text(const char *from, char *buf, int maxbuf, double maxw, int &n, double &width, int wrap, int draw_symbols=0); </pre></td> <td><pre> - +function Expand_Text + (Text : in String; + Max_Width : in Long_Float; + Width : out Long_Float; + Last : out Natural; + Wrap : in Boolean; + Symbols : in Boolean := False) + return String; </pre></td> </tr> @@ -727,19 +756,11 @@ procedure Measure <tr> <td><pre> int fl_measure_pixmap(char *const *data, int &w, int &h); -</pre></td> -<td><pre> -</pre></td> - </tr> - - <tr> -<td><pre> int fl_measure_pixmap(const char *const *cdata, int &w, int &h); </pre></td> -<td><pre> - -</pre></td> +<td>If you have the Header as defined in FLTK.Images.Pixmaps +then you should already have the width and height values.</td> </tr> <tr> @@ -894,9 +915,9 @@ function Read_Image Alpha : in Integer := 0) return Color_Component_Array with Post => - (if Alpha = 0 - then Read_Image'Result'Length = W * H * 3 - else Read_Image'Result'Length = W * H * 4); + (if Alpha = 0 + then Read_Image'Result'Length = Size_Type (W) * Size_Type (H) * 3 + else Read_Image'Result'Length = Size_Type (W) * Size_Type (H) * 4); </pre></td> </tr> diff --git a/doc/fl_file_chooser.html b/doc/fl_file_chooser.html index 24bd6d8..f186ca4 100644 --- a/doc/fl_file_chooser.html +++ b/doc/fl_file_chooser.html @@ -45,7 +45,11 @@ See Fl_Ask for related symbols that are not members of the Fl_File_Chooser class </tr> <tr> - <td>enum {SINGLE=0, MULTI=1, CREATE=2, DIRECTORY=4}</td> + <td>enum {<br /> + SINGLE = 0,<br /> + MULTI = 1,<br /> + CREATE = 2,<br /> + DIRECTORY = 4 }</td> <td>Chooser_Kind</td> </tr> diff --git a/doc/fl_image.html b/doc/fl_image.html index 7550b5c..201a2fa 100644 --- a/doc/fl_image.html +++ b/doc/fl_image.html @@ -46,11 +46,6 @@ <td>Scaling_Kind</td> </tr> - <tr> - <td>float</td> - <td>Blend</td> - </tr> - </table> @@ -84,21 +79,21 @@ <td><pre> static const int ERR_FILE_ACCESS = -2; </pre></td> -<td> </td> +<td>See the errors table.</td> </tr> <tr> <td><pre> static const int ERR_FORMAT = -3; </pre></td> -<td> </td> +<td>See the errors table.</td> </tr> <tr> <td><pre> static const int ERR_NO_IMAGE = -1; </pre></td> -<td> </td> +<td>See the errors table.</td> </tr> </table> @@ -192,20 +187,7 @@ function Copy <td><pre> int count() const; </pre></td> -<td><pre> -function Get_Data_Count - (This : in Image) - return Natural; -</pre></td> - </tr> - - <tr> -<td> </td> -<td><pre> -function Get_Data_Size - (This : in Image) - return Natural; -</pre></td> +<td>Intentionally left unbound.</td> </tr> <tr> @@ -223,53 +205,8 @@ function Get_D <td><pre> const char * const * data() const; </pre></td> -<td><pre> -function Get_Datum - (This : in Image; - Data : in Positive; - Position : in Positive) - return Color_Component -with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This); - -procedure Set_Datum - (This : in out Image; - Data : in Positive; - Position : in Positive; - Value : in Color_Component) -with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This); - -function Get_Data - (This : in Image; - Data : in Positive; - Position : in Positive; - Count : in Natural) - return Color_Component_Array -with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This) and - Count <= Get_Data_Size (This) - Position + 1; - -function All_Data - (This : in Image; - Data : in Positive) - return Color_Component_Array -with Pre => - Data <= Get_Data_Count (This); - -procedure Update_Data - (This : in out Image; - Data : in Positive; - Position : in Positive; - Values : in Color_Component_Array) -with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This) and - Values'Length <= Get_Data_Size (This) - Position + 1; -</pre></td> +<td>See Data_Size, Get_Datum, Set_Datum, Slice, Overwrite, All_Data subprograms +in Fl_Bitmap and Fl_RGB_Image.</td> </tr> <tr> @@ -289,9 +226,9 @@ virtual void draw(int X, int Y, int W, int H, </pre></td> <td><pre> procedure Draw - (This : in Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); </pre></td> </tr> @@ -357,7 +294,7 @@ virtual void label(Fl_Menu_Item *m); int ld() const; </pre></td> <td><pre> -function Get_Line_Data +function Get_Line_Size (This : in Image) return Natural; </pre></td> diff --git a/doc/fl_input_.html b/doc/fl_input_.html index 071ec66..e9edf37 100644 --- a/doc/fl_input_.html +++ b/doc/fl_input_.html @@ -392,9 +392,9 @@ procedure Resize int shortcut() const; </pre></td> <td><pre> -function Get_Shortcut_Key +function Get_Shortcut (This : in Input) - return Shortcut_Key; + return Key_Combo; </pre></td> </tr> @@ -403,9 +403,9 @@ function Get_Shortcut_Key void shortcut(int s); </pre></td> <td><pre> -procedure Set_Shortcut_Key +procedure Set_Shortcut (This : in out Input; - To : in Shortcut_Key); + To : in Key_Combo); </pre></td> </tr> diff --git a/doc/fl_pack.html b/doc/fl_pack.html index 1a7a887..f850557 100644 --- a/doc/fl_pack.html +++ b/doc/fl_pack.html @@ -42,7 +42,9 @@ </tr> <tr> - <td>enum { VERTICAL = 0, HORIZONTAL = 1 }</td> + <td>enum {<br /> + VERTICAL = 0,<br /> + HORIZONTAL = 1 }</td> <td>Pack_Kind</td> </tr> diff --git a/doc/fl_pixmap.html b/doc/fl_pixmap.html index 60fec01..ab8c8d8 100644 --- a/doc/fl_pixmap.html +++ b/doc/fl_pixmap.html @@ -41,6 +41,31 @@ <td>Pixmap_Reference</td> </tr> + <tr> + <td>char *</td> + <td>Header</td> + </tr> + + <tr> + <td>char</td> + <td>Color_Kind</td> + </tr> + + <tr> + <td>char *</td> + <td>Color_Definition</td> + </tr> + + <tr> + <td>char **</td> + <td>Color_Definition_Array</td> + </tr> + + <tr> + <td>char **</td> + <td>Pixmap_Data</td> + </tr> + </table> @@ -72,7 +97,19 @@ Fl_Pixmap(const char *const *D); Fl_Pixmap(const uchar *const *D); </pre></td> -<td> </td> +<td><pre> +function Create + (Values : in Header; + Colors : in Color_Definition_Array; + Pixels : in Pixmap_Data) + return Pixmap +with Pre => + Colors'Length = Values.Colors and + Pixels'Length (1) = Values.Height and + (for all Definition of Colors => + Ada.Strings.Unbounded.Length (Definition.Name) = Values.Per_Pixel) and + Pixels'Length (2) = Values.Width * Values.Per_Pixel; +</pre></td> </tr> </table> @@ -134,9 +171,9 @@ virtual void draw(int X, int Y, int W, int H, </pre></td> <td><pre> procedure Draw - (This : in Pixmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Pixmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); </pre></td> </tr> diff --git a/doc/fl_rgb_image.html b/doc/fl_rgb_image.html index 1e115d5..6d5427d 100644 --- a/doc/fl_rgb_image.html +++ b/doc/fl_rgb_image.html @@ -59,7 +59,42 @@ int alloc_array; <td><pre> const uchar * array; </pre></td> -<td>Intentionally left unbound.</td> +<td><pre> +function Data_Size + (This : in RGB_Image) + return Size_Type; + +function Get_Datum + (This : in RGB_Image; + Place : in Positive_Size) + return Color_Component +with Pre => Place <= This.Data_Size; + +procedure Set_Datum + (This : in out RGB_Image; + Place : in Positive_Size; + Value : in Color_Component) +with Pre => Place <= This.Data_Size; + +function Slice + (This : in RGB_Image; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array +with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Size_Type'Max (0, High - Low + 1); + +procedure Overwrite + (This : in out RGB_Image; + Place : in Positive_Size; + Values : in Color_Component_Array) +with Pre => Place + Values'Length - 1 <= This.Data_Size; + +function All_Data + (This : in RGB_Image) + return Color_Component_Array +with Post => All_Data'Result'Length = This.Data_Size; +</pre></td> </tr> </table> @@ -71,15 +106,20 @@ const uchar * array; <tr> <td><pre> -Fl_RGB_Image(const uchar *bits, int W, int H, int D=3, int LD=0); +Fl_RGB_Image(const uchar *bits, int W, int H, + int D=3, int LD=0); </pre></td> <td><pre> function Create (Data : in Color_Component_Array; Width, Height : in Natural; Depth : in Natural := 3; - Line_Data : in Natural := 0) - return RGB_Image; + Line_Size : in Natural := 0) + return RGB_Image +with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (Width) * Size_Type (Height) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (Height)) + and Data'Length <= Get_Max_Size; </pre></td> </tr> @@ -108,7 +148,7 @@ static void max_size(size_t size); </pre></td> <td><pre> procedure Set_Max_Size - (Value : in Natural); + (Value : in Size_Type); </pre></td> </tr> @@ -118,7 +158,7 @@ static size_t max_size(); </pre></td> <td><pre> function Get_Max_Size - return Natural; + return Size_Type; </pre></td> </tr> @@ -181,9 +221,9 @@ virtual void draw(int X, int Y, int W, int H, </pre></td> <td><pre> procedure Draw - (This : in RGB_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in RGB_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); </pre></td> </tr> diff --git a/doc/fl_scroll.html b/doc/fl_scroll.html index 35856ba..4c8977b 100644 --- a/doc/fl_scroll.html +++ b/doc/fl_scroll.html @@ -42,10 +42,37 @@ </tr> <tr> - <td>enum { HORIZONTAL = 1, VERTICAL = 2, BOTH = 3, ALWAYS_ON = 4, HORIZONTAL_ALWAYS = 5, VERTICAL_ALWAYS = 6, BOTH_ALWAYS = 7 } + <td>enum {<br /> + HORIZONTAL = 1,<br /> + VERTICAL = 2,<br /> + BOTH = 3,<br /> + ALWAYS_ON = 4,<br /> + HORIZONTAL_ALWAYS = 5,<br /> + VERTICAL_ALWAYS = 6,<br /> + BOTH_ALWAYS = 7 } <td>Scroll_Kind</td> </tr> + <tr> + <td>Fl_Region_LRTB</td> + <td>Region</td> + </tr> + + <tr> + <td>Fl_Region_XYWH</td> + <td>Region</td> + </tr> + + <tr> + <td>Fl_Scrollbar_Data</td> + <td>Scrollbar_Data</td> + </tr> + + <tr> + <td>ScrollInfo</td> + <td>Scroll_Info</td> + </tr> + </table> @@ -139,7 +166,11 @@ function Handle <td><pre> void resize(int X, int Y, int W, int H); </pre></td> -<td> </td> +<td><pre> +procedure Resize + (This : in out Scroll; + X, Y, W, H : in Integer); +</pre></td> </tr> <tr> @@ -226,7 +257,11 @@ procedure Set_Kind <td><pre> void bbox(int &, int &, int &, int &); </pre></td> -<td> </td> +<td><pre> +procedure Bounding_Box + (This : in Scroll; + X, Y, W, H : out Integer); +</pre></td> </tr> <tr> @@ -243,7 +278,11 @@ procedure Draw <td><pre> void recalc_scrollbars(Scrollinfo &si); </pre></td> -<td> </td> +<td><pre> +procedure Recalculate_Scrollbars + (This : in Scroll; + Data : out Scroll_Info); +</pre></td> </tr> </table> diff --git a/doc/fl_text_display.html b/doc/fl_text_display.html index e37622c..54b2f54 100644 --- a/doc/fl_text_display.html +++ b/doc/fl_text_display.html @@ -42,22 +42,39 @@ </tr> <tr> - <td>enum { NORMAL_CURSOR, CARET_CURSOR, DIM_CURSOR, BLOCK_CURSOR, HEAVY_CURSOR, SIMPLE_CURSOR }</td> + <td>enum {<br /> + NORMAL_CURSOR,<br /> + CARET_CURSOR,<br /> + DIM_CURSOR,<br /> + BLOCK_CURSOR,<br /> + HEAVY_CURSOR,<br /> + SIMPLE_CURSOR }</td> <td>Cursor_Style</td> </tr> <tr> - <td>enum { CURSOR_POS, CHARACTER_POS }</td> - <td> </td> + <td>enum {<br /> + CURSOR_POS,<br /> + CHARACTER_POS }</td> + <td>Position_Kind</td> </tr> <tr> - <td>enum { DRAG_NONE = -2, DRAG_START_DND = -1, DRAG_CHAR = 0, DRAG_WORD = 1, DRAG_LINE = 2 }</td> + <td>enum {<br /> + DRAG_NONE = -2,<br /> + DRAG_START_DND = -1,<br /> + DRAG_CHAR = 0,<br /> + DRAG_WORD = 1,<br /> + DRAG_LINE = 2 }</td> <td> </td> </tr> <tr> - <td>enum { WRAP_NONE, WRAP_AT_COLUMN, WRAP_AT_PIXEL, WRAP_AT_BOUNDS }</td> + <td>enum {<br /> + WRAP_NONE,<br /> + WRAP_AT_COLUMN,<br /> + WRAP_AT_PIXEL,<br /> + WRAP_AT_BOUNDS }</td> <td>Wrap_Mode</td> </tr> @@ -72,15 +89,25 @@ </tr> <tr> - <td> </td> + <td>uchar</td> <td>Style_Index</td> </tr> <tr> - <td> </td> + <td>Style_Table_Entry *</td> <td>Style_Array</td> </tr> + <tr> + <td>int</td> + <td>Style_Mask</td> + </tr> + + <tr> + <td>int</td> + <td>Style_Info</td> + </tr> + </table> @@ -135,6 +162,7 @@ function Create <tr> <td><pre> void buffer(Fl_Text_Buffer *buf); + void buffer(Fl_Text_Buffer &buf); </pre></td> <td><pre> @@ -169,7 +197,8 @@ function Col_To_X <tr> <td><pre> -int count_lines(int start, int end, bool start_pos_is_line_start) const; +int count_lines(int start, int end, + bool start_pos_is_line_start) const; </pre></td> <td><pre> function Count_Lines @@ -306,19 +335,9 @@ function Get_Insert_Position </tr> <tr> -<td> </td> -<td><pre> -function Item - (Tint : in Color; - Font : in Font_Kind; - Size : in Font_Size) - return Style_Entry; -</pre></td> - </tr> - - <tr> <td><pre> -int line_end(int startPos, bool startPosIsLineStart) const; +int line_end(int startPos, + bool startPosIsLineStart) const; </pre></td> <td><pre> function Line_End @@ -431,16 +450,24 @@ function Get_Linenumber_Font <tr> <td><pre> -void linenumber_format(const char *val); +const char * linenumber_format() const; +</pre></td> +<td><pre> +function Get_Linenumber_Format + (This : in Text_Display) + return String; </pre></td> -<td> </td> </tr> <tr> <td><pre> -const char * linenumber_format() const; +void linenumber_format(const char *val); +</pre></td> +<td><pre> +procedure Set_Linenumber_Format + (This : in out Text_Display; + Value : in String); </pre></td> -<td> </td> </tr> <tr> @@ -494,6 +521,10 @@ int move_down(); <td><pre> procedure Move_Down (This : in out Text_Display); + +function Move_Down + (This : in out Text_Display) + return Boolean; </pre></td> </tr> @@ -504,6 +535,10 @@ int move_left(); <td><pre> procedure Move_Left (This : in out Text_Display); + +function Move_Left + (This : in out Text_Display) + return Boolean; </pre></td> </tr> @@ -514,6 +549,10 @@ int move_right(); <td><pre> procedure Move_Right (This : in out Text_Display); + +function Move_Right + (This : in out Text_Display) + return Boolean; </pre></td> </tr> @@ -524,6 +563,10 @@ int move_up(); <td><pre> procedure Move_Up (This : in out Text_Display); + +function Move_Up + (This : in out Text_Display) + return Boolean; </pre></td> </tr> @@ -550,9 +593,17 @@ procedure Overstrike <tr> <td><pre> -int position_style(int lineStartPos, int lineLen, int lineIndex) const; +int position_style(int lineStartPos, int lineLen, + int lineIndex) const; +</pre></td> +<td><pre> +function Position_Style + (This : in Text_Display; + Line_Start : in Natural; + Line_Length : in Natural; + Line_Index : in Natural) + return Styles.Style_Info; </pre></td> -<td> </td> </tr> <tr> @@ -593,7 +644,11 @@ procedure Redisplay_Range <td><pre> virtual void resize(int X, int Y, int W, int H); </pre></td> -<td> </td> +<td><pre> +procedure Resize + (This : in out Text_Display; + X, Y, W, H : in Integer); +</pre></td> </tr> <tr> @@ -614,8 +669,9 @@ void scroll(int topLineNum, int horizOffset); </pre></td> <td><pre> procedure Scroll_To - (This : in out Text_Display; - Line : in Natural); + (This : in out Text_Display; + Line : in Natural; + Column : in Natural := 0); </pre></td> </tr> @@ -667,14 +723,22 @@ procedure Set_Scrollbar_Width <td><pre> int shortcut() const; </pre></td> -<td> </td> +<td><pre> +function Get_Shortcut + (This : in Text_Display) + return Key_Combo; +</pre></td> </tr> <tr> <td><pre> void shortcut(int s); </pre></td> -<td> </td> +<td><pre> +procedure Set_Shortcut + (This : in out Text_Display; + Value : in Key_Combo); +</pre></td> </tr> <tr> @@ -699,7 +763,8 @@ procedure Show_Insert_Position <tr> <td><pre> -int skip_lines(int startPos, int nLines, bool startPosIsLineStart); +int skip_lines(int startPos, int nLines, + bool startPosIsLineStart); </pre></td> <td><pre> function Skip_Lines @@ -816,14 +881,24 @@ procedure Set_Wrap_Mode <td><pre> int wrapped_column(int row, int column) const; </pre></td> -<td> </td> +<td><pre> +function Wrapped_Column + (This : in Text_Display; + Row, Column : in Natural) + return Natural; +</pre></td> </tr> <tr> <td><pre> int wrapped_row(int row) const; </pre></td> -<td> </td> +<td><pre> +function Wrapped_Row + (This : in Text_Display; + Row : in Natural) + return Natural; +</pre></td> </tr> <tr> @@ -845,6 +920,54 @@ function X_To_Col <table class="function"> <tr><th colspan="2">Static Protected Functions and Procedures</th></tr> + <tr> +<td><pre> +static void buffer_modified_cb(int pos, int nInserted, int nDeleted, + int nRestyled, const char *deletedText, void *cbArg); +</pre></td> +<td><pre> +procedure Buffer_Modified_Callback + (This : in out Text_Display; + Action : in FLTK.Text_Buffers.Modification; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural; + Deleted_Text : in String); +</pre></td> + </tr> + + <tr> +<td><pre> +static void buffer_predelete_cb(int pos, int nDeleted, void *cbArg); +</pre></td> +<td><pre> +procedure Buffer_Predelete_Callback + (This : in out Text_Display; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +static void h_scrollbar_cb(Fl_Scrollbar *w, Fl_Text_Display *d); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +static void scroll_timer_cb(void *); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +static void v_scrollbar_cb(Fl_Scrollbar *w, Fl_Text_Display *d); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + </table> @@ -854,6 +977,61 @@ function X_To_Col <tr> <td><pre> +void absolute_top_line_number(int oldFirstChar); +</pre></td> +<td><pre> +procedure Redo_Absolute_Top_Line + (This : in out Text_Display; + Old_First : in Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +void calc_last_char(); +</pre></td> +<td><pre> +procedure Calculate_Last_Character + (This : in out Text_Display); +</pre></td> + </tr> + + <tr> +<td><pre> +void calc_line_starts(int startLine, int endLine); +</pre></td> +<td><pre> +procedure Calculate_Line_Starts + (This : in out Text_Display; + Start, Finish : in Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +void clear_rect(int style, int x, int y, int width, + int height) const; +</pre></td> +<td><pre> +procedure Clear_Rect + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y, W, H : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +void display_insert(); +</pre></td> +<td><pre> +procedure Display_Insert + (This : in out Text_Display); +</pre></td> + </tr> + + <tr> +<td><pre> virtual void draw(); </pre></td> <td><pre> @@ -862,6 +1040,412 @@ procedure Draw </pre></td> </tr> + <tr> +<td><pre> +void draw_cursor(int, int); +</pre></td> +<td><pre> +procedure Draw_Cursor + (This : in out Text_Display; + X, Y : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_line_numbers(bool clearAll); +</pre></td> +<td><pre> +procedure Draw_Line_Numbers + (This : in out Text_Display; + Clear : in Boolean := False); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_range(int start, int end); +</pre></td> +<td><pre> +procedure Draw_Range + (This : in out Text_Display; + Start, Finish : in Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_string(int style, int x, int y, int toX, + const char *string, int nChars) const; +</pre></td> +<td><pre> +procedure Draw_String + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y : in Integer; + Right : in Integer; + Text : in String; + Num_Chars : in Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_text(int x, int y, int w, int h); +</pre></td> +<td><pre> +procedure Draw_Text + (This : in out Text_Display; + X, Y, W, H : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_vline(int visLineNum, int leftClip, int rightClip, + int leftCharIndex, int rightCharIndex); +</pre></td> +<td><pre> +procedure Draw_Visible_Line + (This : in out Text_Display; + Line : in Natural; + Left_Clip, Right_Clip : in Integer; + Left_Char, Right_Char : in Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +int empty_vlines() const; +</pre></td> +<td><pre> +function Has_Empty_Visible_Lines + (This : in Text_Display) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +void extend_range_for_styles(int *start, int *end); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +void find_line_end(int pos, bool start_pos_is_line_start, + int *lineEnd, int *nextLineStart) const; +</pre></td> +<td><pre> +procedure Find_Line_End + (This : in Text_Display; + Start : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Line_End : out Natural; + Next_Line_Start : out Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +void find_wrap_range(const char *deletedText, int pos, + int nInserted, int nDeleted, int *modRangeStart, + int *modRangeEnd, int *linesInserted, int *linesDeleted); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +int find_x(const char *s, int len, int style, int x) const; +</pre></td> +<td><pre> +function Find_Character + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index; + X : in Integer) + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +int get_absolute_top_line_number() const; +</pre></td> +<td><pre> +function Get_Absolute_Top_Line + (This : in Text_Display) + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +int handle_vline(int mode, int lineStart, int lineLen, + int leftChar, int rightChar, int topClip, int bottomClip, + int leftClip, int rightClip) const; +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +int longest_vline() const; +</pre></td> +<td><pre> +function Get_Longest_Visible_Line + (This : in Text_Display) + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +void maintain_absolute_top_line_number(int state); +</pre></td> +<td><pre> +procedure Maintain_Absolute_Top_Line + (This : in out Text_Display; + State : in Boolean := True); +</pre></td> + </tr> + + <tr> +<td><pre> +int maintaining_absolute_top_line_number() const; +</pre></td> +<td><pre> +function Maintaining_Absolute_Top_Line + (This : in Text_Display) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +void measure_deleted_lines(int pos, int nDeleted); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +double measure_proportional_character(const char *s, int colNum, + int pos) const; +</pre></td> +<td><pre> +function Measure_Character + (This : in Text_Display; + Text : in String; + X : in Integer; + Index : in Positive) + return Long_Float; +</pre></td> + </tr> + + <tr> +<td><pre> +int measure_vline(int visLineNum) const; +</pre></td> +<td><pre> +function Measure_Visible_Line + (This : in Text_Display; + Line : in Natural) + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +void offset_line_starts(int newTopLineNum); +</pre></td> +<td><pre> +procedure Offset_Line_Starts + (This : in out Text_Display; + New_Top : in Natural); +</pre></td> + </tr> + + <tr> +<td><pre> +int position_to_line(int pos, int *lineNum) const; +</pre></td> +<td><pre> +function Position_To_Line + (This : in Text_Display; + Position : in Natural) + return Natural; + +function Position_To_Line + (This : in Text_Display; + Position : in Natural; + Displayed : out Boolean) + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +int position_to_linecol(int pos, int *lineNum, int *column) const; +</pre></td> +<td><pre> +procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural); + +procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural; + Displayed : out Boolean); +</pre></td> + </tr> + + <tr> +<td><pre> +void reset_absolute_top_line_number(); +</pre></td> +<td><pre> +procedure Reset_Absolute_Top_Line + (This : in out Text_Display); +</pre></td> + </tr> + + <tr> +<td><pre> +int scroll_(int topLineNum, int horizOffset); +</pre></td> +<td><pre> +function Scroll_To + (This : in out Text_Display; + Line : in Natural; + Pixel : in Natural := 0) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +double string_width(const char *string, int length, + int style) const; +</pre></td> +<td><pre> +function Measure_String + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index) + return Long_Float; +</pre></td> + </tr> + + <tr> +<td><pre> +void update_h_scrollbar(); +</pre></td> +<td><pre> +procedure Update_Horizontal_Scrollbar + (This : in out Text_Display); +</pre></td> + </tr> + + <tr> +<td><pre> +void update_line_starts(int pos, int charsInserted, + int charsDeleted, int linesInserted, int linesDeleted, + int *scrolled); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +void update_v_scrollbar(); +</pre></td> +<td><pre> +procedure Update_Vertical_Scrollbar + (This : in out Text_Display); +</pre></td> + </tr> + + <tr> +<td><pre> +int vline_length(int visLineNum) const; +</pre></td> +<td><pre> +function Visible_Line_Length + (This : in Text_Display; + Line : in Natural) + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +int wrap_uses_character(int lineEndPos) const; +</pre></td> +<td><pre> +function Wrap_Uses_Character + (This : in Text_Display; + Line_End : in Natural) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +void wrapped_line_counter(Fl_Text_Buffer *buf, int startPos, + int maxPos, int maxLines, bool startPosIsLineStart, + int styleBufOffset, int *retPos, int *retLines, + int *retLineStart, int *retLineEnd, + bool countLastLineMissingNewLine=true) const; +</pre></td> +<td><pre> +procedure Count_Wrapped_Lines + (This : in Text_Display; + Buffer : in FLTK.Text_Buffers.Text_Buffer; + Start : in Natural; + Max_Position, Max_Lines : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Style_Offset : in Natural; + Finish, Line_Count : out Natural; + End_Count_Line_Start : out Natural; + Last_Line_End : out Natural; + Count_Last_Missing_Newline : in Boolean := True); +</pre></td> + </tr> + + <tr> +<td><pre> +int xy_to_position(int x, int y, int PosType=CHARACTER_POS) const; +</pre></td> +<td><pre> +function XY_To_Position + (This : in Text_Display; + X, Y : in Integer; + Kind : in Position_Kind := Character_Position) + return Natural; +</pre></td> + </tr> + + <tr> +<td><pre> +void xy_to_rowcol(int x, int y, int *row, int *column, + int PosType=CHARACTER_POS) const; +</pre></td> +<td><pre> +procedure XY_To_Row_Column + (This : in Text_Display; + X, Y : in Integer; + Row, Column : out Natural; + Kind : in Position_Kind := Character_Position); +</pre></td> + </tr> + </table> diff --git a/doc/fl_tiled_image.html b/doc/fl_tiled_image.html index 39292b1..49aeca0 100644 --- a/doc/fl_tiled_image.html +++ b/doc/fl_tiled_image.html @@ -150,9 +150,9 @@ virtual void draw(int X, int Y, int W, int H, int cx, int cy); </pre></td> <td><pre> procedure Draw - (This : in Tiled_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer); + (This : in Tiled_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer); </pre></td> </tr> diff --git a/doc/fl_widget.html b/doc/fl_widget.html index 265af2c..0552325 100644 --- a/doc/fl_widget.html +++ b/doc/fl_widget.html @@ -46,11 +46,6 @@ <td>Widget_Callback</td> </tr> - <tr> - <td>Fl_When</td> - <td>Callback_Flag</td> - </tr> - </table> @@ -87,20 +82,51 @@ function Create <table class="function"> + <tr><th colspan="2">Static Functions and Procedures</th></tr> + + <tr> +<td><pre> +static void default_callback(Fl_Widget *cb, void *d); +</pre></td> +<td><pre> +procedure Default_Callback + (This : in out Widget'Class); +</pre></td> + </tr> + + <tr> +<td><pre> +static unsigned int label_shortcut(const char *t); +</pre></td> +<td>Marked as internal use only.</td> + </tr> + + <tr> +<td><pre> +static int test_shortcut(const char *, const bool require_alt=false); +</pre></td> +<td>Marked as internal use only.</td> + </tr> + +</table> + + + +<table class="function"> <tr><th colspan="2">Functions and Procedures</th></tr> <tr> <td><pre> void _clear_fullscreen(); </pre></td> -<td> </td> +<td>Marked as internal use only.</td> </tr> <tr> <td><pre> void _set_fullscreen(); </pre></td> -<td> </td> +<td>Marked as internal use only.</td> </tr> <tr> @@ -161,35 +187,35 @@ procedure Set_Alignment <td><pre> long argument() const; </pre></td> -<td> </td> +<td>Intentionally left unbound.</td> </tr> <tr> <td><pre> void argument(long v); </pre></td> -<td> </td> +<td>Intentionally left unbound.</td> </tr> <tr> <td><pre> virtual class Fl_Gl_Window * as_gl_window(); </pre></td> -<td> </td> +<td>Use runtime tag checks and view conversions instead.</td> </tr> <tr> <td><pre> virtual Fl_Group * as_group(); </pre></td> -<td>Use runtime tag checks and view conversions instead</td> +<td>Use runtime tag checks and view conversions instead.</td> </tr> <tr> <td><pre> virtual Fl_Window * as_window(); </pre></td> -<td>Use runtime tag checks and view conversions instead</td> +<td>Use runtime tag checks and view conversions instead.</td> </tr> <tr> @@ -229,12 +255,13 @@ function Get_Callback <td><pre> void callback(Fl_Callback *cb, void *p); </pre></td> -<td> </td> +<td>Use callback(Fl_Callback *cb) / Set_Callback instead.</td> </tr> <tr> <td><pre> void callback(Fl_Callback *cb); + void callback(Fl_Callback0 *cb); </pre></td> <td><pre> @@ -248,7 +275,7 @@ procedure Set_Callback <td><pre> void callback(Fl_Callback1 *cb, long p=0); </pre></td> -<td> </td> +<td>Use callback(Fl_Callback *cb) / Set_Callback instead.</td> </tr> <tr> @@ -267,9 +294,8 @@ function Has_Changed void clear_active(); </pre></td> <td><pre> -procedure Set_Active - (This : in out Widget; - To : in Boolean); +procedure Clear_Active + (This : in out Widget); </pre></td> </tr> @@ -278,9 +304,8 @@ procedure Set_Active void clear_changed(); </pre></td> <td><pre> -procedure Set_Changed - (This : in out Widget; - To : in Boolean); +procedure Clear_Changed + (This : in out Widget); </pre></td> </tr> @@ -288,7 +313,11 @@ procedure Set_Changed <td><pre> void clear_damage(uchar c=0); </pre></td> -<td> </td> +<td><pre> +procedure Clear_Damage + (This : in out Widget; + Mask : in Damage_Mask := Damage_None); +</pre></td> </tr> <tr> @@ -296,9 +325,8 @@ void clear_damage(uchar c=0); void clear_output(); </pre></td> <td><pre> -procedure Set_Output_Only - (This : in out Widget; - To : in Boolean); +procedure Clear_Output_Only + (This : in out Widget); </pre></td> </tr> @@ -307,9 +335,8 @@ procedure Set_Output_Only void clear_visible(); </pre></td> <td><pre> -procedure Set_Visible - (This : in out Widget; - To : in Boolean); +procedure Clear_Visible + (This : in out Widget); </pre></td> </tr> @@ -318,9 +345,8 @@ procedure Set_Visible void clear_visible_focus(); </pre></td> <td><pre> -procedure Set_Visible_Focus - (This : in out Widget; - To : in Boolean); +procedure Clear_Visible_Focus + (This : in out Widget); </pre></td> </tr> @@ -350,21 +376,25 @@ procedure Set_Background_Color <td><pre> void color(Fl_Color bg, Fl_Color sel); </pre></td> -<td> </td> +<td><pre> +procedure Set_Colors + (This : in out Widget; + Back, Sel : in Color); +</pre></td> </tr> <tr> <td><pre> Fl_Color color2() const; </pre></td> -<td> </td> +<td>Deprecated, use selection_color / Get_Selection_Color instead.</td> </tr> <tr> <td><pre> void color2(unsigned a); </pre></td> -<td> </td> +<td>Deprecated, use selection_color / Set_Selection_Color instead.</td> </tr> <tr> @@ -409,6 +439,10 @@ uchar damage() const; function Is_Damaged (This : in Widget) return Boolean; + +function Get_Damage + (This : in Widget) + return Damage_Mask; </pre></td> </tr> @@ -417,9 +451,9 @@ function Is_Damaged void damage(uchar c); </pre></td> <td><pre> -procedure Set_Damaged +procedure Set_Damage (This : in out Widget; - To : in Boolean); + Mask : in Damage_Mask); </pre></td> </tr> @@ -428,9 +462,9 @@ procedure Set_Damaged void damage(uchar c, int x, int y, int w, int h); </pre></td> <td><pre> -procedure Set_Damaged +procedure Set_Damage (This : in out Widget; - To : in Boolean; + Mask : in Damage_Mask; X, Y, W, H : in Integer); </pre></td> </tr> @@ -439,7 +473,7 @@ procedure Set_Damaged <td><pre> int damage_resize(int, int, int, int); </pre></td> -<td> </td> +<td>Marked as internal use only.</td> </tr> <tr> @@ -455,6 +489,7 @@ procedure Deactivate <tr> <td><pre> Fl_Image * deimage(); + const Fl_Image * deimage() const; </pre></td> <td><pre> @@ -467,6 +502,7 @@ function Get_Inactive_Image <tr> <td><pre> void deimage(Fl_Image *img); + void deimage(Fl_Image &img); </pre></td> <td><pre> @@ -489,15 +525,14 @@ procedure Do_Callback <tr> <td><pre> void do_callback(Fl_Widget *o, long arg); -</pre></td> -<td> </td> - </tr> - <tr> -<td><pre> void do_callback(Fl_Widget *o, void *arg=0); </pre></td> -<td> </td> +<td><pre> +procedure Do_Callback + (This : in Widget; + Using : in out Widget); +</pre></td> </tr> <tr> @@ -516,9 +551,9 @@ void draw_label(int, int, int, int, Fl_Align) const; </pre></td> <td><pre> procedure Draw_Label - (This : in Widget; - X, Y, W, H : in Integer; - Align : in Alignment); + (This : in out Widget; + X, Y, W, H : in Integer; + Align : in Alignment); </pre></td> </tr> @@ -549,12 +584,16 @@ function Handle <td><pre> virtual void hide(); </pre></td> -<td>See void clear_visible();</td> +<td><pre> +procedure Hide + (This : in out Widget); +</pre></td> </tr> <tr> <td><pre> Fl_Image * image(); + const Fl_Image * image() const; </pre></td> <td><pre> @@ -567,6 +606,7 @@ function Get_Image <tr> <td><pre> void image(Fl_Image *img); + void image(Fl_Image &img); </pre></td> <td><pre> @@ -592,7 +632,8 @@ function Inside <td><pre> int is_label_copied() const; </pre></td> -<td> </td> +<td>Due to the marshalling between String and char * this +would always return true, so left unbound.</td> </tr> <tr> @@ -610,14 +651,21 @@ function Get_Label <td><pre> void label(const char *text); </pre></td> -<td>See void copy_label(const char *new_label);</td> +<td>Due to the marshalling between String and char * using +this method would be pointless, so its functionality is +subsumed by copy_label / Set_Label.</td> </tr> <tr> <td><pre> void label(Fl_Labeltype a, const char *b); </pre></td> -<td> </td> +<td><pre> +procedure Set_Label + (This : in out Widget; + Kind : in Label_Kind; + Text : in String); +</pre></td> </tr> <tr> @@ -745,7 +793,7 @@ function Parent <td><pre> void parent(Fl_Group *p); </pre></td> -<td> </td> +<td>Marked as internal use only.</td> </tr> <tr> @@ -783,7 +831,11 @@ procedure Redraw_Label <td><pre> virtual void resize(int x, int y, int w, int h); </pre></td> -<td> </td> +<td><pre> +procedure Resize + (This : in out Widget; + X, Y, W, H : in Integer); +</pre></td> </tr> <tr> @@ -812,42 +864,60 @@ procedure Set_Selection_Color <td><pre> void set_active(); </pre></td> -<td>See void clear_active();</td> +<td><pre> +procedure Set_Active + (This : in out Widget); +</pre></td> </tr> <tr> <td><pre> void set_changed(); </pre></td> -<td>See void clear_changed();</td> +<td><pre> +procedure Set_Changed + (This : in out Widget); +</pre></td> </tr> <tr> <td><pre> void set_output(); </pre></td> -<td>See void clear_output();</td> +<td><pre> +procedure Set_Output_Only + (This : in out Widget); +</pre></td> </tr> <tr> <td><pre> void set_visible(); </pre></td> -<td>See void clear_visible();</td> +<td><pre> +procedure Set_Visible + (This : in out Widget); +</pre></td> </tr> <tr> <td><pre> void set_visible_focus(); </pre></td> -<td>See void clear_visible_focus();</td> +<td><pre> +procedure Set_Visible_Focus + (This : in out Widget); +</pre></td> </tr> <tr> <td><pre> virtual void show(); </pre></td> -<td> </td> +<td><pre> +procedure Show + (This : in out Widget); +</pre></td> </tr> <tr> @@ -887,7 +957,7 @@ function Takes_Events <td><pre> int test_shortcut(); </pre></td> -<td> </td> +<td>Marked as internal use only.</td> </tr> <tr> @@ -905,7 +975,9 @@ function Get_Tooltip <td><pre> void tooltip(const char *text); </pre></td> -<td>See void copy_tooltip(const char *text);</td> +<td>Due to the marshalling between String and char * using +this method would be pointless, so its functionality is +subsumed by copy_tooltip / Set_Tooltip.</td> </tr> <tr> @@ -925,8 +997,8 @@ Fl_Window * top_window_offset(int &xoff, int &yoff) const; </pre></td> <td><pre> function Top_Window_Offset - (This : in Widget; - Offset_X, Offset_Y : out Integer) + (This : in Widget; + Offset_X, Offset_Y : out Integer) return access FLTK.Widgets.Groups.Windows.Window'Class; </pre></td> </tr> @@ -935,35 +1007,41 @@ function Top_Window_Offset <td><pre> uchar type() const; </pre></td> -<td> </td> +<td>See Get_Kind subprograms in Fl_Counter, Fl_Dial, Fl_Input_, +Fl_Pack, Fl_Scroll, Fl_Slider, Fl_Spinner.</td> </tr> <tr> <td><pre> void type(uchar t); </pre></td> -<td> </td> +<td>See Set_Kind subprograms in Fl_Counter, Fl_Dial, Fl_Input_, +Fl_Pack, Fl_Scroll, Fl_Slider, Fl_Spinner.</td> </tr> <tr> <td><pre> int use_accents_menu(); </pre></td> -<td> </td> +<td><pre> +function Uses_Accents_Menu + (This : in Widget) + return Boolean; +</pre></td> </tr> <tr> <td><pre> void * user_data() const; </pre></td> -<td> </td> +<td>Used internally by the binding.</td> </tr> <tr> <td><pre> void user_data(void *v); </pre></td> -<td> </td> +<td>Used internally by the binding.</td> </tr> <tr> @@ -981,7 +1059,11 @@ function Is_Visible <td><pre> void visible_focus(int v); </pre></td> -<td>See void clear_visible_focus();</td> +<td><pre> +procedure Set_Visible_Focus + (This : in out Widget; + To : in Boolean); +</pre></td> </tr> <tr> @@ -1075,6 +1157,151 @@ function Get_Y </table> + +<table class="function"> + <tr><th colspan="2">Protected Functions and Procedures</th></tr> + + <tr> +<td><pre> +void clear_flag(unsigned int c); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +void draw_backdrop() const; +</pre></td> +<td><pre> +procedure Draw_Backdrop + (This : in out Widget); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_box() const; +</pre></td> +<td><pre> +procedure Draw_Box + (This : in out Widget); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_box(Fl_Boxtype t, Fl_Color c) const; +</pre></td> +<td><pre> +procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + Hue : in Color); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_box(Fl_Boxtype t, int x, int y, int w, int h, + Fl_Color c) const; +</pre></td> +<td><pre> +procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Hue : in Color); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_focus(); +</pre></td> +<td><pre> +procedure Draw_Focus + (This : in out Widget); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_focus(Fl_Boxtype t, int x, int y, int w, int h) const; +</pre></td> +<td><pre> +procedure Draw_Focus + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_label() const; +</pre></td> +<td><pre> +procedure Draw_Label + (This : in out Widget); +</pre></td> + </tr> + + <tr> +<td><pre> +void draw_label(int, int, int, int) const; +</pre></td> +<td><pre> +procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer); +</pre></td> + </tr> + + <tr> +<td><pre> +unsigned int flags() const; +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +void h(int v); +</pre></td> +<td>Marked as internal use only.</td> + </tr> + + <tr> +<td><pre> +void set_flag(unsigned int c); +</pre></td> +<td>Intentionally left unbound.</td> + </tr> + + <tr> +<td><pre> +void w(int v); +</pre></td> +<td>Marked as internal use only.</td> + </tr> + + <tr> +<td><pre> +void x(int v); +</pre></td> +<td>Marked as internal use only.</td> + </tr> + + <tr> +<td><pre> +void y(int v); +</pre></td> +<td>Marked as internal use only.</td> + </tr> + +</table> + + </body> </html> diff --git a/doc/fl_window.html b/doc/fl_window.html index 8376cf0..4f246b3 100644 --- a/doc/fl_window.html +++ b/doc/fl_window.html @@ -43,11 +43,6 @@ <tr> <td> </td> - <td>Border_State</td> - </tr> - - <tr> - <td> </td> <td>Modal_State</td> </tr> @@ -155,7 +150,7 @@ function Last_Made_Current <td><pre> static void default_callback(Fl_Window *, void *v); </pre></td> -<td> </td> +<td>Back compatibility only, see default_atclose / Default_Window_Close in FLTK.</td> </tr> <tr> @@ -164,7 +159,7 @@ static void default_icon(const Fl_RGB_Image *); </pre></td> <td><pre> procedure Set_Default_Icon - (Pic : in out FLTK.Images.RGB.RGB_Image'Class); + (Pic : in FLTK.Images.RGB.RGB_Image'Class); </pre></td> </tr> @@ -172,21 +167,32 @@ procedure Set_Default_Icon <td><pre> static void default_icons(const Fl_RGB_Image *[], int); </pre></td> -<td> </td> +<td><pre> +procedure Set_Default_Icons + (Pics : in FLTK.Images.RGB.RGB_Image_Array); + +procedure Reset_Default_Icons; +</pre></td> </tr> <tr> <td><pre> static const char * default_xclass(); </pre></td> -<td> </td> +<td><pre> +function Get_Default_X_Class + return String; +</pre></td> </tr> <tr> <td><pre> static void default_xclass(const char *); </pre></td> -<td> </td> +<td><pre> +procedure Set_Default_X_Class + (Value : in String); +</pre></td> </tr> </table> @@ -200,28 +206,28 @@ static void default_xclass(const char *); <td><pre> virtual Fl_Window * as_window(); </pre></td> -<td>Use view conversion and tag membership tests instead</td> +<td>Use view conversion and tag membership tests instead.</td> </tr> <tr> <td><pre> -void border(int b); +unsigned int border() const; </pre></td> <td><pre> -procedure Set_Border_State - (This : in out Window; - To : in Border_State); +function Has_Border + (This : in Window) + return Boolean; </pre></td> </tr> <tr> <td><pre> -unsigned int border() const; +void border(int b); </pre></td> <td><pre> -function Get_Border_State - (This : in Window) - return Border_State; +procedure Set_Border + (This : in out Window; + Value : in Boolean := True); </pre></td> </tr> @@ -229,7 +235,10 @@ function Get_Border_State <td><pre> void clear_border(); </pre></td> -<td> </td> +<td><pre> +procedure Clear_Border + (This : in out Window); +</pre></td> </tr> <tr> @@ -237,9 +246,8 @@ void clear_border(); void clear_modal_states(); </pre></td> <td><pre> -procedure Set_Modal_State - (This : in out Window; - To : in Modal_State); +procedure Clear_Modal_State + (This : in out Window); </pre></td> </tr> @@ -247,7 +255,11 @@ procedure Set_Modal_State <td><pre> void copy_label(const char *a); </pre></td> -<td> </td> +<td><pre> +procedure Set_Label + (This : in out Window; + Text : in String); +</pre></td> </tr> <tr> @@ -268,7 +280,7 @@ void cursor(const Fl_RGB_Image *, int, int); <td><pre> procedure Set_Cursor (This : in out Window; - Pic : in out FLTK.Images.RGB.RGB_Image'Class; + Pic : in FLTK.Images.RGB.RGB_Image'Class; Hot_X, Hot_Y : in Integer); </pre></td> </tr> @@ -277,7 +289,7 @@ procedure Set_Cursor <td><pre> void cursor(Fl_Cursor c, Fl_Color, Fl_Color=FL_WHITE); </pre></td> -<td> </td> +<td>Use cursor(Fl_Cursor) / Set_Cursor instead.</td> </tr> <tr> @@ -317,17 +329,14 @@ procedure Set_Default_Cursor <td><pre> void default_cursor(Fl_Cursor c, Fl_Color, Fl_Color=FL_WHITE); </pre></td> -<td> </td> +<td>Use default_cursor(Fl_Cursor) / Set_Default_Cursor instead.</td> </tr> <tr> <td><pre> void free_position(); </pre></td> -<td><pre> -procedure Free_Position - (This : in out Window); -</pre></td> +<td>Marked as deprecated.</td> </tr> <tr> @@ -438,7 +447,7 @@ void icon(const Fl_RGB_Image *); <td><pre> procedure Set_Icon (This : in out Window; - Pic : in out FLTK.Images.RGB.RGB_Image'Class); + Pic : in FLTK.Images.RGB.RGB_Image'Class); </pre></td> </tr> @@ -446,14 +455,14 @@ procedure Set_Icon <td><pre> const void * icon() const; </pre></td> -<td> </td> +<td>Marked as deprecated.</td> </tr> <tr> <td><pre> void icon(const void *ic); </pre></td> -<td> </td> +<td>Marked as deprecated.</td> </tr> <tr> @@ -492,7 +501,14 @@ procedure Set_Icon_Label <td><pre> void icons(const Fl_RGB_Image *[], int); </pre></td> -<td> </td> +<td><pre> +procedure Set_Icons + (This : in out Window; + Pics : in FLTK.Images.RGB.RGB_Image_Array); + +procedure Reset_Icons + (This : in out Window); +</pre></td> </tr> <tr> @@ -510,18 +526,20 @@ function Get_Label <td><pre> void label(const char *); </pre></td> -<td><pre> -procedure Set_Label - (This : in out Window; - Text : in String); -</pre></td> +<td>Due to the marshalling between String and char * using +this method would be pointless, so its functionality is +subsumed by copy_label / Set_Label.</td> </tr> <tr> <td><pre> void label(const char *label, const char *iconlabel); </pre></td> -<td> </td> +<td><pre> +procedure Set_Labels + (This : in out Window; + Text, Icon_Text : in String); +</pre></td> </tr> <tr> @@ -538,7 +556,11 @@ procedure Make_Current <td><pre> unsigned int menu_window() const; </pre></td> -<td>Use tag membership tests instead</td> +<td><pre> +function Is_Menu_Window + (This : in Window) + return Boolean; +</pre></td> </tr> <tr> @@ -546,6 +568,15 @@ unsigned int menu_window() const; unsigned int modal() const; </pre></td> <td><pre> +function Is_Modal + (This : in Window) + return Boolean; +</pre></td> + </tr> + + <tr> +<td>Use modal, non_modal as appropriate.</td> +<td><pre> function Get_Modal_State (This : in Window) return Modal_State; @@ -556,7 +587,11 @@ function Get_Modal_State <td><pre> unsigned int non_modal() const; </pre></td> -<td>See unsigned int modal() const;</td> +<td><pre> +function Is_Non_Modal + (This : in Window) + return Boolean; +</pre></td> </tr> <tr> @@ -574,28 +609,47 @@ function Is_Override <td><pre> virtual void resize(int X, int Y, int W, int H); </pre></td> -<td> </td> +<td><pre> +procedure Resize + (This : in out Window; + X, Y, W, H : in Integer); +</pre></td> </tr> <tr> <td><pre> void set_menu_window(); </pre></td> -<td> </td> +<td>Intended for internal use only.</td> </tr> <tr> <td><pre> void set_modal(); </pre></td> -<td>See void clear_modal_states();</td> +<td><pre> +procedure Set_Modal + (This : in out Window); +</pre></td> + </tr> + + <tr> +<td>Use clear_modal_states, set_modal, set_non_modal as appropriate.</td> +<td><pre> +procedure Set_Modal_State + (This : in out Window; + Value : in Modal_State); +</pre></td> </tr> <tr> <td><pre> void set_non_modal(); </pre></td> -<td>See void clear_modal_states();</td> +<td><pre> +procedure Set_Non_Modal + (This : in out Window); +</pre></td> </tr> <tr> @@ -612,7 +666,7 @@ procedure Set_Override <td><pre> void set_tooltip_window(); </pre></td> -<td> </td> +<td>Intended for internal use only.</td> </tr> <tr> @@ -624,7 +678,7 @@ void shape(const Fl_Image &b); <td><pre> procedure Shape (This : in out Window; - Pic : in out FLTK.Images.Image'Class); + Pic : in FLTK.Images.Image'Class); </pre></td> </tr> @@ -677,7 +731,11 @@ procedure Set_Size_Range <td><pre> unsigned int tooltip_window() const; </pre></td> -<td> </td> +<td><pre> +function Is_Tooltip_Window + (This : in Window) + return Boolean; +</pre></td> </tr> <tr> @@ -705,14 +763,22 @@ function Get_X_Root <td><pre> const char * xclass() const; </pre></td> -<td> </td> +<td><pre> +function Get_X_Class + (This : in Window) + return String; +</pre></td> </tr> <tr> <td><pre> void xclass(const char *c); </pre></td> -<td> </td> +<td><pre> +procedure Set_X_Class + (This : in out Window; + Value : in String); +</pre></td> </tr> <tr> @@ -747,28 +813,39 @@ procedure Draw <td><pre> virtual void flush(); </pre></td> -<td> </td> +<td><pre> +procedure Flush + (This : in out Window); +</pre></td> </tr> <tr> <td><pre> int force_position() const; </pre></td> -<td> </td> +<td><pre> +function Is_Position_Forced + (This : in Window) + return Boolean; +</pre></td> </tr> <tr> <td><pre> void force_position(int force); </pre></td> -<td> </td> +<td><pre> +procedure Force_Position + (This : in out Window; + State : in Boolean := True); +</pre></td> </tr> <tr> <td><pre> void free_icons(); </pre></td> -<td> </td> +<td>Intentionally left unbound.</td> </tr> </table> diff --git a/doc/index.html b/doc/index.html index e8f0a45..af2faf1 100644 --- a/doc/index.html +++ b/doc/index.html @@ -16,9 +16,13 @@ <h4>List of C++ headers</h4> <ul> - <li><a href="fl.html">Enumerations</a></li> + <li><a href="enumerations.html">Enumerations</a></li> <li><a href="filename.html">Filename</a></li> <li><a href="fl.html">Fl</a></li> + <li><a href="fl_(fltk-errors).html">Fl (FLTK.Errors)</a></li> + <li><a href="fl_(fltk-events).html">Fl (FLTK.Events)</a></li> + <li><a href="fl_(fltk-screen).html">Fl (FLTK.Screen)</a></li> + <li><a href="fl_(fltk-static).html">Fl (FLTK.Static)</a></li> <li><a href="fl_adjuster.html">Fl_Adjuster</a></li> <li><a href="fl_ask.html">Fl_Ask</a></li> <li><a href="fl_bitmap.html">Fl_Bitmap</a></li> @@ -143,6 +147,7 @@ <ul> <li><a href="fl.html">FLTK</a></li> + <li><a href="enumerations.html">FLTK (Enumerations)</a></li> <li><a href="fl_ask.html">FLTK.Asks</a></li> <li><a href="fl_device.html">FLTK.Devices</a></li> <li><a href="fl_graphics_driver.html">FLTK.Devices.Graphics</a></li> @@ -155,8 +160,8 @@ <li><a href="fl_printer.html">FLTK.Devices.Surface.Paged.Printers</a></li> <li><a href="fl_draw.html">FLTK.Draw</a></li> <li><a href="fl_preferences.html">FLTK.Environment</a></li> - <li><a href="fl.html">FLTK.Errors</a></li> - <li><a href="fl.html">FLTK.Event</a></li> + <li><a href="fl_(fltk-errors).html">FLTK.Errors</a></li> + <li><a href="fl_(fltk-events).html">FLTK.Events</a></li> <li><a href="fl_file_chooser.html">FLTK.File_Choosers</a></li> <li><a href="filename.html">FLTK.Filenames</a></li> <li><a href="fl_help_dialog.html">FLTK.Help_Dialogs</a></li> @@ -175,8 +180,8 @@ <li><a href="fl_tiled_image.html">FLTK.Images.Tiled</a></li> <li><a href="fl_label.html">FLTK.Labels</a></li> <li><a href="fl_menu_item.html">FLTK.Menu_Items</a></li> - <li><a href="fl.html">FLTK.Screen</a></li> - <li><a href="fl.html">FLTK.Static</a></li> + <li><a href="fl_(fltk-screen).html">FLTK.Screen</a></li> + <li><a href="fl_(fltk-static).html">FLTK.Static</a></li> <li><a href="fl_text_buffer.html">FLTK.Text_Buffers</a></li> <li><a href="fl_tooltip.html">FLTK.Tooltips</a></li> <li><a href="fl_widget.html">FLTK.Widgets</a></li> diff --git a/fltkada.gpr b/fltkada.gpr index d09f775..3c493bb 100644 --- a/fltkada.gpr +++ b/fltkada.gpr @@ -10,13 +10,15 @@ library project FLTKAda is for Languages use ("Ada", "C++"); - for Source_Dirs use ("body", "spec"); - for Object_Dir use "obj"; - for Library_Dir use "lib"; + for Source_Dirs use ("body", "spec"); + for Object_Dir use "obj"; + for Library_Dir use "lib"; for Library_Name use "fltkada"; for Library_Kind use "dynamic"; + package Builder renames Common.Builder; package Compiler renames Common.Compiler; + package Binder renames Common.Binder; end FLTKAda; diff --git a/progress.txt b/progress.txt index 6e2c8b8..ec58583 100644 --- a/progress.txt +++ b/progress.txt @@ -1,15 +1,12 @@ - Approximate Progress List - Overall estimate: 85+% - Done: FLTK @@ -130,14 +127,12 @@ FLTK.Widgets.Valuators.Value_Outputs - Partially Done: Fl_Graphics_Driver / FLTK.Devices.Graphics - To-Do: Fl_GDI_Graphics_Driver @@ -168,7 +163,6 @@ Fl_PostScript_File_Device (internal Fl_PostScript_Graphics_Driver) - Never: (C++ binary plugins) (I have no idea how to bind these) @@ -189,7 +183,6 @@ Fl_System_Printer - Bugs to fix: Fl_Wizard draw() method private/protected @@ -209,25 +202,13 @@ possibly this hasn't been noticed because it's only visible to doxygen - -Non-widgets with incomplete APIs: +Incomplete APIs: FLTK FLTK.Devices.Graphics -FLTK.Draw -FLTK.Images (static attributes, draw_empty, Get_Data_Size?) -FLTK.Images.Bitmaps (attributes) -FLTK.Images.Pixmaps (constructor) +FLTK.Images.Pixmaps (unmarshall data access?) FLTK.Images.Shared (images(), compare) -FLTK.Text_Buffers - - - -Widgets with incomplete APIs: - -Widgets -Widgets.Groups.Scrolls (attributes, resize, type, protected) -Widgets.Groups.Text_Displays -Widgets.Groups.Windows +FLTK.Text_Buffers (a few functions, protected stuff, ensure buffer is 1-indexed) +FLTK.Widgets.Groups.Text_Displays (ensure text buffer is 1-indexed) diff --git a/proj/common.gpr b/proj/common.gpr index 64c4dc1..0da596c 100644 --- a/proj/common.gpr +++ b/proj/common.gpr @@ -3,12 +3,101 @@ abstract project Common is + type Build_Kind is ("release", "debug"); + + Ver : Build_Kind := external ("build", "release"); + + + package Builder is + for Default_Switches ("Ada") use ("-j4", "-m"); + for Global_Compilation_Switches ("Ada") use ("-shared"); + + case Ver is + + when "release" => + null; + + when "debug" => + for Default_Switches ("Ada") use Builder'Default_Switches ("Ada") & "-g"; + + end case; + end Builder; + + + Ada_Common := + ("-gnaty" + & "4" -- indentation + & "a" -- attribute casing + & "A" -- array attribute indices + & "b" -- blanks at end of lines + & "c" -- two space comments + & "e" -- end/exit labels + & "f" -- no form feeds or vertical tabs + & "h" -- no horizontal tabs + & "i" -- if/then layout + & "k" -- keyword casing + & "l" -- reference manual layout + & "M100" -- max line length + & "n" -- package Standard casing + & "p" -- pragma casing + & "r" -- identifier casing + & "t", -- token separation + "-gnatw" + & "a" -- various warning modes + & "F" -- don't check for unreferenced formal parameters + & "J" -- don't check for obsolescent feature use + & "U"); -- don't check for unused entities + + CPP_Common := + ("-Wall", + "-Werror", + "-Wextra", + "-Wpedantic", + "-std=c++11"); + package Compiler is - for Default_Switches ("Ada") use ("-gnaty4aAbcefhiklM100nprt"); - for Default_Switches("C++") use ("-Wall","-Wextra","-std=c++11"); + case Ver is + + when "release" => + for Default_Switches ("Ada") use Ada_Common & "-O3" & "-gnatn"; + for Default_Switches ("C++") use CPP_Common & "-O3"; + + when "debug" => + for Default_Switches ("Ada") use Ada_Common & "-O0" & "-gnata" & "-gnato" & "-g"; + for Default_Switches ("C++") use CPP_Common & "-O0"; + + end case; end Compiler; + package Binder is + for Default_Switches ("Ada") use ("-shared"); + + case Ver is + + when "release" => + null; + + when "debug" => + for Default_Switches ("Ada") use Binder'Default_Switches ("Ada") & "-Es"; + + end case; + end Binder; + + + package Linker is + case Ver is + + when "release" => + null; + + when "debug" => + for Default_Switches ("Ada") use ("-g"); + + end case; + end Linker; + + end Common; diff --git a/readme.md b/readme.md new file mode 100644 index 0000000..ce1da36 --- /dev/null +++ b/readme.md @@ -0,0 +1,87 @@ + +## FLTKAda + +This is a thick, high level binding for the [FLTK](https://www.fltk.org/) +graphical widget library to the Ada programming language using only the +standard C FFI. + +Types have been marshalled. Class hierarchies have been mapped to equivalent +packages and tagged records. Controlled types have been used to make allocation +and deallocation automatic for objects. Overrideable methods called from the +FLTK event loop have been thunked. Iterators have been implemented. And a few +convenience subprograms have been provided. + +Some of the FLTK test and example programs have also been ported. + +For documentation on what C++ function, method, or class corresponds to what +Ada function, procedure, or package, see `index.html` in the `doc` +subdirectory. + + + +#### Dependencies + +Build time: +<ul> + <li>FLTK</li> + <li>g++</li> + <li>GNAT</li> + <li>GPRbuild</li> +</ul> + +Run time: +<ul> + <li>FLTK</li> +</ul> + +It may be possible to use alternate compilation tooling but this has not been +tested. If attempted, some manual modification of project files may be +necessary. + +Note that at this time only FLTK 1.3 is supported. + + + +#### Building and Installation + +This repository is written to use the GNAT Project Manager build tools. To +build, use the following command + +`gprbuild fltkada.gpr` + +There is a single build switch of `-Xbuild` which can have a value of `release` +(the default) or `debug`. The other project files in the main directory can be +used with similar build commands to build tests, examples, and tools. + +To install the binding, use + +`gprinstall -p -m fltkada.gpr` + +For further information on the build tools, consult the +[GPRbuild docs](https://docs.adacore.com/gprbuild-docs/html/gprbuild_ug.html). + + + +#### Technical Notes + +As part of its normal operation, FLTK calls a Widget's Draw and Handle methods +from its main loop to deal with draw and input events. Since it's another part +of the program that is invoking them, even if it's a part the programmer has no +direct control over, this binding is set up so that if you override Draw or +Handle the behaviour will change. + +On the other hand, something like the Push method in tabbed groups is usually +invoked from within that same tabbed group widget's Handle method. Therefore, +keeping consistency with Ada semantics, overriding the Push method will NOT +change the behaviour of the corresponding Handle method. You must also override +Handle. + + + +#### Credits and Licensing + +Written by Jedidiah Barber. + +Released into the public domain. For details see `unlicense.txt`. + + diff --git a/readme.txt b/readme.txt deleted file mode 100644 index 67d4b40..0000000 --- a/readme.txt +++ /dev/null @@ -1,61 +0,0 @@ - - -FLTK Binding for the Ada Programming Language -============================================= - - - - -This is a thick binding. In particular, dynamic allocation of FLTK objects is -not necessary as in Ada they can be placed on the stack and automatically cleaned -up. Ada 2012 iterators have also been made available for the Fl_Group and Fl_Menu -bindings. - -For documentation on what C++ method or class corresponds to what Ada function, -procedure, or package, see the /doc/index.html file. - - - - -Dependencies: - - GNAT - FLTK - - - - -How to build/install: - -This repository is written to use the GNAT Project Manager build tools. To build -this FLTK-Ada binding for testing purposes, use the following command - - gprbuild fltkada.gpr - -And to install the binding, use - - gprinstall -p -m fltkada.gpr - - - - -For further information on the build tools, consult - - https://docs.adacore.com/gprbuild-docs/html/gprbuild_ug.html - - - - -A technical note on callbacks and overriding: - -As part of its normal operation, FLTK calls a Widget's Draw and Handle methods from its -main loop to deal with draw and input events. Since it's another part of the program -that is invoking them, even if it's a part the programmer has no direct control over, -this binding is set up so that if you override Draw or Handle, the behaviour will change. - -On the other hand, something like the Push method in tabbed groups is usually invoked -from within that same tabbed group widget's Handle method. Therefore, keeping consistency -with Ada semantics, overriding the Push method will NOT change the behaviour of the -corresponding Handle method. You must also override Handle. - - diff --git a/spec/fltk-asks.ads b/spec/fltk-asks.ads index fc6e150..23e2076 100644 --- a/spec/fltk-asks.ads +++ b/spec/fltk-asks.ads @@ -30,7 +30,7 @@ package FLTK.Asks is type RGB_Float is new Long_Float range 0.0 .. 1.0; - type RGB_Int is mod 256; + subtype RGB_Int is Color_Component; type File_Chooser_Callback is access procedure (Item : in String); @@ -38,6 +38,8 @@ package FLTK.Asks is + -- Static Attributes -- + function Get_Cancel_String return String; @@ -71,6 +73,8 @@ package FLTK.Asks is + -- Simple Messages -- + procedure Alert (Message : String); @@ -117,6 +121,8 @@ package FLTK.Asks is + -- Choosers -- + function Color_Chooser (Title : in String; R, G, B : in out RGB_Float; @@ -131,6 +137,10 @@ package FLTK.Asks is FLTK.Widgets.Groups.Color_Choosers.RGB) return Confirm_Result; + function Show_Colormap + (Old_Hue : in Color) + return Color; + function Dir_Chooser (Message, Default : in String; Relative : in Boolean := False) @@ -150,6 +160,8 @@ package FLTK.Asks is + -- Settings -- + function Get_Message_Hotspot return Boolean; @@ -160,6 +172,10 @@ package FLTK.Asks is (Font : in Font_Kind; Size : in Font_Size); + -- Technically the returned Box should have a parent, but you can't access + -- it for annoying technical reasons relating to how the Choice functions + -- work in C++. You shouldn't be trying to poke at those internals anyway. + -- Just stick to calling subprograms to change stuff about this Box. function Get_Message_Icon return FLTK.Widgets.Boxes.Box_Reference; @@ -195,6 +211,7 @@ private pragma Inline (Password); pragma Inline (Color_Chooser); + pragma Inline (Show_Colormap); pragma Inline (Dir_Chooser); pragma Inline (File_Chooser); pragma Inline (Set_File_Chooser_Callback); @@ -218,3 +235,4 @@ private end FLTK.Asks; + diff --git a/spec/fltk-devices-graphics.ads b/spec/fltk-devices-graphics.ads index f9d1a7c..2a1761f 100644 --- a/spec/fltk-devices-graphics.ads +++ b/spec/fltk-devices-graphics.ads @@ -20,6 +20,8 @@ package FLTK.Devices.Graphics is + -- Color -- + function Get_Color (This : in Graphics_Driver) return Color; @@ -27,6 +29,8 @@ package FLTK.Devices.Graphics is + -- Text -- + function Get_Text_Descent (This : in Graphics_Driver) return Integer; @@ -61,6 +65,8 @@ package FLTK.Devices.Graphics is + -- Images -- + procedure Draw_Scaled_Image (This : in Graphics_Driver; Img : in FLTK.Images.Image'Class; @@ -73,11 +79,8 @@ private type Graphics_Driver is new Device with null record; - - pragma Inline (Get_Color); - pragma Inline (Get_Text_Descent); pragma Inline (Get_Line_Height); pragma Inline (Get_Width); @@ -85,9 +88,9 @@ private pragma Inline (Get_Font_Size); pragma Inline (Set_Font); - pragma Inline (Draw_Scaled_Image); end FLTK.Devices.Graphics; + diff --git a/spec/fltk-devices-surface-copy.ads b/spec/fltk-devices-surface-copy.ads index 41d331b..1bc2d93 100644 --- a/spec/fltk-devices-surface-copy.ads +++ b/spec/fltk-devices-surface-copy.ads @@ -38,6 +38,8 @@ package FLTK.Devices.Surface.Copy is + -- Dimensions -- + function Get_W (This : in Copy_Surface) return Integer; @@ -49,6 +51,8 @@ package FLTK.Devices.Surface.Copy is + -- Drawing -- + procedure Draw_Widget (This : in out Copy_Surface; Item : in FLTK.Widgets.Widget'Class; @@ -62,6 +66,8 @@ package FLTK.Devices.Surface.Copy is + -- Surfaces -- + procedure Set_Current (This : in out Copy_Surface); diff --git a/spec/fltk-devices-surface-display.ads b/spec/fltk-devices-surface-display.ads index b581be7..3faaa22 100644 --- a/spec/fltk-devices-surface-display.ads +++ b/spec/fltk-devices-surface-display.ads @@ -32,6 +32,8 @@ package FLTK.Devices.Surface.Display is + -- Displays -- + function Get_Platform_Display return Display_Device_Reference; diff --git a/spec/fltk-devices-surface-image.ads b/spec/fltk-devices-surface-image.ads index 961a9b2..7711771 100644 --- a/spec/fltk-devices-surface-image.ads +++ b/spec/fltk-devices-surface-image.ads @@ -34,6 +34,8 @@ package FLTK.Devices.Surface.Image is + -- Resolution -- + function Is_Highres (This : in Image_Surface) return Boolean; @@ -41,6 +43,8 @@ package FLTK.Devices.Surface.Image is + -- Drawing -- + procedure Draw_Widget (This : in out Image_Surface; Item : in FLTK.Widgets.Widget'Class; @@ -54,6 +58,8 @@ package FLTK.Devices.Surface.Image is + -- Images -- + function Get_Image (This : in Image_Surface) return FLTK.Images.RGB.RGB_Image; @@ -65,6 +71,8 @@ package FLTK.Devices.Surface.Image is + -- Surfaces -- + procedure Set_Current (This : in out Image_Surface); diff --git a/spec/fltk-devices-surface-paged-postscript.ads b/spec/fltk-devices-surface-paged-postscript.ads index a7ea51c..22e2eca 100644 --- a/spec/fltk-devices-surface-paged-postscript.ads +++ b/spec/fltk-devices-surface-paged-postscript.ads @@ -66,6 +66,8 @@ package FLTK.Devices.Surface.Paged.Postscript is + -- Static Attributes -- + function Get_File_Chooser_Title return String; @@ -75,6 +77,8 @@ package FLTK.Devices.Surface.Paged.Postscript is + -- Driver -- + -- Not currently implemented, -- will return a Postscript_Graphics_Driver when done. function Get_Postscript_Driver @@ -84,6 +88,8 @@ package FLTK.Devices.Surface.Paged.Postscript is + -- Job Control -- + -- Docs say don't use this version. procedure Start_Job (This : in out Postscript_File_Device; @@ -121,6 +127,8 @@ package FLTK.Devices.Surface.Paged.Postscript is + -- Spacing and Orientation -- + procedure Get_Margins (This : in Postscript_File_Device; Left, Top, Right, Bottom : out Integer); diff --git a/spec/fltk-devices-surface-paged-printers.ads b/spec/fltk-devices-surface-paged-printers.ads index c0bc34e..b9c0169 100644 --- a/spec/fltk-devices-surface-paged-printers.ads +++ b/spec/fltk-devices-surface-paged-printers.ads @@ -42,6 +42,8 @@ package FLTK.Devices.Surface.Paged.Printers is + -- Static Attributes -- + function Get_Dialog_Title return String; @@ -159,6 +161,8 @@ package FLTK.Devices.Surface.Paged.Printers is + -- Driver -- + -- Not currently implemented function Get_Original_Driver (This : in out Printer) @@ -167,6 +171,8 @@ package FLTK.Devices.Surface.Paged.Printers is + -- Job Control -- + procedure Start_Job (This : in out Printer; Count : in Natural := 0); @@ -188,6 +194,8 @@ package FLTK.Devices.Surface.Paged.Printers is + -- Spacing and Orientation -- + procedure Get_Margins (This : in Printer; Left, Top, Right, Bottom : out Integer); @@ -226,6 +234,8 @@ package FLTK.Devices.Surface.Paged.Printers is + -- Printing -- + procedure Print_Widget (This : in out Printer; Item : in FLTK.Widgets.Widget'Class; @@ -240,6 +250,8 @@ package FLTK.Devices.Surface.Paged.Printers is + -- Printer -- + procedure Set_Current (This : in out Printer); diff --git a/spec/fltk-devices-surface-paged.ads b/spec/fltk-devices-surface-paged.ads index b445c62..cb820e6 100644 --- a/spec/fltk-devices-surface-paged.ads +++ b/spec/fltk-devices-surface-paged.ads @@ -75,6 +75,8 @@ package FLTK.Devices.Surface.Paged is + -- Job Control -- + procedure Start_Job (This : in out Paged_Device; Count : in Natural := 0); @@ -96,6 +98,8 @@ package FLTK.Devices.Surface.Paged is + -- Spacing and Orientation -- + procedure Get_Margins (This : in Paged_Device; Left, Top, Right, Bottom : out Integer); @@ -134,6 +138,8 @@ package FLTK.Devices.Surface.Paged is + -- Printing -- + procedure Print_Widget (This : in out Paged_Device; Item : in FLTK.Widgets.Widget'Class; diff --git a/spec/fltk-devices-surface.ads b/spec/fltk-devices-surface.ads index f70d1e8..7aa9e87 100644 --- a/spec/fltk-devices-surface.ads +++ b/spec/fltk-devices-surface.ads @@ -31,6 +31,8 @@ package FLTK.Devices.Surface is + -- Surfaces -- + function Get_Current return Surface_Device_Reference; @@ -43,6 +45,8 @@ package FLTK.Devices.Surface is + -- Drivers -- + function Has_Driver (This : in Surface_Device) return Boolean; diff --git a/spec/fltk-devices.ads b/spec/fltk-devices.ads index d9ce5b1..6e9873f 100644 --- a/spec/fltk-devices.ads +++ b/spec/fltk-devices.ads @@ -21,3 +21,4 @@ private end FLTK.Devices; + diff --git a/spec/fltk-draw.ads b/spec/fltk-draw.ads index cedd4da..a2c66f3 100644 --- a/spec/fltk-draw.ads +++ b/spec/fltk-draw.ads @@ -6,17 +6,14 @@ with - FLTK.Images, + Ada.Strings.Unbounded, + FLTK.Images.Pixmaps, FLTK.Widgets.Groups.Windows; package FLTK.Draw is - -------------------------- - -- Types and Constants -- - -------------------------- - type Line_Kind is (Solid_Line, Dash_Line, @@ -66,9 +63,7 @@ package FLTK.Draw is - ------------------------ -- No Documentation -- - ------------------------ procedure Reset_Spot; @@ -89,9 +84,7 @@ package FLTK.Draw is - --------------- -- Utility -- - --------------- function Can_Do_Alpha_Blending return Boolean; @@ -103,9 +96,7 @@ package FLTK.Draw is - -------------------------- -- Charset Conversion -- - -------------------------- function Latin1_To_Local (From : in String) @@ -126,9 +117,7 @@ package FLTK.Draw is - ---------------- -- Clipping -- - ---------------- function Clip_Box (X, Y, W, H : in Integer; @@ -151,9 +140,7 @@ package FLTK.Draw is - --------------- -- Overlay -- - --------------- procedure Overlay_Clear; @@ -163,9 +150,7 @@ package FLTK.Draw is - ---------------- -- Settings -- - ---------------- function Get_Color return Color; @@ -215,9 +200,7 @@ package FLTK.Draw is - ------------------------- -- Matrix Operations -- - ------------------------- procedure Mult_Matrix (A, B, C, D, X, Y : in Long_Float); @@ -263,17 +246,18 @@ package FLTK.Draw is - --------------------- -- Image Drawing -- - --------------------- procedure Draw_Image (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); + Flip_Vertical : in Boolean := False) + with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (W) * Size_Type (H) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (H)); procedure Draw_Image (X, Y, W, H : in Integer; @@ -284,30 +268,44 @@ package 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); + Flip_Vertical : Boolean := False) + with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (W) * Size_Type (H) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (H)); procedure Draw_Image_Mono (X, Y, W, H : in Integer; Callback : in Image_Draw_Function; Depth : in Positive := 1); + procedure Draw_Pixmap + (Values : in FLTK.Images.Pixmaps.Header; + Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; + Pixels : in FLTK.Images.Pixmaps.Pixmap_Data; + X, Y : in Integer; + Tone : in Color := Grey0_Color) + with Pre => + Colors'Length = Values.Colors and + Pixels'Length (1) = Values.Height and + (for all Definition of Colors => + Ada.Strings.Unbounded.Length (Definition.Name) = Values.Per_Pixel) and + Pixels'Length (2) = Values.Width * Values.Per_Pixel; + function Read_Image (X, Y, W, H : in Integer; Alpha : in Integer := 0) return Color_Component_Array with Post => - (if Alpha = 0 - then Read_Image'Result'Length = W * H * 3 - else Read_Image'Result'Length = W * H * 4); + (if Alpha = 0 + then Read_Image'Result'Length = Size_Type (W) * Size_Type (H) * 3 + else Read_Image'Result'Length = Size_Type (W) * Size_Type (H) * 4); - ----------------------- -- Special Drawing -- - ----------------------- procedure Add_Symbol (Text : in String; @@ -381,6 +379,19 @@ package FLTK.Draw is (Text : in String; DX, DY, W, H : out Integer); + -- Last is the index of the last character processed in Text which + -- would normally be one before the index of the char pointed at by + -- the return value in the C++ version. Instead, the return value + -- here is the processed text buffer. + function Expand_Text + (Text : in String; + Max_Width : in Long_Float; + Width : out Long_Float; + Last : out Natural; + Wrap : in Boolean; + Symbols : in Boolean := False) + return String; + function Width (Text : in String) return Long_Float; @@ -400,9 +411,7 @@ package FLTK.Draw is - ---------------------- -- Manual Drawing -- - ---------------------- procedure Begin_Complex_Polygon; procedure Begin_Line; @@ -524,32 +533,53 @@ private pragma Convention (C, Symbol_Draw_Function); + pragma Import (C, Reset_Spot, "fl_draw_reset_spot"); + + pragma Import (C, Pop_Clip, "fl_draw_pop_clip"); + pragma Import (C, Push_No_Clip, "fl_draw_push_no_clip"); + pragma Import (C, Restore_Clip, "fl_draw_restore_clip"); + + pragma Import (C, Overlay_Clear, "fl_draw_overlay_clear"); + + pragma Import (C, Pop_Matrix, "fl_draw_pop_matrix"); + pragma Import (C, Push_Matrix, "fl_draw_push_matrix"); + + pragma Import (C, Begin_Complex_Polygon, "fl_draw_begin_complex_polygon"); + pragma Import (C, Begin_Line, "fl_draw_begin_line"); + pragma Import (C, Begin_Loop, "fl_draw_begin_loop"); + pragma Import (C, Begin_Points, "fl_draw_begin_points"); + pragma Import (C, Begin_Polygon, "fl_draw_begin_polygon"); + + pragma Import (C, Gap, "fl_draw_gap"); + + pragma Import (C, End_Complex_Polygon, "fl_draw_end_complex_polygon"); + pragma Import (C, End_Line, "fl_draw_end_line"); + pragma Import (C, End_Loop, "fl_draw_end_loop"); + pragma Import (C, End_Points, "fl_draw_end_points"); + pragma Import (C, End_Polygon, "fl_draw_end_polygon"); + + pragma Inline (Reset_Spot); pragma Inline (Set_Spot); pragma Inline (Set_Status); - pragma Inline (Can_Do_Alpha_Blending); pragma Inline (Shortcut_Label); - pragma Inline (Latin1_To_Local); pragma Inline (Local_To_Latin1); pragma Inline (Mac_Roman_To_Local); pragma Inline (Local_To_Mac_Roman); - pragma Inline (Clip_Intersects); pragma Inline (Pop_Clip); pragma Inline (Push_Clip); pragma Inline (Push_No_Clip); pragma Inline (Restore_Clip); - pragma Inline (Overlay_Clear); pragma Inline (Overlay_Rect); - pragma Inline (Get_Color); pragma Inline (Set_Color); pragma Inline (Get_Font); @@ -559,7 +589,6 @@ private pragma Inline (Font_Descent); pragma Inline (Font_Height); - pragma Inline (Mult_Matrix); pragma Inline (Pop_Matrix); pragma Inline (Push_Matrix); @@ -573,7 +602,6 @@ private pragma Inline (Translate); pragma Inline (Vertex); - pragma Inline (Add_Symbol); pragma Inline (Draw_Text); pragma Inline (Draw_Text_Right_Left); @@ -584,14 +612,12 @@ private pragma Inline (Text_Extents); pragma Inline (Width); - pragma Inline (Begin_Complex_Polygon); pragma Inline (Begin_Line); pragma Inline (Begin_Loop); pragma Inline (Begin_Points); pragma Inline (Begin_Polygon); - pragma Inline (Arc); pragma Inline (Chord); pragma Inline (Circle); @@ -608,7 +634,6 @@ private pragma Inline (Ecks_Why_Line); pragma Inline (Why_Ecks_Line); - pragma Inline (End_Complex_Polygon); pragma Inline (End_Line); pragma Inline (End_Loop); diff --git a/spec/fltk-environment.ads b/spec/fltk-environment.ads index 4bb807b..9ab7f7c 100644 --- a/spec/fltk-environment.ads +++ b/spec/fltk-environment.ads @@ -36,12 +36,6 @@ package FLTK.Environment is - function New_UUID - return String; - - - - package Forge is function From_Filesystem @@ -76,6 +70,16 @@ package FLTK.Environment is + -- Static -- + + function New_UUID + return String; + + + + + -- Disk Activity -- + procedure Flush (This : in Database); @@ -86,6 +90,8 @@ package FLTK.Environment is + -- Deletion -- + procedure Delete_Entry (This : in out Pref_Group; Key : in String) @@ -112,6 +118,8 @@ package FLTK.Environment is + -- Key Values -- + function Number_Of_Entries (This : in Pref_Group) return Natural; @@ -135,6 +143,8 @@ package FLTK.Environment is + -- Groups -- + function Number_Of_Groups (This : in Pref_Group) return Natural; @@ -153,6 +163,8 @@ package FLTK.Environment is + -- Names -- + function At_Name (This : in Pref_Group) return String; @@ -164,6 +176,8 @@ package FLTK.Environment is + -- Retrieval -- + function Get (This : in Pref_Group; Key : in String) @@ -238,6 +252,8 @@ package FLTK.Environment is + -- Storage -- + procedure Set (This : in out Pref_Group; Key : in String; @@ -301,7 +317,6 @@ private pragma Convention (C, Binary_Data); - pragma Pack (Binary_Data); for Binary_Data'Component_Size use Interfaces.C.CHAR_BIT; diff --git a/spec/fltk-event.ads b/spec/fltk-events.ads index 3b0dec9..5dbc573 100644 --- a/spec/fltk-event.ads +++ b/spec/fltk-events.ads @@ -6,49 +6,79 @@ with - FLTK.Widgets.Groups.Windows; + FLTK.Widgets.Groups.Windows, + System; private with - Ada.Containers.Vectors, + Ada.Finalization, System.Address_To_Access_Conversions; -package FLTK.Event is +package FLTK.Events is type Event_Handler is access function (Event : in Event_Kind) return Event_Outcome; - -- type Event_Dispatch is access function - -- (Event : in Event_Kind; - -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) - -- return Event_Outcome; + type Event_Dispatch is access function + (Event : in Event_Kind; + Win : access FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + type System_Event is new System.Address; + + type System_Handler is access function + (Event : in System_Event) + return Event_Outcome; + + -- Handlers -- + procedure Add_Handler - (Func : in Event_Handler); + (Func : in not null Event_Handler); procedure Remove_Handler - (Func : in Event_Handler); + (Func : in not null Event_Handler); + + procedure Add_System_Handler + (Func : in not null System_Handler); - -- function Get_Dispatch - -- return Event_Dispatch; + procedure Remove_System_Handler + (Func : in not null System_Handler); - -- procedure Set_Dispatch - -- (Func : in Event_Dispatch); - -- function Default_Dispatch - -- (Event : in Event_Kind; - -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) - -- return Event_Outcome; + -- Dispatch -- + + function Get_Dispatch + return Event_Dispatch; + + -- Any Event_Dispatch function set must call Handle + -- if you want the Event to actually be acknowledged. + procedure Set_Dispatch + (Func : in Event_Dispatch); + + function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + + -- Receiving -- + function Get_Grab return access FLTK.Widgets.Groups.Windows.Window'Class; @@ -75,9 +105,28 @@ package FLTK.Event is procedure Set_Focus (To : in FLTK.Widgets.Widget'Class); + function Has_Visible_Focus + return Boolean; + + procedure Set_Visible_Focus + (To : in Boolean); + + + + + -- Clipboard -- + + function Clipboard_Text + return String; + + function Clipboard_Kind + return String; + + -- Multikey -- + function Compose (Del : out Natural) return Boolean; @@ -90,15 +139,23 @@ package FLTK.Event is function Text_Length return Natural; + function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean; + + + -- Modifiers -- function Last return Event_Kind; + -- Focuses on keyboard modifiers only, not mouse buttons function Last_Modifier return Modifier; + -- Focuses on keyboard modifiers only, not mouse buttons function Last_Modifier (Had : in Modifier) return Boolean; @@ -106,6 +163,8 @@ package FLTK.Event is + -- Mouse -- + function Mouse_X return Integer; @@ -130,9 +189,18 @@ package FLTK.Event is function Is_Click return Boolean; + procedure Clear_Click; + function Is_Multi_Click return Boolean; + -- Returns the actual number of clicks. + -- So no clicks is 0, a single click is 1, a double click is 2, etc. + function Get_Clicks + return Natural; + + -- Will set the actual number of clicks. + -- This means setting it to 0 will make Is_Click return False. procedure Set_Clicks (To : in Natural); @@ -148,6 +216,19 @@ package FLTK.Event is function Mouse_Right return Boolean; + function Mouse_Back + return Boolean; + + function Mouse_Forward + return Boolean; + + procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean); + + function Is_Inside + (Child : in FLTK.Widgets.Widget'Class) + return Boolean; + function Is_Inside (X, Y, W, H : in Integer) return Boolean; @@ -155,6 +236,8 @@ package FLTK.Event is + -- Keyboard -- + function Last_Key return Keypress; @@ -191,12 +274,7 @@ private (FLTK.Widgets.Groups.Windows.Window'Class); - package Handler_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, Element_Type => Event_Handler); - - - Handlers : Handler_Vectors.Vector := Handler_Vectors.Empty_Vector; - -- Current_Dispatch : Event_Dispatch := null; + Current_Dispatch : Event_Dispatch := null; function fl_widget_get_user_data @@ -206,14 +284,18 @@ private pragma Inline (fl_widget_get_user_data); + pragma Import (C, Compose_Reset, "fl_event_compose_reset"); pragma Inline (Add_Handler); pragma Inline (Remove_Handler); - -- pragma Inline (Get_Dispatch); - -- pragma Inline (Set_Dispatch); - -- pragma Inline (Default_Dispatch); + pragma Inline (Add_System_Handler); + pragma Inline (Remove_System_Handler); + pragma Inline (Get_Dispatch); + pragma Inline (Set_Dispatch); + pragma Inline (Handle_Dispatch); + pragma Inline (Handle); pragma Inline (Get_Grab); pragma Inline (Set_Grab); @@ -224,18 +306,21 @@ private pragma Inline (Set_Below_Mouse); pragma Inline (Get_Focus); pragma Inline (Set_Focus); + pragma Inline (Has_Visible_Focus); + pragma Inline (Set_Visible_Focus); + pragma Inline (Clipboard_Text); + pragma Inline (Clipboard_Kind); pragma Inline (Compose); pragma Inline (Compose_Reset); pragma Inline (Text); pragma Inline (Text_Length); - + pragma Inline (Test_Shortcut); pragma Inline (Last); pragma Inline (Last_Modifier); - pragma Inline (Mouse_X); pragma Inline (Mouse_X_Root); pragma Inline (Mouse_Y); @@ -244,15 +329,17 @@ private pragma Inline (Mouse_DY); pragma Inline (Get_Mouse); pragma Inline (Is_Click); + pragma Inline (Clear_Click); pragma Inline (Is_Multi_Click); + pragma Inline (Get_Clicks); pragma Inline (Set_Clicks); - pragma Inline (Last_Button); pragma Inline (Mouse_Left); pragma Inline (Mouse_Middle); pragma Inline (Mouse_Right); + pragma Inline (Mouse_Back); + pragma Inline (Mouse_Forward); pragma Inline (Is_Inside); - pragma Inline (Last_Key); pragma Inline (Original_Last_Key); pragma Inline (Pressed_During); @@ -263,5 +350,15 @@ private pragma Inline (Key_Shift); -end FLTK.Event; + -- Needed to deregister the handlers + type FLTK_Events_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out FLTK_Events_Final_Controller); + + Cleanup : FLTK_Events_Final_Controller; + + +end FLTK.Events; + diff --git a/spec/fltk-file_choosers.ads b/spec/fltk-file_choosers.ads index 927ae04..3445d4f 100644 --- a/spec/fltk-file_choosers.ads +++ b/spec/fltk-file_choosers.ads @@ -47,12 +47,16 @@ package FLTK.File_Choosers is + -- Sorting -- + Sort_Method : not null FLTK.Filenames.Compare_Function := FLTK.Filenames.Numeric_Sort'Access; + -- Buttons -- + function New_Button (This : in out File_Chooser) return FLTK.Widgets.Buttons.Button_Reference; @@ -68,6 +72,8 @@ package FLTK.File_Choosers is + -- Static Labels -- + function Get_Add_Favorites_Label return String; @@ -155,6 +161,8 @@ package FLTK.File_Choosers is + -- Callback and Extra -- + procedure Add_Extra (This : in out File_Chooser; Item : in out Widgets.Widget'Class); @@ -174,6 +182,8 @@ package FLTK.File_Choosers is + -- Settings -- + function Get_Background_Color (This : in File_Chooser) return Color; @@ -249,6 +259,8 @@ package FLTK.File_Choosers is + -- File Selection -- + function Number_Selected (This : in File_Chooser) return Natural; @@ -296,6 +308,8 @@ package FLTK.File_Choosers is + -- Visibility -- + procedure Show (This : in out File_Chooser); diff --git a/spec/fltk-filenames.ads b/spec/fltk-filenames.ads index 2872b8c..5d9b5ff 100644 --- a/spec/fltk-filenames.ads +++ b/spec/fltk-filenames.ads @@ -54,6 +54,8 @@ package FLTK.Filenames is + -- Uniform Resource Identifiers -- + function Decode_URI (URI : in Path_String) return Path_String; @@ -64,6 +66,8 @@ package FLTK.Filenames is + -- Pathnames -- + function Absolute (Name : in Path_String) return Path_String; @@ -94,6 +98,8 @@ package FLTK.Filenames is + -- Filenames -- + function Base_Name (Name : in Path_String) return Path_String; @@ -110,6 +116,8 @@ package FLTK.Filenames is + -- Directories -- + function Is_Directory (Name : in Path_String) return Boolean; @@ -122,6 +130,8 @@ package FLTK.Filenames is + -- Patterns -- + function Match (Input, Pattern : in String) return Boolean; diff --git a/spec/fltk-help_dialogs.ads b/spec/fltk-help_dialogs.ads index 655e357..fa0b94b 100644 --- a/spec/fltk-help_dialogs.ads +++ b/spec/fltk-help_dialogs.ads @@ -24,15 +24,13 @@ package FLTK.Help_Dialogs is (X, Y, W, H : in Integer) return Help_Dialog; - private - - pragma Inline (Create); - end Forge; + -- Visibility -- + procedure Show (This : in out Help_Dialog); @@ -49,6 +47,8 @@ package FLTK.Help_Dialogs is + -- Topline -- + procedure Set_Topline_Number (This : in out Help_Dialog; Line : in Positive); @@ -60,7 +60,9 @@ package FLTK.Help_Dialogs is - -- Name here can be either a ftp/http/https/ipp/mailto/news URL or a filename + -- Content -- + + -- Name here can be either a ftp/http/https/ipp/mailto/news URL or a filename. -- See Load procedure in FLTK.Widgets.Groups.Help_Views procedure Load (This : in out Help_Dialog; @@ -77,6 +79,8 @@ package FLTK.Help_Dialogs is + -- Settings -- + function Get_Text_Size (This : in Help_Dialog) return Font_Size; @@ -88,6 +92,8 @@ package FLTK.Help_Dialogs is + -- Dimensions -- + function Get_X (This : in Help_Dialog) return Integer; diff --git a/spec/fltk-images-bitmaps-xbm.ads b/spec/fltk-images-bitmaps-xbm.ads index 0887666..5805332 100644 --- a/spec/fltk-images-bitmaps-xbm.ads +++ b/spec/fltk-images-bitmaps-xbm.ads @@ -7,10 +7,6 @@ package FLTK.Images.Bitmaps.XBM is - ------------- - -- Types -- - ------------- - type XBM_Image is new Bitmap with private; type XBM_Image_Reference (Data : not null access XBM_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.Bitmaps.XBM is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.Bitmaps.XBM; + diff --git a/spec/fltk-images-bitmaps.ads b/spec/fltk-images-bitmaps.ads index d8730a2..9577273 100644 --- a/spec/fltk-images-bitmaps.ads +++ b/spec/fltk-images-bitmaps.ads @@ -7,10 +7,6 @@ package FLTK.Images.Bitmaps is - ------------- - -- Types -- - ------------- - type Bitmap is new Image with private; type Bitmap_Reference (Data : not null access Bitmap'Class) is limited null record @@ -19,22 +15,34 @@ package FLTK.Images.Bitmaps is - -------------------- - -- Construction -- - -------------------- + -- Calculates the bytes needed to hold a given number of bits. + + function Bytes_Needed + (Bits : in Natural) + return Natural; + + + package Forge is - -- Please note that I'm pretty sure (?) input data here should be some - -- declared item that lives at least as long as the resulting Bitmap + -- Please note that input data should be some declared item + -- that lives at least as long as the resulting Bitmap. function Create (Data : in Color_Component_Array; Width, Height : in Natural) - return Bitmap; + return Bitmap + with Pre => + Data'Length >= Size_Type (Bytes_Needed (Width)) * Size_Type (Height); end Forge; + + + + -- Copying -- + function Copy (This : in Bitmap; Width, Height : in Natural) @@ -47,9 +55,7 @@ package FLTK.Images.Bitmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Bitmap); @@ -57,18 +63,56 @@ package FLTK.Images.Bitmaps is - --------------- + -- Pixel Data -- + + function Data_Size + (This : in Bitmap) + return Size_Type; + + function Get_Datum + (This : in Bitmap; + Place : in Positive_Size) + return Color_Component + with Pre => Place <= This.Data_Size; + + procedure Set_Datum + (This : in out Bitmap; + Place : in Positive_Size; + Value : in Color_Component) + with Pre => Place <= This.Data_Size; + + function Slice + (This : in Bitmap; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array + with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Size_Type'Max (0, High - Low + 1); + + procedure Overwrite + (This : in out Bitmap; + Place : in Positive_Size; + Values : in Color_Component_Array) + with Pre => Place + Values'Length - 1 <= This.Data_Size; + + function All_Data + (This : in Bitmap) + return Color_Component_Array + with Post => All_Data'Result'Length = This.Data_Size; + + + + -- Drawing -- - --------------- procedure Draw (This : in Bitmap; X, Y : in Integer); procedure Draw - (This : in Bitmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Bitmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); private @@ -80,10 +124,22 @@ private (This : in out Bitmap); + pragma Inline (Bytes_Needed); + pragma Inline (Copy); + pragma Inline (Uncache); + + pragma Inline (Data_Size); + pragma Inline (Get_Datum); + pragma Inline (Set_Datum); + pragma Inline (Slice); + pragma Inline (Overwrite); + pragma Inline (All_Data); + pragma Inline (Draw); end FLTK.Images.Bitmaps; + diff --git a/spec/fltk-images-pixmaps-gif.ads b/spec/fltk-images-pixmaps-gif.ads index 7084a13..5720138 100644 --- a/spec/fltk-images-pixmaps-gif.ads +++ b/spec/fltk-images-pixmaps-gif.ads @@ -7,10 +7,6 @@ package FLTK.Images.Pixmaps.GIF is - ------------- - -- Types -- - ------------- - type GIF_Image is new Pixmap with private; type GIF_Image_Reference (Data : not null access GIF_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.Pixmaps.GIF is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.Pixmaps.GIF; + diff --git a/spec/fltk-images-pixmaps-xpm.ads b/spec/fltk-images-pixmaps-xpm.ads index d5bae5a..c703264 100644 --- a/spec/fltk-images-pixmaps-xpm.ads +++ b/spec/fltk-images-pixmaps-xpm.ads @@ -7,10 +7,6 @@ package FLTK.Images.Pixmaps.XPM is - ------------- - -- Types -- - ------------- - type XPM_Image is new Pixmap with private; type XPM_Image_Reference (Data : not null access XPM_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.Pixmaps.XPM is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.Pixmaps.XPM; + diff --git a/spec/fltk-images-pixmaps.ads b/spec/fltk-images-pixmaps.ads index 14e3f94..64d8330 100644 --- a/spec/fltk-images-pixmaps.ads +++ b/spec/fltk-images-pixmaps.ads @@ -4,12 +4,17 @@ -- Released into the public domain -package FLTK.Images.Pixmaps is +with + + Ada.Strings.Unbounded; + +private with + Interfaces.C.Strings; + + +package FLTK.Images.Pixmaps is - ------------- - -- Types -- - ------------- type Pixmap is new Image with private; @@ -17,11 +22,48 @@ package FLTK.Images.Pixmaps is with Implicit_Dereference => Data; + type Header is record + Width, Height, Colors, Per_Pixel : Positive; + end record; + + type Color_Kind is (Colorful, Monochrome, Greyscale, Symbolic); + + type Color_Definition is record + Name : Ada.Strings.Unbounded.Unbounded_String; + Kind : Color_Kind; + Value : Ada.Strings.Unbounded.Unbounded_String; + end record; + + type Color_Definition_Array is array (Positive range <>) of Color_Definition; + + type Pixmap_Data is array (Positive range <>, Positive range <>) of Character; + - -------------------- - -- Construction -- - -------------------- + + package Forge is + + -- Unlike Bitmaps or RGB_Images, you do NOT have to keep this data around. + -- A copy will be allocated and deallocated internally. + + function Create + (Values : in Header; + Colors : in Color_Definition_Array; + Pixels : in Pixmap_Data) + return Pixmap + with Pre => + Colors'Length = Values.Colors and + Pixels'Length (1) = Values.Height and + (for all Definition of Colors => + Ada.Strings.Unbounded.Length (Definition.Name) = Values.Per_Pixel) and + Pixels'Length (2) = Values.Width * Values.Per_Pixel; + + end Forge; + + + + + -- Copying -- function Copy (This : in Pixmap; @@ -35,9 +77,7 @@ package FLTK.Images.Pixmaps is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Pixmap; @@ -50,9 +90,7 @@ package FLTK.Images.Pixmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Pixmap); @@ -60,24 +98,24 @@ package FLTK.Images.Pixmaps is - --------------- -- Drawing -- - --------------- procedure Draw (This : in Pixmap; X, Y : in Integer); procedure Draw - (This : in Pixmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Pixmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); private - type Pixmap is new Image with null record; + type Pixmap is new Image with record + Loose_Ptr : access Interfaces.C.Strings.chars_ptr_array; + end record; overriding procedure Finalize (This : in out Pixmap); @@ -86,13 +124,12 @@ private pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Uncache); - pragma Inline (Copy); pragma Inline (Draw); end FLTK.Images.Pixmaps; + diff --git a/spec/fltk-images-rgb-bmp.ads b/spec/fltk-images-rgb-bmp.ads index 4eb9e1b..f2bf103 100644 --- a/spec/fltk-images-rgb-bmp.ads +++ b/spec/fltk-images-rgb-bmp.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.BMP is - ------------- - -- Types -- - ------------- - type BMP_Image is new RGB_Image with private; type BMP_Image_Reference (Data : not null access BMP_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.RGB.BMP is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.RGB.BMP; + diff --git a/spec/fltk-images-rgb-jpeg.ads b/spec/fltk-images-rgb-jpeg.ads index 0349b01..8bb21ba 100644 --- a/spec/fltk-images-rgb-jpeg.ads +++ b/spec/fltk-images-rgb-jpeg.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.JPEG is - ------------- - -- Types -- - ------------- - type JPEG_Image is new RGB_Image with private; type JPEG_Image_Reference (Data : not null access JPEG_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.RGB.JPEG is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -48,3 +40,4 @@ private end FLTK.Images.RGB.JPEG; + diff --git a/spec/fltk-images-rgb-png.ads b/spec/fltk-images-rgb-png.ads index 23890b3..dcfbd4f 100644 --- a/spec/fltk-images-rgb-png.ads +++ b/spec/fltk-images-rgb-png.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.PNG is - ------------- - -- Types -- - ------------- - type PNG_Image is new RGB_Image with private; type PNG_Image_Reference (Data : not null access PNG_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.RGB.PNG is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -48,3 +40,4 @@ private end FLTK.Images.RGB.PNG; + diff --git a/spec/fltk-images-rgb-pnm.ads b/spec/fltk-images-rgb-pnm.ads index d72706b..847b149 100644 --- a/spec/fltk-images-rgb-pnm.ads +++ b/spec/fltk-images-rgb-pnm.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.PNM is - ------------- - -- Types -- - ------------- - type PNM_Image is new RGB_Image with private; type PNM_Image_Reference (Data : not null access PNM_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.RGB.PNM is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.RGB.PNM; + diff --git a/spec/fltk-images-rgb.ads b/spec/fltk-images-rgb.ads index 5768b3c..d893cec 100644 --- a/spec/fltk-images-rgb.ads +++ b/spec/fltk-images-rgb.ads @@ -12,30 +12,42 @@ with package FLTK.Images.RGB is - ------------- - -- Types -- - ------------- - type RGB_Image is new Image with private; type RGB_Image_Reference (Data : not null access RGB_Image'Class) is limited null record with Implicit_Dereference => Data; + type RGB_Image_Array is array (Positive range <>) of RGB_Image; + + + + + -- Static Settings -- + + function Get_Max_Size + return Size_Type; + + procedure Set_Max_Size + (Value : in Size_Type); - -------------------- - -- Construction -- - -------------------- package Forge is + -- Please note that input data should be some declared item + -- that lives at least as long as the resulting RGB_Image. + function Create (Data : in Color_Component_Array; Width, Height : in Natural; Depth : in Natural := 3; - Line_Data : in Natural := 0) - return RGB_Image; + Line_Size : in Natural := 0) + return RGB_Image + with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (Width) * Size_Type (Height) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (Height)) + and Data'Length <= Get_Max_Size; function Create (Data : in FLTK.Images.Pixmaps.Pixmap'Class; @@ -44,11 +56,10 @@ package FLTK.Images.RGB is end Forge; - function Get_Max_Size - return Natural; - procedure Set_Max_Size - (Value : in Natural); + + + -- Copying -- function Copy (This : in RGB_Image; @@ -62,9 +73,7 @@ package FLTK.Images.RGB is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out RGB_Image; @@ -77,9 +86,7 @@ package FLTK.Images.RGB is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out RGB_Image); @@ -87,18 +94,56 @@ package FLTK.Images.RGB is - --------------- + -- Pixel Data -- + + function Data_Size + (This : in RGB_Image) + return Size_Type; + + function Get_Datum + (This : in RGB_Image; + Place : in Positive_Size) + return Color_Component + with Pre => Place <= This.Data_Size; + + procedure Set_Datum + (This : in out RGB_Image; + Place : in Positive_Size; + Value : in Color_Component) + with Pre => Place <= This.Data_Size; + + function Slice + (This : in RGB_Image; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array + with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Size_Type'Max (0, High - Low + 1); + + procedure Overwrite + (This : in out RGB_Image; + Place : in Positive_Size; + Values : in Color_Component_Array) + with Pre => Place + Values'Length - 1 <= This.Data_Size; + + function All_Data + (This : in RGB_Image) + return Color_Component_Array + with Post => All_Data'Result'Length = This.Data_Size; + + + + -- Drawing -- - --------------- procedure Draw (This : in RGB_Image; X, Y : in Integer); procedure Draw - (This : in RGB_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in RGB_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); private @@ -112,18 +157,24 @@ private pragma Inline (Get_Max_Size); pragma Inline (Set_Max_Size); - pragma Inline (Copy); + pragma Inline (Copy); pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Uncache); + pragma Inline (Data_Size); + pragma Inline (Get_Datum); + pragma Inline (Set_Datum); + pragma Inline (Slice); + pragma Inline (Overwrite); + pragma Inline (All_Data); pragma Inline (Draw); end FLTK.Images.RGB; + diff --git a/spec/fltk-images-shared.ads b/spec/fltk-images-shared.ads index dce9254..c1bbdbd 100644 --- a/spec/fltk-images-shared.ads +++ b/spec/fltk-images-shared.ads @@ -12,10 +12,6 @@ with package FLTK.Images.Shared is - ------------- - -- Types -- - ------------- - type Shared_Image is new Image with private; type Shared_Image_Reference (Data : not null access Shared_Image'Class) is @@ -24,10 +20,6 @@ package FLTK.Images.Shared is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -46,6 +38,11 @@ package FLTK.Images.Shared is end Forge; + + + + -- Copying -- + function Copy (This : in Shared_Image; Width, Height : in Natural) @@ -58,9 +55,7 @@ package FLTK.Images.Shared is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Shared_Image; @@ -73,9 +68,7 @@ package FLTK.Images.Shared is - ---------------- -- Activity -- - ---------------- function Number_Of_Images return Natural; @@ -101,9 +94,7 @@ package FLTK.Images.Shared is - --------------- -- Drawing -- - --------------- procedure Set_Scaling_Algorithm (To : in Scaling_Kind); @@ -135,11 +126,9 @@ private pragma Inline (Copy); - pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Number_Of_Images); pragma Inline (Name); pragma Inline (Original); @@ -147,7 +136,6 @@ private pragma Inline (Reload); pragma Inline (Uncache); - pragma Inline (Set_Scaling_Algorithm); pragma Inline (Scale); pragma Inline (Draw); @@ -155,3 +143,4 @@ private end FLTK.Images.Shared; + diff --git a/spec/fltk-images-tiled.ads b/spec/fltk-images-tiled.ads index a7e775e..a7470fc 100644 --- a/spec/fltk-images-tiled.ads +++ b/spec/fltk-images-tiled.ads @@ -7,10 +7,6 @@ package FLTK.Images.Tiled is - ------------- - -- Types -- - ------------- - type Tiled_Image is new Image with private; type Tiled_Image_Reference (Data : not null access Tiled_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.Tiled is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -32,6 +24,11 @@ package FLTK.Images.Tiled is end Forge; + + + + -- Copying -- + function Copy (This : in Tiled_Image; Width, Height : in Natural) @@ -44,9 +41,7 @@ package FLTK.Images.Tiled is - --------------------- -- Miscellaneous -- - --------------------- procedure Inactive (This : in out Tiled_Image); @@ -58,9 +53,7 @@ package FLTK.Images.Tiled is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Tiled_Image; @@ -73,18 +66,16 @@ package FLTK.Images.Tiled is - --------------- -- Drawing -- - --------------- procedure Draw (This : in Tiled_Image; X, Y : in Integer); procedure Draw - (This : in Tiled_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer); + (This : in Tiled_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer); private @@ -100,17 +91,15 @@ private pragma Inline (Copy); - pragma Inline (Inactive); pragma Inline (Tile); - pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Draw); end FLTK.Images.Tiled; + diff --git a/spec/fltk-images.ads b/spec/fltk-images.ads index 9a02f23..6afb788 100644 --- a/spec/fltk-images.ads +++ b/spec/fltk-images.ads @@ -7,10 +7,6 @@ package FLTK.Images is - ------------- - -- Types -- - ------------- - type Image is new Wrapper with private; type Image_Reference (Data : not null access Image'Class) is limited null record @@ -18,25 +14,27 @@ package FLTK.Images is type Scaling_Kind is (Nearest, Bilinear); - type Blend is new Float range 0.0 .. 1.0; No_Image_Error, File_Access_Error, Format_Error : exception; - -------------------- - -- Construction -- - -------------------- - package Forge is + -- This creates an empty image with no data, so not that useful. + function Create (Width, Height, Depth : in Natural) return Image; end Forge; + + + + -- Copying -- + function Get_Copy_Algorithm return Scaling_Kind; @@ -55,9 +53,7 @@ package FLTK.Images is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Image; @@ -70,9 +66,7 @@ package FLTK.Images is - ---------------- -- Activity -- - ---------------- procedure Inactive (This : in out Image); @@ -87,9 +81,7 @@ package FLTK.Images is - ------------------ -- Dimensions -- - ------------------ function Get_W (This : in Image) @@ -103,86 +95,23 @@ package FLTK.Images is (This : in Image) return Natural; - function Get_Line_Data - (This : in Image) - return Natural; - - function Get_Data_Count + function Get_Line_Size (This : in Image) return Natural; - function Get_Data_Size - (This : in Image) - return Natural; - - - - - ------------------ - -- Pixel Data -- - ------------------ - - function Get_Datum - (This : in Image; - Data : in Positive; - Position : in Positive) - return Color_Component - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This); - - procedure Set_Datum - (This : in out Image; - Data : in Positive; - Position : in Positive; - Value : in Color_Component) - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This); - - function Get_Data - (This : in Image; - Data : in Positive; - Position : in Positive; - Count : in Natural) - return Color_Component_Array - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This) and - Count <= Get_Data_Size (This) - Position + 1; - - function All_Data - (This : in Image; - Data : in Positive) - return Color_Component_Array - with Pre => - Data <= Get_Data_Count (This); - - procedure Update_Data - (This : in out Image; - Data : in Positive; - Position : in Positive; - Values : in Color_Component_Array) - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This) and - Values'Length <= Get_Data_Size (This) - Position + 1; - - --------------- -- Drawing -- - --------------- procedure Draw (This : in Image; X, Y : in Integer); procedure Draw - (This : in Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); procedure Draw_Empty (This : in Image; @@ -198,40 +127,43 @@ private (This : in out Image); + procedure Raise_Fail_Errors + (This : in Image'Class); + + + function fl_image_data + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_image_data, "fl_image_data"); + pragma Inline (fl_image_data); + + function fl_image_count + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_count, "fl_image_count"); + pragma Inline (fl_image_count); pragma Inline (Get_Copy_Algorithm); pragma Inline (Set_Copy_Algorithm); pragma Inline (Copy); - pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Inactive); pragma Inline (Is_Empty); pragma Inline (Uncache); - pragma Inline (Get_W); pragma Inline (Get_H); pragma Inline (Get_D); - pragma Inline (Get_Line_Data); - pragma Inline (Get_Data_Count); - + pragma Inline (Get_Line_Size); pragma Inline (Draw); pragma Inline (Draw_Empty); - - - function fl_image_fail - (I : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_image_fail, "fl_image_fail"); - - end FLTK.Images; + diff --git a/spec/fltk-labels.ads b/spec/fltk-labels.ads index 5e13a2e..e9da5f1 100644 --- a/spec/fltk-labels.ads +++ b/spec/fltk-labels.ads @@ -42,6 +42,8 @@ package FLTK.Labels is + -- Attributes -- + function Get_Value (This : in Label) return String; @@ -109,6 +111,8 @@ package FLTK.Labels is + -- Drawing -- + procedure Draw (This : in out Label; X, Y, W, H : in Integer; diff --git a/spec/fltk-menu_items.ads b/spec/fltk-menu_items.ads index ac80984..ced27ec 100644 --- a/spec/fltk-menu_items.ads +++ b/spec/fltk-menu_items.ads @@ -40,6 +40,8 @@ package FLTK.Menu_Items is + -- Callback -- + function Get_Callback (This : in Menu_Item) return FLTK.Widgets.Widget_Callback; @@ -55,6 +57,8 @@ package FLTK.Menu_Items is + -- Settings -- + function Has_Checkbox (This : in Menu_Item) return Boolean; @@ -87,6 +91,8 @@ package FLTK.Menu_Items is + -- Label -- + function Get_Label (This : in Menu_Item) return String; @@ -135,6 +141,8 @@ package FLTK.Menu_Items is + -- Shortcut and Flags -- + function Get_Shortcut (This : in Menu_Item) return Key_Combo; @@ -154,6 +162,8 @@ package FLTK.Menu_Items is + -- Image -- + function Get_Image (This : in Menu_Item) return access FLTK.Images.Image'Class; @@ -165,6 +175,8 @@ package FLTK.Menu_Items is + -- Activity and Visibility -- + procedure Activate (This : in out Menu_Item); diff --git a/spec/fltk-screen.ads b/spec/fltk-screen.ads index be28134..38db9aa 100644 --- a/spec/fltk-screen.ads +++ b/spec/fltk-screen.ads @@ -7,6 +7,28 @@ package FLTK.Screen is + type Visual_Mode is (RGB, RGB_24bit, Double_Buffer, Double_RGB, Double_RGB_24bit); + + + + + -- Environment -- + + procedure Set_Display_String + (Value : in String); + + procedure Set_Visual_Mode + (Value : in Visual_Mode); + + function Set_Visual_Mode + (Value : in Visual_Mode) + return Boolean; + + + + + -- Basic Dimensions -- + function Get_X return Integer; @@ -22,6 +44,8 @@ package FLTK.Screen is + -- Pixel Density -- + function Count return Integer; @@ -33,6 +57,8 @@ package FLTK.Screen is + -- Position Lookup -- + function Containing (X, Y : in Integer) return Integer; @@ -44,6 +70,8 @@ package FLTK.Screen is + -- Bounding Boxes -- + procedure Work_Area (X, Y, W, H : out Integer; Pos_X, Pos_Y : in Integer); @@ -55,9 +83,6 @@ package FLTK.Screen is procedure Work_Area (X, Y, W, H : out Integer); - - - procedure Bounding_Rect (X, Y, W, H : out Integer; Pos_X, Pos_Y : in Integer); @@ -74,23 +99,49 @@ package FLTK.Screen is PX, PY, PW, PH : in Integer); + + + -- Drawing -- + + function Is_Damaged + return Boolean; + + procedure Set_Damaged + (To : in Boolean); + + procedure Flush; + + procedure Redraw; + + private + pragma Import (C, Flush, "fl_screen_flush"); + pragma Import (C, Redraw, "fl_screen_redraw"); + + + pragma Inline (Set_Display_String); + pragma Inline (Set_Visual_Mode); + pragma Inline (Get_X); pragma Inline (Get_Y); pragma Inline (Get_W); pragma Inline (Get_H); - pragma Inline (Count); pragma Inline (DPI); - pragma Inline (Containing); pragma Inline (Work_Area); pragma Inline (Bounding_Rect); + pragma Inline (Is_Damaged); + pragma Inline (Set_Damaged); + pragma Inline (Flush); + pragma Inline (Redraw); + end FLTK.Screen; + diff --git a/spec/fltk-static.ads b/spec/fltk-static.ads index 98f44ba..4f71244 100644 --- a/spec/fltk-static.ads +++ b/spec/fltk-static.ads @@ -6,23 +6,31 @@ with + FLTK.Labels, FLTK.Widgets.Groups.Windows; private with - Interfaces.C; + Ada.Finalization, + Ada.Unchecked_Conversion, + FLTK.Args_Marshal, + Interfaces.C.Strings; package FLTK.Static is - type Awake_Handler is access procedure; + -- Input is the argument index usable with Ada.Command_Line. + -- Output is how many arguments parsed starting from that index. + type Args_Handler is access function + (Index : in Positive) + return Natural; - type Timeout_Handler is access procedure; + type Awake_Handler is access procedure; type Idle_Handler is access procedure; - + type Timeout_Handler is access procedure; type Buffer_Kind is (Selection, Clipboard); @@ -31,35 +39,82 @@ package FLTK.Static is (Kind : in Buffer_Kind); + type File_Descriptor is new Integer; + type File_Mode is record + Read : Boolean := False; + Write : Boolean := False; + Except : Boolean := False; + end record; - type File_Descriptor is new Integer; + function "+" (Left, Right : in File_Mode) return File_Mode; + function "-" (Left, Right : in File_Mode) return File_Mode; - type File_Mode is (Read, Write, Except); + Read_Mode : constant File_Mode; + Write_Mode : constant File_Mode; + Except_Mode : constant File_Mode; type File_Handler is access procedure (FD : in File_Descriptor); - + subtype Byte_Integer is Integer range 0 .. 255; type Box_Draw_Function is access procedure (X, Y, W, H : in Integer; - My_Color : in Color); + Tone : in Color); + type Label_Draw_Function is access procedure + (Item : in FLTK.Labels.Label'Class; + X, Y, W, H : in Integer; + Position : in Alignment); + + type Label_Measure_Function is access procedure + (Item : in FLTK.Labels.Label'Class; + W, H : out Integer); type Option is - (Arrow_Focus, - Visible_Focus, - DND_Text, - Show_Tooltips, - FNFC_Uses_GTK, - Last); + (Arrow_Focus, + Visible_Focus, + DND_Text, + Show_Tooltips, + FNFC_Uses_GTK); + + + -- According to docs this should be customisable, + -- but in C++ it is a constant pointer to constant. + Help_Message : constant String; + + + Argument_Error : exception; + + + + + -- Command Line Arguments -- + + function Parse_Arg + (Index : in Positive) + return Natural; + + procedure Parse_Args; + + -- Not task safe, but you won't need to call this more than once anyway. + procedure Parse_Args + (Count : out Natural; + Func : in Args_Handler := null); + + + -- Thread Notify -- + -- Unsure if it is worth actually using this or if mixing tasks, pthreads, + -- and whatever other platforms use causes errors in some unexpected way. + -- Might be better to rely on FLTK.Check, Ada tasking, and Ada protected types. + -- You'll need appropriately declared protected objects to pass messages anyway. procedure Add_Awake_Handler (Func : in Awake_Handler); @@ -67,57 +122,74 @@ package FLTK.Static is function Get_Awake_Handler return Awake_Handler; + procedure Awake + (Func : in Awake_Handler); + + procedure Awake; + + procedure Lock; + + procedure Unlock; + + + -- Pre-Eventloop Callbacks -- procedure Add_Check - (Func : in Timeout_Handler); + (Func : in not null Timeout_Handler); function Has_Check - (Func : in Timeout_Handler) + (Func : in not null Timeout_Handler) return Boolean; procedure Remove_Check - (Func : in Timeout_Handler); + (Func : in not null Timeout_Handler); + -- Timer Callbacks -- + procedure Add_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler); + (Seconds : in Long_Float; + Func : in not null Timeout_Handler); function Has_Timeout - (Func : in Timeout_Handler) + (Func : in not null Timeout_Handler) return Boolean; procedure Remove_Timeout - (Func : in Timeout_Handler); + (Func : in not null Timeout_Handler); procedure Repeat_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler); + (Seconds : in Long_Float; + Func : in not null Timeout_Handler); + + -- Clipboard Callbacks -- procedure Add_Clipboard_Notify - (Func : in Clipboard_Notify_Handler); + (Func : in not null Clipboard_Notify_Handler); procedure Remove_Clipboard_Notify - (Func : in Clipboard_Notify_Handler); + (Func : in not null Clipboard_Notify_Handler); + + -- File Descriptor Waiting Callbacks -- procedure Add_File_Descriptor - (FD : in File_Descriptor; - Func : in File_Handler); + (FD : in File_Descriptor; + Func : in not null File_Handler); procedure Add_File_Descriptor - (FD : in File_Descriptor; - Mode : in File_Mode; - Func : in File_Handler); + (FD : in File_Descriptor; + Mode : in File_Mode; + Func : in not null File_Handler); procedure Remove_File_Descriptor (FD : in File_Descriptor); @@ -129,31 +201,49 @@ package FLTK.Static is + -- Idle Callbacks -- + procedure Add_Idle - (Func : in Idle_Handler); + (Func : in not null Idle_Handler); function Has_Idle - (Func : in Idle_Handler) + (Func : in not null Idle_Handler) return Boolean; procedure Remove_Idle - (Func : in Idle_Handler); + (Func : in not null Idle_Handler); + -- Custom Colors -- + + function Get_Color + (From : in Color) + return Color; + procedure Get_Color (From : in Color; R, G, B : out Color_Component); procedure Set_Color - (To : in Color; + (Target, Source : in Color); + + procedure Set_Color + (Target : in Color; R, G, B : in Color_Component); procedure Free_Color (Value : in Color; Overlay : in Boolean := False); + function Get_Box_Color + (Tone : in Color) + return Color; + + procedure Set_Box_Color + (Tone : in Color); + procedure Own_Colormap; procedure Set_Foreground @@ -170,6 +260,8 @@ package FLTK.Static is + -- Custom Fonts -- + function Font_Image (Kind : in Font_Kind) return String; @@ -179,7 +271,11 @@ package FLTK.Static is return String; procedure Set_Font_Kind - (To, From : in Font_Kind); + (Target, Source : in Font_Kind); + + procedure Set_Font_Kind + (Target : in Font_Kind; + Source : in String); function Font_Sizes (Kind : in Font_Kind) @@ -191,6 +287,8 @@ package FLTK.Static is + -- Box_Kind Attributes -- + function Get_Box_Height_Offset (Kind : in Box_Kind) return Integer; @@ -213,18 +311,33 @@ package FLTK.Static is function Draw_Box_Active return Boolean; - -- function Get_Box_Draw_Function - -- (Kind : in Box_Kind) - -- return Box_Draw_Function; + function Get_Box_Draw_Function + (Kind : in Box_Kind) + return 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); - -- 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); + -- Label_Kind Attributes -- + + procedure Set_Label_Kind + (Target, Source : in Label_Kind); + + procedure Set_Label_Draw_Function + (Kind : in Label_Kind; + Draw_Func : in Label_Draw_Function; + Measure_Func : in Label_Measure_Function); + + + + + -- Clipboard / Selection -- procedure Copy (Text : in String; @@ -238,8 +351,14 @@ package FLTK.Static is (Owner : in FLTK.Widgets.Widget'Class; Text : in String); + function Clipboard_Contains + (Kind : in String) + return Boolean; + + + -- Dragon Drop -- procedure Drag_Drop_Start; @@ -252,18 +371,16 @@ package FLTK.Static is + -- Input Methods -- + procedure Enable_System_Input; procedure Disable_System_Input; - function Has_Visible_Focus - return Boolean; - - procedure Set_Visible_Focus - (To : in Boolean); + -- Windows -- procedure Default_Window_Close (Item : in out FLTK.Widgets.Widget'Class); @@ -284,13 +401,15 @@ package FLTK.Static is + -- Queue -- + function Read_Queue return access FLTK.Widgets.Widget'Class; - procedure Do_Widget_Deletion; + -- Schemes -- function Get_Scheme return String; @@ -307,6 +426,8 @@ package FLTK.Static is + -- Library Options -- + function Get_Option (Opt : in Option) return Boolean; @@ -318,6 +439,8 @@ package FLTK.Static is + -- Scrollbars -- + function Get_Default_Scrollbar_Size return Natural; @@ -328,101 +451,114 @@ package FLTK.Static is private - File_Mode_Codes : array (File_Mode) of Interfaces.C.int := - (Read => 1, Write => 4, Except => 8); + The_Argv : Interfaces.C.Strings.chars_ptr_array := FLTK.Args_Marshal.Create_Argv; + for File_Mode use record + Read at 0 range 0 .. 0; + -- bit position 1 is unused + Write at 0 range 2 .. 2; + Except at 0 range 3 .. 3; + end record; + for File_Mode'Size use Interfaces.C.int'Size; - pragma Import (C, Own_Colormap, "fl_static_own_colormap"); - pragma Import (C, System_Colors, "fl_static_get_system_colors"); + Read_Mode : constant File_Mode := (Read => True, others => False); + Write_Mode : constant File_Mode := (Write => True, others => False); + Except_Mode : constant File_Mode := (Except => True, others => False); + function FMode_To_Cint is new + Ada.Unchecked_Conversion (File_Mode, Interfaces.C.int); - pragma Import (C, Drag_Drop_Start, "fl_static_dnd"); + help_usage_string_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, help_usage_string_ptr, "fl_help_usage_string_ptr"); - pragma Import (C, Enable_System_Input, "fl_static_enable_im"); - pragma Import (C, Disable_System_Input, "fl_static_disable_im"); + Help_Message : constant String := Interfaces.C.Strings.Value (help_usage_string_ptr); - pragma Import (C, Do_Widget_Deletion, "fl_static_do_widget_deletion"); + Font_Overrides : array (Font_Kind) of Interfaces.C.Strings.chars_ptr; - pragma Import (C, Reload_Scheme, "fl_static_reload_scheme"); + pragma Import (C, Lock, "fl_static_lock"); + pragma Import (C, Unlock, "fl_static_unlock"); + + pragma Import (C, Own_Colormap, "fl_static_own_colormap"); + pragma Import (C, System_Colors, "fl_static_get_system_colors"); + pragma Import (C, Enable_System_Input, "fl_static_enable_im"); + pragma Import (C, Disable_System_Input, "fl_static_disable_im"); + + pragma Import (C, Reload_Scheme, "fl_static_reload_scheme"); + pragma Inline (Parse_Arg); pragma Inline (Add_Awake_Handler); pragma Inline (Get_Awake_Handler); - + pragma Inline (Awake); + pragma Inline (Lock); + pragma Inline (Unlock); pragma Inline (Add_Check); pragma Inline (Has_Check); pragma Inline (Remove_Check); - pragma Inline (Add_Timeout); pragma Inline (Has_Timeout); pragma Inline (Remove_Timeout); pragma Inline (Repeat_Timeout); - pragma Inline (Add_Clipboard_Notify); pragma Inline (Remove_Clipboard_Notify); - pragma Inline (Add_File_Descriptor); pragma Inline (Remove_File_Descriptor); - pragma Inline (Add_Idle); pragma Inline (Has_Idle); pragma Inline (Remove_Idle); - pragma Inline (Get_Color); pragma Inline (Set_Color); pragma Inline (Free_Color); + pragma Inline (Get_Box_Color); + pragma Inline (Set_Box_Color); pragma Inline (Own_Colormap); pragma Inline (Set_Foreground); pragma Inline (Set_Background); pragma Inline (Set_Alt_Background); pragma Inline (System_Colors); - pragma Inline (Font_Image); pragma Inline (Font_Family_Image); pragma Inline (Set_Font_Kind); pragma Inline (Font_Sizes); pragma Inline (Setup_Fonts); - pragma Inline (Get_Box_Height_Offset); pragma Inline (Get_Box_Width_Offset); pragma Inline (Get_Box_X_Offset); pragma Inline (Get_Box_Y_Offset); pragma Inline (Set_Box_Kind); pragma Inline (Draw_Box_Active); - -- pragma Inline (Get_Box_Draw_Function); - -- pragma Inline (Set_Box_Draw_Function); + pragma Inline (Get_Box_Draw_Function); + pragma Inline (Set_Box_Draw_Function); + pragma Inline (Set_Label_Kind); + pragma Inline (Set_Label_Draw_Function); pragma Inline (Copy); pragma Inline (Paste); pragma Inline (Selection); - + pragma Inline (Clipboard_Contains); pragma Inline (Drag_Drop_Start); pragma Inline (Get_Drag_Drop_Text_Support); pragma Inline (Set_Drag_Drop_Text_Support); - pragma Inline (Enable_System_Input); pragma Inline (Disable_System_Input); - pragma Inline (Has_Visible_Focus); - pragma Inline (Set_Visible_Focus); - pragma Inline (Default_Window_Close); pragma Inline (Get_First_Window); @@ -430,24 +566,29 @@ private pragma Inline (Get_Next_Window); pragma Inline (Get_Top_Modal); - pragma Inline (Read_Queue); - pragma Inline (Do_Widget_Deletion); - pragma Inline (Get_Scheme); pragma Inline (Set_Scheme); pragma Inline (Is_Scheme); pragma Inline (Reload_Scheme); - pragma Inline (Get_Option); pragma Inline (Set_Option); - pragma Inline (Get_Default_Scrollbar_Size); pragma Inline (Set_Default_Scrollbar_Size); + -- Needed to dealloc the argv array and deregister the clipboard notify handler + type FLTK_Static_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out FLTK_Static_Final_Controller); + + Cleanup : FLTK_Static_Final_Controller; + + end FLTK.Static; + diff --git a/spec/fltk-text_buffers.ads b/spec/fltk-text_buffers.ads index 53b2692..9430c57 100644 --- a/spec/fltk-text_buffers.ads +++ b/spec/fltk-text_buffers.ads @@ -48,6 +48,8 @@ package FLTK.Text_Buffers is + -- Callbacks -- + procedure Add_Modify_Callback (This : in out Text_Buffer; Func : in Modify_Callback); @@ -79,6 +81,8 @@ package FLTK.Text_Buffers is + -- Files -- + procedure Load_File (This : in out Text_Buffer; Name : in String; @@ -109,6 +113,8 @@ package FLTK.Text_Buffers is + -- Modification -- + procedure Insert_Text (This : in out Text_Buffer; Place : in Position; @@ -163,6 +169,8 @@ package FLTK.Text_Buffers is + -- Measurement -- + function Count_Displayed_Characters (This : in Text_Buffer; Start, Finish : in Position) @@ -188,6 +196,8 @@ package FLTK.Text_Buffers is + -- Selection -- + function Get_Selection (This : in Text_Buffer; Start, Finish : out Position) @@ -245,6 +255,8 @@ package FLTK.Text_Buffers is + -- Highlighting -- + procedure Get_Highlight (This : in Text_Buffer; Start, Finish : out Position); @@ -263,6 +275,8 @@ package FLTK.Text_Buffers is + -- Search -- + function Findchar_Forward (This : in Text_Buffer; Start_At : in Position; @@ -296,6 +310,8 @@ package FLTK.Text_Buffers is + -- Navigation -- + function Word_Start (This : in Text_Buffer; Place : in Position) @@ -344,6 +360,8 @@ package FLTK.Text_Buffers is + -- Miscellaneous -- + procedure Can_Undo (This : in out Text_Buffer; Flag : in Boolean); @@ -371,8 +389,6 @@ private Element_Type => Predelete_Callback); - - type Text_Buffer is new Wrapper with record CB_Active : Boolean := True; @@ -385,8 +401,6 @@ private (This : in out Text_Buffer); - - procedure Modify_Callback_Hook (Pos, Inserted, Deleted, Restyled : in Interfaces.C.int; Text : in Interfaces.C.Strings.chars_ptr; @@ -399,13 +413,9 @@ private pragma Convention (C, Predelete_Callback_Hook); - - package Text_Buffer_Convert is new System.Address_To_Access_Conversions (Text_Buffer); - - pragma Inline (Add_Modify_Callback); pragma Inline (Add_Predelete_Callback); pragma Inline (Remove_Modify_Callback); @@ -415,14 +425,12 @@ private pragma Inline (Enable_Callbacks); pragma Inline (Disable_Callbacks); - pragma Inline (Load_File); pragma Inline (Append_File); pragma Inline (Insert_File); pragma Inline (Output_File); pragma Inline (Save_File); - pragma Inline (Insert_Text); pragma Inline (Append_Text); pragma Inline (Replace_Text); @@ -435,14 +443,12 @@ private pragma Inline (Next_Char); pragma Inline (Prev_Char); - pragma Inline (Count_Displayed_Characters); pragma Inline (Count_Lines); pragma Inline (Length); pragma Inline (Get_Tab_Width); pragma Inline (Set_Tab_Width); - pragma Inline (Get_Selection); pragma Inline (Get_Secondary_Selection); pragma Inline (Set_Selection); @@ -458,19 +464,16 @@ private pragma Inline (Unselect); pragma Inline (Secondary_Unselect); - pragma Inline (Get_Highlight); pragma Inline (Set_Highlight); pragma Inline (Get_Highlighted_Text); pragma Inline (Unhighlight); - pragma Inline (Findchar_Forward); pragma Inline (Findchar_Backward); pragma Inline (Search_Forward); pragma Inline (Search_Backward); - pragma Inline (Word_Start); pragma Inline (Word_End); pragma Inline (Line_Start); @@ -480,7 +483,6 @@ private pragma Inline (Rewind_Lines); pragma Inline (Skip_Displayed_Characters); - pragma Inline (Can_Undo); pragma Inline (Copy); pragma Inline (UTF8_Align); @@ -488,3 +490,4 @@ private end FLTK.Text_Buffers; + diff --git a/spec/fltk-tooltips.ads b/spec/fltk-tooltips.ads index 4162358..46a50d5 100644 --- a/spec/fltk-tooltips.ads +++ b/spec/fltk-tooltips.ads @@ -12,6 +12,8 @@ with package FLTK.Tooltips is + -- Activity -- + function Get_Target return access FLTK.Widgets.Widget'Class; @@ -34,6 +36,8 @@ package FLTK.Tooltips is + -- Delay -- + function Get_Delay return Float; @@ -49,6 +53,8 @@ package FLTK.Tooltips is + -- Color, Margins, Wrap -- + function Get_Background_Color return Color; @@ -76,6 +82,8 @@ package FLTK.Tooltips is + -- Text Settings -- + function Get_Text_Color return Color; diff --git a/spec/fltk-widgets-boxes.ads b/spec/fltk-widgets-boxes.ads index 7e24d5f..d9674e5 100644 --- a/spec/fltk-widgets-boxes.ads +++ b/spec/fltk-widgets-boxes.ads @@ -51,6 +51,8 @@ package FLTK.Widgets.Boxes is + -- Drawing, Events -- + procedure Draw (This : in out Box); diff --git a/spec/fltk-widgets-buttons-enter.ads b/spec/fltk-widgets-buttons-enter.ads index ed5ab83..896df8d 100644 --- a/spec/fltk-widgets-buttons-enter.ads +++ b/spec/fltk-widgets-buttons-enter.ads @@ -41,6 +41,8 @@ package FLTK.Widgets.Buttons.Enter is + -- Drawing, Events -- + procedure Draw (This : in out Enter_Button); diff --git a/spec/fltk-widgets-buttons-light.ads b/spec/fltk-widgets-buttons-light.ads index b1a1cfa..c4761a8 100644 --- a/spec/fltk-widgets-buttons-light.ads +++ b/spec/fltk-widgets-buttons-light.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Buttons.Light is + -- Drawing, Events -- + procedure Draw (This : in out Light_Button); diff --git a/spec/fltk-widgets-buttons-repeat.ads b/spec/fltk-widgets-buttons-repeat.ads index 37380db..451553a 100644 --- a/spec/fltk-widgets-buttons-repeat.ads +++ b/spec/fltk-widgets-buttons-repeat.ads @@ -38,12 +38,16 @@ package FLTK.Widgets.Buttons.Repeat is + -- Activity -- + procedure Deactivate (This : in out Repeat_Button); + -- Events -- + function Handle (This : in out Repeat_Button; Event : in Event_Kind) diff --git a/spec/fltk-widgets-buttons.ads b/spec/fltk-widgets-buttons.ads index c5fb917..bff7c81 100644 --- a/spec/fltk-widgets-buttons.ads +++ b/spec/fltk-widgets-buttons.ads @@ -40,6 +40,8 @@ package FLTK.Widgets.Buttons is + -- State -- + function Is_On (This : in Button) return Boolean; @@ -58,6 +60,8 @@ package FLTK.Widgets.Buttons is + -- Settings -- + function Get_Down_Box (This : in Button) return Box_Kind; @@ -77,6 +81,8 @@ package FLTK.Widgets.Buttons is + -- Drawing, Events -- + procedure Draw (This : in out Button); @@ -88,6 +94,8 @@ package FLTK.Widgets.Buttons is + -- Miscellaneous -- + procedure Simulate_Key_Action (This : in out Button); diff --git a/spec/fltk-widgets-charts.ads b/spec/fltk-widgets-charts.ads index eb8d75b..7df4df1 100644 --- a/spec/fltk-widgets-charts.ads +++ b/spec/fltk-widgets-charts.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Charts is + -- Data -- + procedure Add (This : in out Chart; Data_Value : in Long_Float; @@ -64,6 +66,8 @@ package FLTK.Widgets.Charts is + -- Settings -- + function Will_Autosize (This : in Chart) return Boolean; @@ -95,6 +99,8 @@ package FLTK.Widgets.Charts is + -- Text Settings -- + function Get_Text_Color (This : in Chart) return Color; @@ -122,6 +128,8 @@ package FLTK.Widgets.Charts is + -- Dimensions -- + procedure Resize (This : in out Chart; W, H : in Integer); @@ -129,6 +137,8 @@ package FLTK.Widgets.Charts is + -- Drawing -- + procedure Draw (This : in out Chart); diff --git a/spec/fltk-widgets-clocks-updated.ads b/spec/fltk-widgets-clocks-updated.ads index c0700b2..b3389df 100644 --- a/spec/fltk-widgets-clocks-updated.ads +++ b/spec/fltk-widgets-clocks-updated.ads @@ -51,6 +51,8 @@ package FLTK.Widgets.Clocks.Updated is + -- Events -- + function Handle (This : in out Updated_Clock; Event : in Event_Kind) diff --git a/spec/fltk-widgets-clocks.ads b/spec/fltk-widgets-clocks.ads index d5b3728..c729262 100644 --- a/spec/fltk-widgets-clocks.ads +++ b/spec/fltk-widgets-clocks.ads @@ -44,6 +44,8 @@ package FLTK.Widgets.Clocks is + -- Individual Values -- + function Get_Hour (This : in Clock) return Hour; @@ -59,6 +61,8 @@ package FLTK.Widgets.Clocks is + -- Full Value -- + function Get_Time (This : in Clock) return Time_Value; @@ -76,6 +80,8 @@ package FLTK.Widgets.Clocks is + -- Drawing -- + procedure Draw (This : in out Clock); diff --git a/spec/fltk-widgets-groups-browsers-check.ads b/spec/fltk-widgets-groups-browsers-check.ads index bd70503..46c9108 100644 --- a/spec/fltk-widgets-groups-browsers-check.ads +++ b/spec/fltk-widgets-groups-browsers-check.ads @@ -47,7 +47,7 @@ package FLTK.Widgets.Groups.Browsers.Check is - -- Adding and removing + -- Items -- procedure Add (This : in out Check_Browser; @@ -68,7 +68,7 @@ package FLTK.Widgets.Groups.Browsers.Check is - -- Checking and unchecking + -- Checkmarking -- procedure Check_All (This : in out Check_Browser); @@ -93,7 +93,7 @@ package FLTK.Widgets.Groups.Browsers.Check is - -- Text and selection + -- Text Selection -- -- Don't confuse this with the missing Item_Cursor version function Item_Text @@ -108,6 +108,8 @@ package FLTK.Widgets.Groups.Browsers.Check is + -- Item Implementation -- + -- As mentioned at the start, due to issues with FLTK 1.3 if you override -- these subprograms the behaviour in FLTK will not change. Should be able -- to bind them properly once 1.4 comes around. diff --git a/spec/fltk-widgets-groups-browsers-textline-choice.ads b/spec/fltk-widgets-groups-browsers-textline-choice.ads index b3c404c..dcf3d60 100644 --- a/spec/fltk-widgets-groups-browsers-textline-choice.ads +++ b/spec/fltk-widgets-groups-browsers-textline-choice.ads @@ -4,6 +4,9 @@ -- Released into the public domain +-- Select_Browsers except select is a reserved word + + package FLTK.Widgets.Groups.Browsers.Textline.Choice is @@ -13,6 +16,8 @@ package FLTK.Widgets.Groups.Browsers.Textline.Choice is limited null record with Implicit_Dereference => Data; + + package Forge is function Create diff --git a/spec/fltk-widgets-groups-browsers-textline-file.ads b/spec/fltk-widgets-groups-browsers-textline-file.ads index e679957..d19bd50 100644 --- a/spec/fltk-widgets-groups-browsers-textline-file.ads +++ b/spec/fltk-widgets-groups-browsers-textline-file.ads @@ -55,6 +55,8 @@ package FLTK.Widgets.Groups.Browsers.Textline.File is + -- Directory -- + function Load (This : in out File_Browser; Dir : in String; @@ -71,6 +73,8 @@ package FLTK.Widgets.Groups.Browsers.Textline.File is + -- Settings -- + function Get_File_Kind (This : in File_Browser) return File_Kind; @@ -106,6 +110,8 @@ package FLTK.Widgets.Groups.Browsers.Textline.File is + -- List Implementation -- + function Full_List_Height (This : in File_Browser) return Integer; @@ -117,6 +123,8 @@ package FLTK.Widgets.Groups.Browsers.Textline.File is + -- Item Implementation -- + function Item_Width (This : in File_Browser; Item : in Item_Cursor) diff --git a/spec/fltk-widgets-groups-browsers-textline-hold.ads b/spec/fltk-widgets-groups-browsers-textline-hold.ads index 7de4445..3839dd1 100644 --- a/spec/fltk-widgets-groups-browsers-textline-hold.ads +++ b/spec/fltk-widgets-groups-browsers-textline-hold.ads @@ -13,6 +13,8 @@ package FLTK.Widgets.Groups.Browsers.Textline.Hold is limited null record with Implicit_Dereference => Data; + + package Forge is function Create diff --git a/spec/fltk-widgets-groups-browsers-textline-multi.ads b/spec/fltk-widgets-groups-browsers-textline-multi.ads index f4a7df2..150b5b6 100644 --- a/spec/fltk-widgets-groups-browsers-textline-multi.ads +++ b/spec/fltk-widgets-groups-browsers-textline-multi.ads @@ -13,6 +13,8 @@ package FLTK.Widgets.Groups.Browsers.Textline.Multi is limited null record with Implicit_Dereference => Data; + + package Forge is function Create diff --git a/spec/fltk-widgets-groups-browsers-textline.ads b/spec/fltk-widgets-groups-browsers-textline.ads index 3ef7322..3a66e12 100644 --- a/spec/fltk-widgets-groups-browsers-textline.ads +++ b/spec/fltk-widgets-groups-browsers-textline.ads @@ -51,7 +51,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- Directly manipulating lines + -- Lines -- procedure Add (This : in out Textline_Browser; @@ -86,7 +86,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- Loading text and text size + -- Text Loading -- procedure Load (This : in out Textline_Browser; @@ -113,7 +113,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- Columns and formatting + -- Columns, Formatting -- function Get_Column_Character (This : in Textline_Browser) @@ -143,7 +143,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- Line positioning + -- Line Positions -- function Get_Top_Line (This : in Textline_Browser) @@ -169,7 +169,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- Line selection + -- Selection -- function Set_Select (This : in out Textline_Browser; @@ -194,7 +194,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- Visibility, showing, hiding + -- Visibility -- function Is_Visible (This : in Textline_Browser; @@ -227,7 +227,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- Resizing + -- Dimensions -- procedure Resize (This : in out Textline_Browser; @@ -236,7 +236,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- Icons for specific lines + -- Icons -- function Has_Icon (This : in Textline_Browser; @@ -260,7 +260,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- List dimensions + -- List Implementation -- function Full_List_Height (This : in Textline_Browser) @@ -273,7 +273,7 @@ package FLTK.Widgets.Groups.Browsers.Textline is - -- Item implementation + -- Item Implementation -- function Item_Width (This : in Textline_Browser; @@ -335,6 +335,8 @@ package FLTK.Widgets.Groups.Browsers.Textline is + -- Line Numbers -- + function Line_Number (This : in Textline_Browser; Item : in Item_Cursor) diff --git a/spec/fltk-widgets-groups-browsers.ads b/spec/fltk-widgets-groups-browsers.ads index d7b0498..c735fa2 100644 --- a/spec/fltk-widgets-groups-browsers.ads +++ b/spec/fltk-widgets-groups-browsers.ads @@ -56,7 +56,7 @@ package FLTK.Widgets.Groups.Browsers is - -- Access to the Browser's self contained scrollbars + -- Attributes -- function H_Bar (This : in out Browser) @@ -69,7 +69,7 @@ package FLTK.Widgets.Groups.Browsers is - -- Item related settings + -- Items -- function Set_Select (This : in out Browser; @@ -135,7 +135,7 @@ package FLTK.Widgets.Groups.Browsers is - -- Scrollbar related settings + -- Scrollbar Settings -- function Get_Scrollbar_Mode (This : in Browser) @@ -178,7 +178,7 @@ package FLTK.Widgets.Groups.Browsers is - -- Text related settings + -- Text Settings -- function Get_Text_Color (This : in Browser) @@ -207,7 +207,7 @@ package FLTK.Widgets.Groups.Browsers is - -- Graphical dimensions and redrawing + -- Dimensions, Redrawing -- procedure Resize (This : in out Browser; @@ -231,6 +231,8 @@ package FLTK.Widgets.Groups.Browsers is + -- Optional Overrides -- + -- You may override these subprograms to change the behaviour of the widget -- even though these are called from within FLTK. @@ -254,6 +256,8 @@ package FLTK.Widgets.Groups.Browsers is + -- Mandatory Overrides -- + -- You MUST override these subprograms if deriving a type from Browser or your -- program will crash, since they are called from within FLTK and do not have -- any implementations given. By default here they will raise an exception. @@ -318,7 +322,7 @@ package FLTK.Widgets.Groups.Browsers is - -- Cache invalidation + -- Cache Invalidation -- procedure New_List (This : in out Browser); @@ -340,20 +344,6 @@ package FLTK.Widgets.Groups.Browsers is A, B : in Item_Cursor); - - - -- You may override these subprograms to change the behaviour of the widget - -- even though these are called from within FLTK. - - procedure Draw - (This : in out Browser); - - function Handle - (This : in out Browser; - Event : in Event_Kind) - return Event_Outcome; - - private @@ -456,9 +446,6 @@ private pragma Inline (Replacing); pragma Inline (Swapping); - pragma Inline (Draw); - pragma Inline (Handle); - end FLTK.Widgets.Groups.Browsers; diff --git a/spec/fltk-widgets-groups-color_choosers.ads b/spec/fltk-widgets-groups-color_choosers.ads index 4307acd..d3b049f 100644 --- a/spec/fltk-widgets-groups-color_choosers.ads +++ b/spec/fltk-widgets-groups-color_choosers.ads @@ -35,6 +35,8 @@ package FLTK.Widgets.Groups.Color_Choosers is + -- RGB Color -- + function Get_Red (This : in Color_Chooser) return Long_Float; @@ -59,6 +61,8 @@ package FLTK.Widgets.Groups.Color_Choosers is + -- HSV Color -- + function Get_Hue (This : in Color_Chooser) return Long_Float; @@ -83,6 +87,8 @@ package FLTK.Widgets.Groups.Color_Choosers is + -- RGB / HSV Conversion -- + procedure HSV_To_RGB (H, S, V : in Long_Float; R, G, B : out Long_Float); @@ -94,6 +100,8 @@ package FLTK.Widgets.Groups.Color_Choosers is + -- Settings -- + function Get_Mode (This : in Color_Chooser) return Color_Mode; diff --git a/spec/fltk-widgets-groups-help_views.ads b/spec/fltk-widgets-groups-help_views.ads index 8cab6a7..d1dc75b 100644 --- a/spec/fltk-widgets-groups-help_views.ads +++ b/spec/fltk-widgets-groups-help_views.ads @@ -53,6 +53,8 @@ package FLTK.Widgets.Groups.Help_Views is + -- Selection -- + procedure Clear_Selection (This : in out Help_View); @@ -62,6 +64,8 @@ package FLTK.Widgets.Groups.Help_Views is + -- Position -- + function Find (This : in Help_View; Item : in String; @@ -91,6 +95,8 @@ package FLTK.Widgets.Groups.Help_Views is + -- Content -- + function Current_Directory (This : in Help_View) return String; @@ -123,6 +129,8 @@ package FLTK.Widgets.Groups.Help_Views is + -- Settings -- + function Get_Scrollbar_Size (This : in Help_View) return Natural; @@ -170,6 +178,8 @@ package FLTK.Widgets.Groups.Help_Views is + -- Drawing, Events -- + procedure Draw (This : in out Help_View); diff --git a/spec/fltk-widgets-groups-input_choices.ads b/spec/fltk-widgets-groups-input_choices.ads index fb092de..5843c44 100644 --- a/spec/fltk-widgets-groups-input_choices.ads +++ b/spec/fltk-widgets-groups-input_choices.ads @@ -40,6 +40,8 @@ package FLTK.Widgets.Groups.Input_Choices is + -- Attributes -- + function Text_Field (This : in out Input_Choice) return FLTK.Widgets.Inputs.Text.Text_Input_Reference; @@ -51,6 +53,8 @@ package FLTK.Widgets.Groups.Input_Choices is + -- Menu Items -- + function Has_Item (This : in Input_Choice; Place : in FLTK.Widgets.Menus.Index) @@ -71,6 +75,8 @@ package FLTK.Widgets.Groups.Input_Choices is + -- Settings -- + function Has_Changed (This : in Input_Choice) return Boolean; @@ -129,6 +135,8 @@ package FLTK.Widgets.Groups.Input_Choices is + -- Dimensions -- + procedure Resize (This : in out Input_Choice; X, Y, W, H : in Integer); diff --git a/spec/fltk-widgets-groups-packed.ads b/spec/fltk-widgets-groups-packed.ads index 60a6c2a..3d55749 100644 --- a/spec/fltk-widgets-groups-packed.ads +++ b/spec/fltk-widgets-groups-packed.ads @@ -35,6 +35,8 @@ package FLTK.Widgets.Groups.Packed is + -- Settings -- + function Get_Spacing (This : in Packed_Group) return Integer; @@ -54,6 +56,8 @@ package FLTK.Widgets.Groups.Packed is + -- Drawing -- + procedure Draw (This : in out Packed_Group); diff --git a/spec/fltk-widgets-groups-scrolls.ads b/spec/fltk-widgets-groups-scrolls.ads index f4cbad0..116fe42 100644 --- a/spec/fltk-widgets-groups-scrolls.ads +++ b/spec/fltk-widgets-groups-scrolls.ads @@ -27,6 +27,25 @@ package FLTK.Widgets.Groups.Scrolls is Both_Always); + type Region is record + X, Y, W, H : Integer; + end record; + + type Scrollbar_Data is record + X, Y, W, H : Integer; + Size, Total : Natural; + First, Position : Integer; + end record; + + type Scroll_Info is record + Child_Box : Region; + Inner_Inc, Inner_Ex : Region; + H_Needed, V_Needed : Boolean; + H_Data, V_Data : Scrollbar_Data; + Scroll_Size : Natural; + end record; + + package Forge is @@ -47,6 +66,8 @@ package FLTK.Widgets.Groups.Scrolls is + -- Attributes -- + function H_Bar (This : in out Scroll) return Valuators.Sliders.Scrollbars.Scrollbar_Reference; @@ -58,12 +79,16 @@ package FLTK.Widgets.Groups.Scrolls is + -- Contents -- + procedure Clear (This : in out Scroll); + -- Scrolling -- + procedure Scroll_To (This : in out Scroll; X, Y : in Integer); @@ -81,6 +106,8 @@ package FLTK.Widgets.Groups.Scrolls is + -- Scrollbar Settings -- + function Get_Scrollbar_Size (This : in Scroll) return Integer; @@ -100,6 +127,25 @@ package FLTK.Widgets.Groups.Scrolls is + -- Dimensions -- + + procedure Resize + (This : in out Scroll; + X, Y, W, H : in Integer); + + procedure Recalculate_Scrollbars + (This : in Scroll; + Data : out Scroll_Info); + + + + + -- Drawing, Events -- + + procedure Bounding_Box + (This : in Scroll; + X, Y, W, H : out Integer); + procedure Draw (This : in out Scroll); @@ -142,6 +188,9 @@ private pragma Inline (Get_Kind); pragma Inline (Set_Kind); + pragma Inline (Resize); + + pragma Inline (Bounding_Box); pragma Inline (Draw); pragma Inline (Handle); diff --git a/spec/fltk-widgets-groups-spinners.ads b/spec/fltk-widgets-groups-spinners.ads index 3124dc2..681c4d7 100644 --- a/spec/fltk-widgets-groups-spinners.ads +++ b/spec/fltk-widgets-groups-spinners.ads @@ -40,6 +40,8 @@ package FLTK.Widgets.Groups.Spinners is + -- Settings -- + function Get_Background_Color (This : in Spinner) return Color; @@ -83,6 +85,8 @@ package FLTK.Widgets.Groups.Spinners is + -- Values -- + function Get_Minimum (This : in Spinner) return Long_Float; @@ -126,6 +130,8 @@ package FLTK.Widgets.Groups.Spinners is + -- Formatting -- + function Get_Format (This : in Spinner) return String; @@ -145,6 +151,8 @@ package FLTK.Widgets.Groups.Spinners is + -- Dimensions -- + procedure Resize (This : in out Spinner; X, Y, W, H : in Integer); @@ -152,6 +160,8 @@ package FLTK.Widgets.Groups.Spinners is + -- Events -- + function Handle (This : in out Spinner; Event : in Event_Kind) diff --git a/spec/fltk-widgets-groups-tabbed.ads b/spec/fltk-widgets-groups-tabbed.ads index c056d29..a7b8d26 100644 --- a/spec/fltk-widgets-groups-tabbed.ads +++ b/spec/fltk-widgets-groups-tabbed.ads @@ -33,6 +33,8 @@ package FLTK.Widgets.Groups.Tabbed is + -- Child Area -- + procedure Get_Client_Area (This : in Tabbed_Group; Tab_Height : in Natural; @@ -41,6 +43,8 @@ package FLTK.Widgets.Groups.Tabbed is + -- Operation -- + function Get_Push (This : in Tabbed_Group) return access Widget'Class; @@ -65,6 +69,8 @@ package FLTK.Widgets.Groups.Tabbed is + -- Drawing, Events -- + procedure Draw (This : in out Tabbed_Group); diff --git a/spec/fltk-widgets-groups-tables-row.ads b/spec/fltk-widgets-groups-tables-row.ads index e51068a..84d7191 100644 --- a/spec/fltk-widgets-groups-tables-row.ads +++ b/spec/fltk-widgets-groups-tables-row.ads @@ -37,12 +37,16 @@ package FLTK.Widgets.Groups.Tables.Row is + -- Contents Modification -- + procedure Clear (This : in out Row_Table); + -- Rows -- + function Get_Rows (This : in Row_Table) return Natural; @@ -54,6 +58,8 @@ package FLTK.Widgets.Groups.Tables.Row is + -- Selection -- + function Is_Row_Selected (This : in Row_Table; Row : in Positive) @@ -85,6 +91,8 @@ package FLTK.Widgets.Groups.Tables.Row is + -- Drawing, Events -- + procedure Cell_Dimensions (This : in Row_Table; Context : in Table_Context; diff --git a/spec/fltk-widgets-groups-tables.ads b/spec/fltk-widgets-groups-tables.ads index 5b52623..faabc6d 100644 --- a/spec/fltk-widgets-groups-tables.ads +++ b/spec/fltk-widgets-groups-tables.ads @@ -55,6 +55,8 @@ package FLTK.Widgets.Groups.Tables is + -- Attributes -- + function H_Bar (This : in out Table) return Valuators.Sliders.Scrollbars.Scrollbar_Reference; @@ -70,6 +72,8 @@ package FLTK.Widgets.Groups.Tables is + -- Contents Modification -- + procedure Add (This : in out Table; Item : in out Widget'Class); @@ -94,6 +98,8 @@ package FLTK.Widgets.Groups.Tables is + -- Contents Query -- + function Has_Child (This : in Table; Place : in Index) @@ -130,6 +136,8 @@ package FLTK.Widgets.Groups.Tables is + -- Current -- + procedure Begin_Current (This : in out Table); @@ -139,6 +147,8 @@ package FLTK.Widgets.Groups.Tables is + -- Callbacks -- + procedure Set_Callback (This : in out Table; Func : in Widget_Callback); @@ -172,6 +182,8 @@ package FLTK.Widgets.Groups.Tables is + -- Columns -- + function Column_Headers_Enabled (This : in Table) return Boolean; @@ -250,6 +262,8 @@ package FLTK.Widgets.Groups.Tables is + -- Rows -- + function Row_Headers_Enabled (This : in Table) return Boolean; @@ -336,6 +350,8 @@ package FLTK.Widgets.Groups.Tables is + -- Selection -- + procedure Set_Cursor_Kind (This : in out Table; Kind : in Mouse_Cursor_Kind); @@ -403,6 +419,8 @@ package FLTK.Widgets.Groups.Tables is + -- Dimensions -- + function Get_Scrollbar_Size (This : in Table) return Integer; @@ -434,6 +452,8 @@ package FLTK.Widgets.Groups.Tables is + -- Drawing, Events -- + procedure Draw (This : in out Table); diff --git a/spec/fltk-widgets-groups-text_displays-text_editors.ads b/spec/fltk-widgets-groups-text_displays-text_editors.ads index e6355c7..641395b 100644 --- a/spec/fltk-widgets-groups-text_displays-text_editors.ads +++ b/spec/fltk-widgets-groups-text_displays-text_editors.ads @@ -64,6 +64,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Default Key Function -- + procedure KF_Default (This : in out Text_Editor'Class; Key : in Key_Combo); @@ -71,6 +73,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Operation Key Functions -- + procedure KF_Undo (This : in out Text_Editor'Class); @@ -92,6 +96,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Special Key Functions -- + procedure KF_Backspace (This : in out Text_Editor'Class); @@ -110,6 +116,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Movement Key Functions -- + procedure KF_Home (This : in out Text_Editor'Class); @@ -137,6 +145,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Shift Key Functions -- + procedure KF_Shift_Home (This : in out Text_Editor'Class); @@ -164,6 +174,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Control Key Functions -- + procedure KF_Ctrl_Home (This : in out Text_Editor'Class); @@ -191,6 +203,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Control Shift Key Functions -- + procedure KF_Ctrl_Shift_Home (This : in out Text_Editor'Class); @@ -218,6 +232,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Meta Key Functions -- + procedure KF_Meta_Home (This : in out Text_Editor'Class); @@ -245,6 +261,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Meta Shift Key Functions -- + procedure KF_Meta_Shift_Home (This : in out Text_Editor'Class); @@ -272,6 +290,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Default / Global Key Bindings -- + Default_Key_Bindings : constant Key_Binding_Array := ((Mod_None + Escape_Key, KF_Ignore'Access), (Mod_None + Enter_Key, KF_Enter'Access), @@ -349,6 +369,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Key Binding Modification -- + procedure Add_Key_Binding (This : in out Text_Editor; Key : in Key_Combo; @@ -397,6 +419,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Settings -- + function Get_Insert_Mode (This : in Text_Editor) return Insert_Mode; @@ -405,9 +429,6 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is (This : in out Text_Editor; To : in Insert_Mode); - - - function Get_Tab_Mode (This : in Text_Editor) return Tab_Navigation; @@ -419,6 +440,8 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + -- Events -- + function Handle (This : in out Text_Editor; Event : in Event_Kind) @@ -541,7 +564,6 @@ private pragma Inline (Get_Insert_Mode); pragma Inline (Set_Insert_Mode); - pragma Inline (Get_Tab_Mode); pragma Inline (Set_Tab_Mode); diff --git a/spec/fltk-widgets-groups-text_displays.ads b/spec/fltk-widgets-groups-text_displays.ads index c56708a..c057ce0 100644 --- a/spec/fltk-widgets-groups-text_displays.ads +++ b/spec/fltk-widgets-groups-text_displays.ads @@ -26,8 +26,7 @@ package FLTK.Widgets.Groups.Text_Displays is type Cursor_Style is (Normal, Caret, Dim, Block, Heavy, Simple); - - Bounds_Error : exception; + type Position_Kind is (Cursor_Position, Character_Position); @@ -52,29 +51,62 @@ package FLTK.Widgets.Groups.Text_Displays is package Styles is - type Style_Entry is private; + type Style_Entry is record + Hue : Color; + Font : Font_Kind; + Size : Font_Size; + end record; + type Style_Index is new Character range 'A' .. '~'; + type Style_Array is array (Style_Index range <>) of Style_Entry; type Unfinished_Style_Callback is access procedure (Char : in Character; Display : in out Text_Display); - function Item - (Tint : in Color; - Font : in Font_Kind; - Size : in Font_Size) - return Style_Entry; + type Style_Mask is record + Fill : Boolean := False; + Secondary : Boolean := False; + Primary : Boolean := False; + Highlight : Boolean := False; + Background : Boolean := False; + Text_Only : Boolean := False; + end record; + + Empty_Mask : constant Style_Mask; + + type Style_Info is record + Mask : Style_Mask; + Index : Style_Index; + end record; private - type Style_Entry is record - Attr : Interfaces.C.unsigned; - Col : Interfaces.C.unsigned; - Font : Interfaces.C.int; - Size : Interfaces.C.int; + for Style_Entry use record + Hue at 1 * Interfaces.C.unsigned'Size / System.Storage_Unit + range 0 .. Interfaces.C.unsigned'Size - 1; + Font at 2 * Interfaces.C.unsigned'Size / System.Storage_Unit + range 0 .. Interfaces.C.int'Size - 1; + Size at 3 * Interfaces.C.unsigned'Size / System.Storage_Unit + range 0 .. Interfaces.C.int'Size - 1; end record; + for Style_Entry'Size use Interfaces.C.unsigned'Size * 3 + Interfaces.C.int'Size; + + for Style_Mask use record + Fill at 0 range 0 .. 0; + Secondary at 0 range 1 .. 1; + Primary at 0 range 2 .. 2; + Highlight at 0 range 3 .. 3; + Background at 0 range 4 .. 4; + Text_Only at 0 range 5 .. 5; + end record; + + for Style_Mask'Size use Interfaces.C.unsigned_char'Size; + + Empty_Mask : constant Style_Mask := (others => False); + pragma Convention (C, Style_Entry); pragma Convention (C, Style_Array); @@ -83,6 +115,8 @@ package FLTK.Widgets.Groups.Text_Displays is + -- Buffers -- + function Get_Buffer (This : in Text_Display) return FLTK.Text_Buffers.Text_Buffer_Reference; @@ -91,9 +125,23 @@ package FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display; Buff : in out FLTK.Text_Buffers.Text_Buffer); + procedure Buffer_Modified_Callback + (This : in out Text_Display; + Action : in FLTK.Text_Buffers.Modification; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural; + Deleted_Text : in String); + + procedure Buffer_Predelete_Callback + (This : in out Text_Display; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural); + + -- Highlighting -- + procedure Highlight_Data (This : in out Text_Display; Buff : in out FLTK.Text_Buffers.Text_Buffer; @@ -103,12 +151,21 @@ package FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display; Buff : in out FLTK.Text_Buffers.Text_Buffer; Table : in Styles.Style_Array; - Unfinished : in Styles.Style_Index; + Unfinished : in Character; Callback : in Styles.Unfinished_Style_Callback); + function Position_Style + (This : in Text_Display; + Line_Start : in Natural; + Line_Length : in Natural; + Line_Index : in Natural) + return Styles.Style_Info; + + -- Measurement Conversion -- + function Col_To_X (This : in Text_Display; Col_Num : in Integer) @@ -130,8 +187,60 @@ package FLTK.Widgets.Groups.Text_Displays is X, Y : out Integer; Vert_Out : out Boolean); + procedure Find_Line_End + (This : in Text_Display; + Start : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Line_End : out Natural; + Next_Line_Start : out Natural); + + function Find_Character + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index; + X : in Integer) + return Natural; + + function Position_To_Line + (This : in Text_Display; + Position : in Natural) + return Natural; + + function Position_To_Line + (This : in Text_Display; + Position : in Natural; + Displayed : out Boolean) + return Natural; + + procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural); + + procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural; + Displayed : out Boolean); + + function XY_To_Position + (This : in Text_Display; + X, Y : in Integer; + Kind : in Position_Kind := Character_Position) + return Natural; + + procedure XY_To_Row_Column + (This : in Text_Display; + X, Y : in Integer; + Row, Column : out Natural; + Kind : in Position_Kind := Character_Position); + + + -- Cursors -- function Get_Cursor_Color (This : in Text_Display) @@ -154,6 +263,8 @@ package FLTK.Widgets.Groups.Text_Displays is + -- Text Settings -- + function Get_Text_Color (This : in Text_Display) return Color; @@ -181,6 +292,8 @@ package FLTK.Widgets.Groups.Text_Displays is + -- Text Insert -- + procedure Insert_Text (This : in out Text_Display; Item : in String); @@ -203,6 +316,8 @@ package FLTK.Widgets.Groups.Text_Displays is + -- Words -- + function Word_Start (This : in out Text_Display; Pos : in Natural) @@ -219,14 +334,48 @@ package FLTK.Widgets.Groups.Text_Displays is procedure Previous_Word (This : in out Text_Display); + + + + -- Wrapping -- + procedure Set_Wrap_Mode (This : in out Text_Display; Mode : in Wrap_Mode; Margin : in Natural := 0); + function Wrapped_Row + (This : in Text_Display; + Row : in Natural) + return Natural; + + function Wrapped_Column + (This : in Text_Display; + Row, Column : in Natural) + return Natural; + + function Wrap_Uses_Character + (This : in Text_Display; + Line_End : in Natural) + return Boolean; + + procedure Count_Wrapped_Lines + (This : in Text_Display; + Buffer : in FLTK.Text_Buffers.Text_Buffer; + Start : in Natural; + Max_Position, Max_Lines : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Style_Offset : in Natural; + Finish, Line_Count : out Natural; + End_Count_Line_Start : out Natural; + Last_Line_End : out Natural; + Count_Last_Missing_Newline : in Boolean := True); + + -- Lines -- + -- Takes into account word wrap function Line_Start (This : in Text_Display; @@ -259,8 +408,63 @@ package FLTK.Widgets.Groups.Text_Displays is Start, Lines : in Natural) return Natural; + procedure Calculate_Last_Character + (This : in out Text_Display); + + procedure Calculate_Line_Starts + (This : in out Text_Display; + Start, Finish : in Natural); + + procedure Offset_Line_Starts + (This : in out Text_Display; + New_Top : in Natural); + + + + + -- Absolute Lines -- + + procedure Redo_Absolute_Top_Line + (This : in out Text_Display; + Old_First : in Natural); + + function Get_Absolute_Top_Line + (This : in Text_Display) + return Natural; + + procedure Maintain_Absolute_Top_Line + (This : in out Text_Display; + State : in Boolean := True); + + function Maintaining_Absolute_Top_Line + (This : in Text_Display) + return Boolean; + + procedure Reset_Absolute_Top_Line + (This : in out Text_Display); + + + + + -- Visible Lines -- + function Has_Empty_Visible_Lines + (This : in Text_Display) + return Boolean; + function Get_Longest_Visible_Line + (This : in Text_Display) + return Natural; + + function Visible_Line_Length + (This : in Text_Display; + Line : in Natural) + return Natural; + + + + + -- Line Numbers -- function Get_Linenumber_Alignment (This : in Text_Display) @@ -310,27 +514,85 @@ package FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display; Width : in Natural); + function Get_Linenumber_Format + (This : in Text_Display) + return String; + + procedure Set_Linenumber_Format + (This : in out Text_Display; + Value : in String); + + + + + -- Text Measurement -- + + function Measure_Character + (This : in Text_Display; + Text : in String; + X : in Integer; + Index : in Positive) + return Long_Float; + + function Measure_Visible_Line + (This : in Text_Display; + Line : in Natural) + return Natural; + + function Measure_String + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index) + return Long_Float; + + + -- Movement -- procedure Move_Down (This : in out Text_Display); + function Move_Down + (This : in out Text_Display) + return Boolean; + procedure Move_Left (This : in out Text_Display); + function Move_Left + (This : in out Text_Display) + return Boolean; + procedure Move_Right (This : in out Text_Display); + function Move_Right + (This : in out Text_Display) + return Boolean; + procedure Move_Up (This : in out Text_Display); + function Move_Up + (This : in out Text_Display) + return Boolean; + + + -- Scrolling -- procedure Scroll_To - (This : in out Text_Display; - Line : in Natural); + (This : in out Text_Display; + Line : in Natural; + Column : in Natural := 0); + + function Scroll_To + (This : in out Text_Display; + Line : in Natural; + Pixel : in Natural := 0) + return Boolean; function Get_Scrollbar_Alignment (This : in Text_Display) @@ -348,8 +610,46 @@ package FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display; Width : in Natural); + procedure Update_Horizontal_Scrollbar + (This : in out Text_Display); + + procedure Update_Vertical_Scrollbar + (This : in out Text_Display); + + + + + -- Shortcuts -- + + function Get_Shortcut + (This : in Text_Display) + return Key_Combo; + + procedure Set_Shortcut + (This : in out Text_Display; + Value : in Key_Combo); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Text_Display; + X, Y, W, H : in Integer); + + + + -- Drawing, Events -- + procedure Clear_Rect + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y, W, H : in Integer); + + procedure Display_Insert + (This : in out Text_Display); procedure Redisplay_Range (This : in out Text_Display; @@ -358,6 +658,36 @@ package FLTK.Widgets.Groups.Text_Displays is procedure Draw (This : in out Text_Display); + procedure Draw_Cursor + (This : in out Text_Display; + X, Y : in Integer); + + procedure Draw_Line_Numbers + (This : in out Text_Display; + Clear : in Boolean := False); + + procedure Draw_Range + (This : in out Text_Display; + Start, Finish : in Natural); + + procedure Draw_String + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y : in Integer; + Right : in Integer; + Text : in String; + Num_Chars : in Natural); + + procedure Draw_Text + (This : in out Text_Display; + X, Y, W, H : in Integer); + + procedure Draw_Visible_Line + (This : in out Text_Display; + Line : in Natural; + Left_Clip, Right_Clip : in Integer; + Left_Char, Right_Char : in Natural); + function Handle (This : in out Text_Display; Event : in Event_Kind) @@ -409,6 +739,7 @@ private pragma Inline (Get_Buffer); pragma Inline (Set_Buffer); + pragma Inline (Buffer_Predelete_Callback); pragma Inline (Highlight_Data); @@ -416,6 +747,12 @@ private pragma Inline (X_To_Col); pragma Inline (In_Selection); pragma Inline (Position_To_XY); + pragma Inline (Find_Line_End); + pragma Inline (Find_Character); + pragma Inline (Position_To_Line); + pragma Inline (Position_To_Line_Column); + pragma Inline (XY_To_Position); + pragma Inline (XY_To_Row_Column); pragma Inline (Get_Cursor_Color); pragma Inline (Set_Cursor_Color); @@ -440,13 +777,31 @@ private pragma Inline (Word_End); pragma Inline (Next_Word); pragma Inline (Previous_Word); + pragma Inline (Set_Wrap_Mode); + pragma Inline (Wrapped_Row); + pragma Inline (Wrapped_Column); + pragma Inline (Wrap_Uses_Character); + pragma Inline (Count_Wrapped_Lines); pragma Inline (Line_Start); pragma Inline (Line_End); pragma Inline (Count_Lines); pragma Inline (Skip_Lines); pragma Inline (Rewind_Lines); + pragma Inline (Calculate_Last_Character); + pragma Inline (Calculate_Line_Starts); + pragma Inline (Offset_Line_Starts); + + pragma Inline (Redo_Absolute_Top_Line); + pragma Inline (Get_Absolute_Top_Line); + pragma Inline (Maintain_Absolute_Top_Line); + pragma Inline (Maintaining_Absolute_Top_Line); + pragma Inline (Reset_Absolute_Top_Line); + + pragma Inline (Has_Empty_Visible_Lines); + pragma Inline (Get_Longest_Visible_Line); + pragma Inline (Visible_Line_Length); pragma Inline (Get_Linenumber_Alignment); pragma Inline (Set_Linenumber_Alignment); @@ -460,6 +815,12 @@ private pragma Inline (Set_Linenumber_Size); pragma Inline (Get_Linenumber_Width); pragma Inline (Set_Linenumber_Width); + pragma Inline (Get_Linenumber_Format); + pragma Inline (Set_Linenumber_Format); + + pragma Inline (Measure_Character); + pragma Inline (Measure_Visible_Line); + pragma Inline (Measure_String); pragma Inline (Move_Down); pragma Inline (Move_Left); @@ -471,9 +832,24 @@ private pragma Inline (Set_Scrollbar_Alignment); pragma Inline (Get_Scrollbar_Width); pragma Inline (Set_Scrollbar_Width); + pragma Inline (Update_Horizontal_Scrollbar); + pragma Inline (Update_Vertical_Scrollbar); + + pragma Inline (Get_Shortcut); + pragma Inline (Set_Shortcut); + + pragma Inline (Resize); + pragma Inline (Clear_Rect); + pragma Inline (Display_Insert); pragma Inline (Redisplay_Range); pragma Inline (Draw); + pragma Inline (Draw_Cursor); + pragma Inline (Draw_Line_Numbers); + pragma Inline (Draw_Range); + pragma Inline (Draw_String); + pragma Inline (Draw_Text); + pragma Inline (Draw_Visible_Line); pragma Inline (Handle); diff --git a/spec/fltk-widgets-groups-tiled.ads b/spec/fltk-widgets-groups-tiled.ads index 9edaf6b..43c7d51 100644 --- a/spec/fltk-widgets-groups-tiled.ads +++ b/spec/fltk-widgets-groups-tiled.ads @@ -33,6 +33,8 @@ package FLTK.Widgets.Groups.Tiled is + -- Dimensions -- + procedure Position (This : in out Tiled_Group; Old_X, Old_Y : in Integer; @@ -45,6 +47,8 @@ package FLTK.Widgets.Groups.Tiled is + -- Events -- + function Handle (This : in out Tiled_Group; Event : in Event_Kind) diff --git a/spec/fltk-widgets-groups-windows-double-cairo.ads b/spec/fltk-widgets-groups-windows-double-cairo.ads index 8073a81..a5430c4 100644 --- a/spec/fltk-widgets-groups-windows-double-cairo.ads +++ b/spec/fltk-widgets-groups-windows-double-cairo.ads @@ -72,6 +72,8 @@ package FLTK.Widgets.Groups.Windows.Double.Cairo is + -- Cairo Callback -- + procedure Set_Cairo_Draw (This : in out Cairo_Window; Func : in Cairo_Callback); @@ -79,6 +81,8 @@ package FLTK.Widgets.Groups.Windows.Double.Cairo is + -- Drawing -- + procedure Draw (This : in out Cairo_Window); diff --git a/spec/fltk-widgets-groups-windows-double-overlay.ads b/spec/fltk-widgets-groups-windows-double-overlay.ads index bd60292..a6d271c 100644 --- a/spec/fltk-widgets-groups-windows-double-overlay.ads +++ b/spec/fltk-widgets-groups-windows-double-overlay.ads @@ -44,6 +44,8 @@ package FLTK.Widgets.Groups.Windows.Double.Overlay is + -- Visibility -- + procedure Show (This : in out Overlay_Window); @@ -59,6 +61,8 @@ package FLTK.Widgets.Groups.Windows.Double.Overlay is + -- Settings -- + function Can_Do_Overlay (This : in Overlay_Window) return Boolean; @@ -70,6 +74,8 @@ package FLTK.Widgets.Groups.Windows.Double.Overlay is + -- Drawing -- + -- You must override this subprogram procedure Draw_Overlay (This : in out Overlay_Window); diff --git a/spec/fltk-widgets-groups-windows-double.ads b/spec/fltk-widgets-groups-windows-double.ads index ed957ac..f9ccf85 100644 --- a/spec/fltk-widgets-groups-windows-double.ads +++ b/spec/fltk-widgets-groups-windows-double.ads @@ -44,6 +44,8 @@ package FLTK.Widgets.Groups.Windows.Double is + -- Visibility -- + procedure Show (This : in out Double_Window); @@ -62,6 +64,8 @@ package FLTK.Widgets.Groups.Windows.Double is + -- Dimensions -- + procedure Resize (This : in out Double_Window; X, Y, W, H : in Integer); diff --git a/spec/fltk-widgets-groups-windows-opengl.ads b/spec/fltk-widgets-groups-windows-opengl.ads index 2ce374d..825df4f 100644 --- a/spec/fltk-widgets-groups-windows-opengl.ads +++ b/spec/fltk-widgets-groups-windows-opengl.ads @@ -69,9 +69,7 @@ package FLTK.Widgets.Groups.Windows.OpenGL is - --------------- - -- Display -- - --------------- + -- Visibility -- procedure Show (This : in out GL_Window); @@ -91,9 +89,7 @@ package FLTK.Widgets.Groups.Windows.OpenGL is - ------------------ -- Dimensions -- - ------------------ function Pixel_H (This : in GL_Window) @@ -114,9 +110,7 @@ package FLTK.Widgets.Groups.Windows.OpenGL is - -------------------- -- OpenGL Modes -- - -------------------- function Get_Mode (This : in GL_Window) @@ -141,9 +135,7 @@ package FLTK.Widgets.Groups.Windows.OpenGL is - ----------------------- -- OpenGL Contexts -- - ----------------------- function Get_Context (This : in GL_Window) @@ -182,9 +174,7 @@ package FLTK.Widgets.Groups.Windows.OpenGL is - ---------------------------------- - -- Drawing and Event Handling -- - ---------------------------------- + -- Drawing, Events -- procedure Ortho (This : in out GL_Window); diff --git a/spec/fltk-widgets-groups-windows-single-menu.ads b/spec/fltk-widgets-groups-windows-single-menu.ads index 7b89f29..c9dd1ea 100644 --- a/spec/fltk-widgets-groups-windows-single-menu.ads +++ b/spec/fltk-widgets-groups-windows-single-menu.ads @@ -44,6 +44,8 @@ package FLTK.Widgets.Groups.Windows.Single.Menu is + -- Visibility -- + procedure Show (This : in out Menu_Window); @@ -59,6 +61,8 @@ package FLTK.Widgets.Groups.Windows.Single.Menu is + -- Overlay -- + function Is_Overlay (This : in Menu_Window) return Boolean; diff --git a/spec/fltk-widgets-groups-windows-single.ads b/spec/fltk-widgets-groups-windows-single.ads index bcc08a8..1517fbf 100644 --- a/spec/fltk-widgets-groups-windows-single.ads +++ b/spec/fltk-widgets-groups-windows-single.ads @@ -44,6 +44,8 @@ package FLTK.Widgets.Groups.Windows.Single is + -- Visibility -- + procedure Show (This : in out Single_Window); @@ -56,6 +58,8 @@ package FLTK.Widgets.Groups.Windows.Single is + -- Current -- + procedure Make_Current (This : in out Single_Window); diff --git a/spec/fltk-widgets-groups-windows.ads b/spec/fltk-widgets-groups-windows.ads index 6a3233d..e2f9b3e 100644 --- a/spec/fltk-widgets-groups-windows.ads +++ b/spec/fltk-widgets-groups-windows.ads @@ -8,10 +8,6 @@ with FLTK.Images.RGB; -private with - - Interfaces.C.Strings; - package FLTK.Widgets.Groups.Windows is @@ -21,8 +17,6 @@ package FLTK.Widgets.Groups.Windows is type Window_Reference (Data : not null access Window'Class) is limited null record with Implicit_Dereference => Data; - type Border_State is (None, Visible); - type Modal_State is (Normal, Non_Modal, Modal); @@ -57,6 +51,8 @@ package FLTK.Widgets.Groups.Windows is + -- Visibility -- + procedure Show (This : in out Window); @@ -82,11 +78,10 @@ package FLTK.Widgets.Groups.Windows is function Last_Made_Current return access Window'Class; - procedure Free_Position - (This : in out Window); + -- Fullscreen -- function Is_Fullscreen (This : in Window) @@ -109,12 +104,26 @@ package FLTK.Widgets.Groups.Windows is + -- Icons, Cursors -- + procedure Set_Icon (This : in out Window; - Pic : in out FLTK.Images.RGB.RGB_Image'Class); + Pic : in FLTK.Images.RGB.RGB_Image'Class); + + procedure Set_Icons + (This : in out Window; + Pics : in FLTK.Images.RGB.RGB_Image_Array); + + procedure Reset_Icons + (This : in out Window); procedure Set_Default_Icon - (Pic : in out FLTK.Images.RGB.RGB_Image'Class); + (Pic : in FLTK.Images.RGB.RGB_Image'Class); + + procedure Set_Default_Icons + (Pics : in FLTK.Images.RGB.RGB_Image_Array); + + procedure Reset_Default_Icons; function Get_Icon_Label (This : in Window) @@ -130,7 +139,7 @@ package FLTK.Widgets.Groups.Windows is procedure Set_Cursor (This : in out Window; - Pic : in out FLTK.Images.RGB.RGB_Image'Class; + Pic : in FLTK.Images.RGB.RGB_Image'Class; Hot_X, Hot_Y : in Integer); procedure Set_Default_Cursor @@ -140,13 +149,18 @@ package FLTK.Widgets.Groups.Windows is - function Get_Border_State + -- Settings -- + + function Has_Border (This : in Window) - return Border_State; + return Boolean; - procedure Set_Border_State - (This : in out Window; - To : in Border_State); + procedure Set_Border + (This : in out Window; + Value : in Boolean := True); + + procedure Clear_Border + (This : in out Window); function Is_Override (This : in Window) @@ -155,16 +169,35 @@ package FLTK.Widgets.Groups.Windows is procedure Set_Override (This : in out Window); + function Is_Modal + (This : in Window) + return Boolean; + + function Is_Non_Modal + (This : in Window) + return Boolean; + function Get_Modal_State (This : in Window) return Modal_State; + procedure Set_Modal + (This : in out Window); + + procedure Set_Non_Modal + (This : in out Window); + procedure Set_Modal_State - (This : in out Window; - To : in Modal_State); + (This : in out Window; + Value : in Modal_State); + + procedure Clear_Modal_State + (This : in out Window); + + -- Labels, Hotspot, Shape -- function Get_Label (This : in Window) @@ -174,6 +207,10 @@ package FLTK.Widgets.Groups.Windows is (This : in out Window; Text : in String); + procedure Set_Labels + (This : in out Window; + Text, Icon_Text : in String); + procedure Hotspot (This : in out Window; X, Y : in Integer; @@ -184,18 +221,32 @@ package FLTK.Widgets.Groups.Windows is Item : in Widget'Class; Offscreen : in Boolean := False); + procedure Shape + (This : in out Window; + Pic : in FLTK.Images.Image'Class); + + + + + -- Dimensions -- + procedure Set_Size_Range (This : in out Window; Min_W, Min_H : in Integer; Max_W, Max_H, Incre_W, Incre_H : in Integer := 0; Keep_Aspect : in Boolean := False); - procedure Shape - (This : in out Window; - Pic : in out FLTK.Images.Image'Class); - + procedure Resize + (This : in out Window; + X, Y, W, H : in Integer); + function Is_Position_Forced + (This : in Window) + return Boolean; + procedure Force_Position + (This : in out Window; + State : in Boolean := True); function Get_X_Root (This : in Window) @@ -216,9 +267,41 @@ package FLTK.Widgets.Groups.Windows is + -- Class Info -- + + function Get_X_Class + (This : in Window) + return String; + + procedure Set_X_Class + (This : in out Window; + Value : in String); + + function Get_Default_X_Class + return String; + + procedure Set_Default_X_Class + (Value : in String); + + function Is_Menu_Window + (This : in Window) + return Boolean; + + function Is_Tooltip_Window + (This : in Window) + return Boolean; + + + + + -- Drawing, Events -- + procedure Draw (This : in out Window); + procedure Flush + (This : in out Window); + function Handle (This : in out Window; Event : in Event_Kind) @@ -255,7 +338,6 @@ private pragma Inline (Iconify); pragma Inline (Make_Current); pragma Inline (Last_Made_Current); - pragma Inline (Free_Position); pragma Inline (Is_Fullscreen); pragma Inline (Fullscreen_On); @@ -263,31 +345,53 @@ private pragma Inline (Fullscreen_Screens); pragma Inline (Set_Icon); + pragma Inline (Set_Icons); + pragma Inline (Reset_Icons); pragma Inline (Set_Default_Icon); + pragma Inline (Set_Default_Icons); + pragma Inline (Reset_Default_Icons); pragma Inline (Get_Icon_Label); pragma Inline (Set_Icon_Label); pragma Inline (Set_Cursor); pragma Inline (Set_Default_Cursor); - pragma Inline (Get_Border_State); - pragma Inline (Set_Border_State); + pragma Inline (Has_Border); + pragma Inline (Set_Border); + pragma Inline (Clear_Border); pragma Inline (Is_Override); pragma Inline (Set_Override); + pragma Inline (Is_Modal); + pragma Inline (Is_Non_Modal); pragma Inline (Get_Modal_State); + pragma Inline (Set_Modal); + pragma Inline (Set_Non_Modal); pragma Inline (Set_Modal_State); + pragma Inline (Clear_Modal_State); pragma Inline (Get_Label); pragma Inline (Set_Label); + pragma Inline (Set_Labels); pragma Inline (Hotspot); - pragma Inline (Set_Size_Range); pragma Inline (Shape); + pragma Inline (Set_Size_Range); + pragma Inline (Resize); + pragma Inline (Is_Position_Forced); + pragma Inline (Force_Position); pragma Inline (Get_X_Root); pragma Inline (Get_Y_Root); pragma Inline (Get_Decorated_W); pragma Inline (Get_Decorated_H); + pragma Inline (Get_X_Class); + pragma Inline (Set_X_Class); + pragma Inline (Get_Default_X_Class); + pragma Inline (Set_Default_X_Class); + pragma Inline (Is_Menu_Window); + pragma Inline (Is_Tooltip_Window); + pragma Inline (Draw); + pragma Inline (Flush); pragma Inline (Handle); diff --git a/spec/fltk-widgets-groups-wizards.ads b/spec/fltk-widgets-groups-wizards.ads index 0ec0e39..1d748be 100644 --- a/spec/fltk-widgets-groups-wizards.ads +++ b/spec/fltk-widgets-groups-wizards.ads @@ -33,6 +33,8 @@ package FLTK.Widgets.Groups.Wizards is + -- Navigation -- + procedure Next (This : in out Wizard); @@ -42,6 +44,8 @@ package FLTK.Widgets.Groups.Wizards is + -- Visibility -- + function Get_Visible (This : in Wizard) return access Widget'Class; @@ -53,6 +57,8 @@ package FLTK.Widgets.Groups.Wizards is + -- Drawing -- + procedure Draw (This : in out Wizard); diff --git a/spec/fltk-widgets-groups.ads b/spec/fltk-widgets-groups.ads index 33c0cb3..9532084 100644 --- a/spec/fltk-widgets-groups.ads +++ b/spec/fltk-widgets-groups.ads @@ -53,6 +53,8 @@ package FLTK.Widgets.Groups is + -- Contents Modification -- + procedure Add (This : in out Group; Item : in out Widget'Class); @@ -81,6 +83,8 @@ package FLTK.Widgets.Groups is + -- Contents Query -- + function Has_Child (This : in Group; Place : in Index) @@ -113,6 +117,8 @@ package FLTK.Widgets.Groups is + -- Iteration -- + package Group_Iterators is new Ada.Iterator_Interfaces (Cursor, Has_Child); @@ -123,6 +129,8 @@ package FLTK.Widgets.Groups is + -- Clipping -- + function Get_Clip_Mode (This : in Group) return Clip_Mode; @@ -134,6 +142,8 @@ package FLTK.Widgets.Groups is + -- Dimensions -- + procedure Add_Resizable (This : in out Group; Item : in out Widget'Class); @@ -156,6 +166,8 @@ package FLTK.Widgets.Groups is + -- Current -- + function Get_Current return access Group'Class; @@ -171,6 +183,8 @@ package FLTK.Widgets.Groups is + -- Drawing, Events -- + procedure Draw (This : in out Group); diff --git a/spec/fltk-widgets-inputs-text-file.ads b/spec/fltk-widgets-inputs-text-file.ads index 1f2883b..7bc2564 100644 --- a/spec/fltk-widgets-inputs-text-file.ads +++ b/spec/fltk-widgets-inputs-text-file.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Inputs.Text.File is + -- Settings -- + function Get_Down_Box (This : in File_Input) return Box_Kind; @@ -57,6 +59,8 @@ package FLTK.Widgets.Inputs.Text.File is + -- Text Field -- + function Get_Value (This : in File_Input) return String; @@ -68,6 +72,8 @@ package FLTK.Widgets.Inputs.Text.File is + -- Drawing, Events -- + procedure Draw (This : in out File_Input); diff --git a/spec/fltk-widgets-inputs-text-floating_point.ads b/spec/fltk-widgets-inputs-text-floating_point.ads index db4e0ae..3d24652 100644 --- a/spec/fltk-widgets-inputs-text-floating_point.ads +++ b/spec/fltk-widgets-inputs-text-floating_point.ads @@ -4,6 +4,9 @@ -- Released into the public domain +-- Naming this package Float would have caused ambiguity with the Float type + + limited with FLTK.Widgets.Groups; @@ -38,6 +41,8 @@ package FLTK.Widgets.Inputs.Text.Floating_Point is + -- Text Field -- + function Get_Value (This : in Float_Input) return Long_Float; diff --git a/spec/fltk-widgets-inputs-text-secret.ads b/spec/fltk-widgets-inputs-text-secret.ads index cd98283..aa94b45 100644 --- a/spec/fltk-widgets-inputs-text-secret.ads +++ b/spec/fltk-widgets-inputs-text-secret.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Inputs.Text.Secret is + -- Events -- + function Handle (This : in out Secret_Input; Event : in Event_Kind) diff --git a/spec/fltk-widgets-inputs-text-whole_number.ads b/spec/fltk-widgets-inputs-text-whole_number.ads index 9c13dc6..7ff8514 100644 --- a/spec/fltk-widgets-inputs-text-whole_number.ads +++ b/spec/fltk-widgets-inputs-text-whole_number.ads @@ -4,6 +4,9 @@ -- Released into the public domain +-- Naming this package Integer would have caused ambiguity with the Integer type + + limited with FLTK.Widgets.Groups; @@ -38,6 +41,8 @@ package FLTK.Widgets.Inputs.Text.Whole_Number is + -- Text Field -- + function Get_Value (This : in Integer_Input) return Long_Integer; diff --git a/spec/fltk-widgets-inputs-text.ads b/spec/fltk-widgets-inputs-text.ads index c73e869..64ece1c 100644 --- a/spec/fltk-widgets-inputs-text.ads +++ b/spec/fltk-widgets-inputs-text.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Inputs.Text is + -- Drawing, Events -- + procedure Draw (This : in out Text_Input); diff --git a/spec/fltk-widgets-inputs.ads b/spec/fltk-widgets-inputs.ads index c7f9c17..6de80da 100644 --- a/spec/fltk-widgets-inputs.ads +++ b/spec/fltk-widgets-inputs.ads @@ -10,8 +10,7 @@ limited with private with - Interfaces.C.Strings, - System; + Interfaces.C.Strings; package FLTK.Widgets.Inputs is @@ -50,6 +49,8 @@ package FLTK.Widgets.Inputs is + -- Clipboard -- + procedure Copy (This : in out Input; Destination : in Clipboard_Kind := Cut_Paste_Board); @@ -101,6 +102,8 @@ package FLTK.Widgets.Inputs is + -- Readonly, Tabs, Wrap -- + function Is_Readonly (This : in Input) return Boolean; @@ -128,15 +131,17 @@ package FLTK.Widgets.Inputs is + -- Shortcut, Input Position -- + function Get_Kind (This : in Input) return Input_Kind; - function Get_Shortcut_Key + function Get_Shortcut (This : in Input) return Key_Combo; - procedure Set_Shortcut_Key + procedure Set_Shortcut (This : in out Input; To : in Key_Combo); @@ -180,6 +185,8 @@ package FLTK.Widgets.Inputs is + -- Text Field -- + function Index (This : in Input; Place : in Integer) @@ -221,6 +228,8 @@ package FLTK.Widgets.Inputs is + -- Input Size -- + function Get_Maximum_Size (This : in Input) return Natural; @@ -236,6 +245,8 @@ package FLTK.Widgets.Inputs is + -- Cursors, Text Settings -- + function Get_Cursor_Color (This : in Input) return Color; @@ -271,6 +282,8 @@ package FLTK.Widgets.Inputs is + -- Dimensions -- + procedure Resize (This : in out Input; W, H : in Integer); @@ -282,6 +295,8 @@ package FLTK.Widgets.Inputs is + -- Changing Input Type -- + package Extra is procedure Set_Kind @@ -326,8 +341,8 @@ private pragma Inline (Set_Wrap); pragma Inline (Get_Kind); - pragma Inline (Get_Shortcut_Key); - pragma Inline (Set_Shortcut_Key); + pragma Inline (Get_Shortcut); + pragma Inline (Set_Shortcut); pragma Inline (Get_Mark); pragma Inline (Set_Mark); pragma Inline (Get_Position); diff --git a/spec/fltk-widgets-menus-choices.ads b/spec/fltk-widgets-menus-choices.ads index 7a5c225..cda6b64 100644 --- a/spec/fltk-widgets-menus-choices.ads +++ b/spec/fltk-widgets-menus-choices.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Menus.Choices is + -- Selection -- + function Chosen_Index (This : in Choice) return Extended_Index; @@ -63,6 +65,8 @@ package FLTK.Widgets.Menus.Choices is + -- Drawing, Events -- + procedure Draw (This : in out Choice); diff --git a/spec/fltk-widgets-menus-menu_bars-systemwide.ads b/spec/fltk-widgets-menus-menu_bars-systemwide.ads index 77dba9f..08f97d2 100644 --- a/spec/fltk-widgets-menus-menu_bars-systemwide.ads +++ b/spec/fltk-widgets-menus-menu_bars-systemwide.ads @@ -42,6 +42,8 @@ package FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Menu Items -- + procedure Add (This : in out System_Menu_Bar; Text : in String); @@ -133,6 +135,8 @@ package FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Item Query -- + function Item (This : in System_Menu_Bar; Place : in Index) @@ -141,6 +145,8 @@ package FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Label, Shortcut, Flags -- + procedure Set_Only (This : in out System_Menu_Bar; Item : in out FLTK.Menu_Items.Menu_Item); @@ -168,6 +174,8 @@ package FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Global -- + procedure Make_Global (This : in out System_Menu_Bar); @@ -177,6 +185,8 @@ package FLTK.Widgets.Menus.Menu_Bars.Systemwide is + -- Drawing -- + procedure Draw (This : in out System_Menu_Bar); diff --git a/spec/fltk-widgets-menus-menu_bars.ads b/spec/fltk-widgets-menus-menu_bars.ads index fc4b3ce..72c40de 100644 --- a/spec/fltk-widgets-menus-menu_bars.ads +++ b/spec/fltk-widgets-menus-menu_bars.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Menus.Menu_Bars is + -- Drawing, Events -- + procedure Draw (This : in out Menu_Bar); diff --git a/spec/fltk-widgets-menus-menu_buttons.ads b/spec/fltk-widgets-menus-menu_buttons.ads index b265d7c..7a93a6d 100644 --- a/spec/fltk-widgets-menus-menu_buttons.ads +++ b/spec/fltk-widgets-menus-menu_buttons.ads @@ -4,10 +4,6 @@ -- Released into the public domain -with - - FLTK.Menu_Items; - limited with FLTK.Widgets.Groups; @@ -45,6 +41,8 @@ package FLTK.Widgets.Menus.Menu_Buttons is + -- Popup -- + function Get_Popup_Kind (This : in Menu_Button) return Popup_Buttons; @@ -60,6 +58,8 @@ package FLTK.Widgets.Menus.Menu_Buttons is + -- Drawing, Events -- + procedure Draw (This : in out Menu_Button); diff --git a/spec/fltk-widgets-menus.ads b/spec/fltk-widgets-menus.ads index bce29dd..d24ebbe 100644 --- a/spec/fltk-widgets-menus.ads +++ b/spec/fltk-widgets-menus.ads @@ -68,6 +68,8 @@ package FLTK.Widgets.Menus is + -- Menu Items -- + procedure Add (This : in out Menu; Text : in String); @@ -163,6 +165,8 @@ package FLTK.Widgets.Menus is + -- Item Query -- + function Has_Item (This : in Menu; Place : in Index) @@ -224,6 +228,8 @@ package FLTK.Widgets.Menus is + -- Iteration -- + package Menu_Iterators is new Ada.Iterator_Interfaces (Cursor, Has_Item); @@ -234,6 +240,8 @@ package FLTK.Widgets.Menus is + -- Selection -- + function Chosen (This : in Menu) return FLTK.Menu_Items.Menu_Item_Reference; @@ -267,6 +275,8 @@ package FLTK.Widgets.Menus is + -- Label, Shortcut, Flags -- + procedure Set_Only (This : in out Menu; Item : in out FLTK.Menu_Items.Menu_Item); @@ -299,6 +309,8 @@ package FLTK.Widgets.Menus is + -- Text Settings -- + function Get_Text_Color (This : in Menu) return Color; @@ -326,6 +338,8 @@ package FLTK.Widgets.Menus is + -- Miscellaneous -- + function Get_Down_Box (This : in Menu) return Box_Kind; @@ -345,6 +359,8 @@ package FLTK.Widgets.Menus is + -- Menu Item Methods -- + function Popup (This : in Menu; X, Y : in Integer; @@ -380,6 +396,8 @@ package FLTK.Widgets.Menus is + -- Dimensions -- + procedure Resize (This : in out Menu; W, H : in Integer); @@ -387,6 +405,8 @@ package FLTK.Widgets.Menus is + -- Drawing -- + procedure Draw_Item (This : in out Menu; Item : in Index; diff --git a/spec/fltk-widgets-positioners.ads b/spec/fltk-widgets-positioners.ads index 0603239..4e06155 100644 --- a/spec/fltk-widgets-positioners.ads +++ b/spec/fltk-widgets-positioners.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Positioners is + -- Targeting -- + procedure Get_Coords (This : in Positioner; X, Y : out Long_Float); @@ -54,6 +56,8 @@ package FLTK.Widgets.Positioners is + -- X Axis -- + procedure Set_Ecks_Bounds (This : in out Positioner; Low, High : in Long_Float); @@ -94,6 +98,8 @@ package FLTK.Widgets.Positioners is + -- Y Axis -- + procedure Set_Why_Bounds (This : in out Positioner; Low, High : in Long_Float); @@ -134,6 +140,8 @@ package FLTK.Widgets.Positioners is + -- Drawing, Events -- + procedure Draw (This : in out Positioner); diff --git a/spec/fltk-widgets-progress_bars.ads b/spec/fltk-widgets-progress_bars.ads index 01fe674..068f8a7 100644 --- a/spec/fltk-widgets-progress_bars.ads +++ b/spec/fltk-widgets-progress_bars.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Progress_Bars is + -- Values -- + function Get_Minimum (This : in Progress_Bar) return Float; @@ -65,6 +67,8 @@ package FLTK.Widgets.Progress_Bars is + -- Drawing -- + procedure Draw (This : in out Progress_Bar); diff --git a/spec/fltk-widgets-valuators-adjusters.ads b/spec/fltk-widgets-valuators-adjusters.ads index c980d53..fb8fc9f 100644 --- a/spec/fltk-widgets-valuators-adjusters.ads +++ b/spec/fltk-widgets-valuators-adjusters.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Valuators.Adjusters is + -- Allow Outside Range -- + function Is_Soft (This : in Adjuster) return Boolean; @@ -49,6 +51,8 @@ package FLTK.Widgets.Valuators.Adjusters is + -- Drawing, Events -- + procedure Value_Damage (This : in out Adjuster); diff --git a/spec/fltk-widgets-valuators-counters.ads b/spec/fltk-widgets-valuators-counters.ads index fd3cea8..0bea0a6 100644 --- a/spec/fltk-widgets-valuators-counters.ads +++ b/spec/fltk-widgets-valuators-counters.ads @@ -40,6 +40,8 @@ package FLTK.Widgets.Valuators.Counters is + -- Button Steps -- + function Get_Step (This : in Counter) return Long_Float; @@ -63,6 +65,8 @@ package FLTK.Widgets.Valuators.Counters is + -- Text Settings -- + function Get_Text_Color (This : in Counter) return Color; @@ -90,6 +94,8 @@ package FLTK.Widgets.Valuators.Counters is + -- Drawing, Events -- + procedure Draw (This : in out Counter); @@ -101,6 +107,8 @@ package FLTK.Widgets.Valuators.Counters is + -- Counter Type -- + function Get_Kind (This : in out Counter) return Counter_Kind; diff --git a/spec/fltk-widgets-valuators-dials.ads b/spec/fltk-widgets-valuators-dials.ads index 036c6f1..ff16ea6 100644 --- a/spec/fltk-widgets-valuators-dials.ads +++ b/spec/fltk-widgets-valuators-dials.ads @@ -40,6 +40,8 @@ package FLTK.Widgets.Valuators.Dials is + -- Limit Angles -- + function Get_First_Angle (This : in Dial) return Short_Integer; @@ -63,6 +65,8 @@ package FLTK.Widgets.Valuators.Dials is + -- Drawing, Events -- + procedure Draw (This : in out Dial); @@ -84,6 +88,8 @@ package FLTK.Widgets.Valuators.Dials is + -- Dial Type -- + function Get_Kind (This : in Dial) return Dial_Kind; diff --git a/spec/fltk-widgets-valuators-rollers.ads b/spec/fltk-widgets-valuators-rollers.ads index 7a5effc..782fefc 100644 --- a/spec/fltk-widgets-valuators-rollers.ads +++ b/spec/fltk-widgets-valuators-rollers.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Valuators.Rollers is + -- Drawing, Events -- + procedure Draw (This : in out Roller); diff --git a/spec/fltk-widgets-valuators-sliders-scrollbars.ads b/spec/fltk-widgets-valuators-sliders-scrollbars.ads index 79b4c69..5ab2a54 100644 --- a/spec/fltk-widgets-valuators-sliders-scrollbars.ads +++ b/spec/fltk-widgets-valuators-sliders-scrollbars.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Valuators.Sliders.Scrollbars is + -- Line Position -- + function Get_Line_Size (This : in Scrollbar) return Natural; @@ -64,6 +66,8 @@ package FLTK.Widgets.Valuators.Sliders.Scrollbars is + -- Drawing, Events -- + procedure Draw (This : in out Scrollbar); diff --git a/spec/fltk-widgets-valuators-sliders-value.ads b/spec/fltk-widgets-valuators-sliders-value.ads index f9f849f..a68c404 100644 --- a/spec/fltk-widgets-valuators-sliders-value.ads +++ b/spec/fltk-widgets-valuators-sliders-value.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Valuators.Sliders.Value is + -- Text Settings -- + function Get_Text_Color (This : in Value_Slider) return Color; @@ -65,6 +67,8 @@ package FLTK.Widgets.Valuators.Sliders.Value is + -- Drawing, Events -- + procedure Draw (This : in out Value_Slider); diff --git a/spec/fltk-widgets-valuators-sliders.ads b/spec/fltk-widgets-valuators-sliders.ads index 786a9f5..9f4b7db 100644 --- a/spec/fltk-widgets-valuators-sliders.ads +++ b/spec/fltk-widgets-valuators-sliders.ads @@ -56,6 +56,8 @@ package FLTK.Widgets.Valuators.Sliders is + -- Settings -- + procedure Set_Bounds (This : in out Slider; Min, Max : in Long_Float); @@ -86,6 +88,8 @@ package FLTK.Widgets.Valuators.Sliders is + -- Drawing, Events -- + procedure Draw (This : in out Slider); @@ -107,6 +111,8 @@ package FLTK.Widgets.Valuators.Sliders is + -- Slider Type -- + function Get_Kind (This : in Slider) return Slider_Kind; diff --git a/spec/fltk-widgets-valuators-value_inputs.ads b/spec/fltk-widgets-valuators-value_inputs.ads index 7392e78..ba1d66f 100644 --- a/spec/fltk-widgets-valuators-value_inputs.ads +++ b/spec/fltk-widgets-valuators-value_inputs.ads @@ -42,6 +42,8 @@ package FLTK.Widgets.Valuators.Value_Inputs is + -- Attributes -- + function Text_Field (This : in out Value_Input) return FLTK.Widgets.Inputs.Text.Text_Input_Reference; @@ -49,6 +51,8 @@ package FLTK.Widgets.Valuators.Value_Inputs is + -- Cursors -- + function Get_Cursor_Color (This : in Value_Input) return Color; @@ -60,6 +64,8 @@ package FLTK.Widgets.Valuators.Value_Inputs is + -- Shortcut -- + function Get_Shortcut (This : in Value_Input) return Key_Combo; @@ -71,6 +77,8 @@ package FLTK.Widgets.Valuators.Value_Inputs is + -- Allow Outside Range -- + function Is_Soft (This : in Value_Input) return Boolean; @@ -82,6 +90,8 @@ package FLTK.Widgets.Valuators.Value_Inputs is + -- Text Settings -- + function Get_Text_Color (This : in Value_Input) return Color; @@ -109,6 +119,8 @@ package FLTK.Widgets.Valuators.Value_Inputs is + -- Dimensions -- + procedure Resize (This : in out Value_Input; X, Y, W, H : in Integer); @@ -116,6 +128,8 @@ package FLTK.Widgets.Valuators.Value_Inputs is + -- Drawing, Events -- + procedure Draw (This : in out Value_Input); diff --git a/spec/fltk-widgets-valuators-value_outputs.ads b/spec/fltk-widgets-valuators-value_outputs.ads index a8447a7..09c1da5 100644 --- a/spec/fltk-widgets-valuators-value_outputs.ads +++ b/spec/fltk-widgets-valuators-value_outputs.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Valuators.Value_Outputs is + -- Allow Outside Range -- + function Is_Soft (This : in Value_Output) return Boolean; @@ -49,6 +51,8 @@ package FLTK.Widgets.Valuators.Value_Outputs is + -- Text Settings -- + function Get_Text_Color (This : in Value_Output) return Color; @@ -76,6 +80,8 @@ package FLTK.Widgets.Valuators.Value_Outputs is + -- Drawing, Events -- + procedure Draw (This : in out Value_Output); diff --git a/spec/fltk-widgets-valuators.ads b/spec/fltk-widgets-valuators.ads index 1e60f4b..e8180d6 100644 --- a/spec/fltk-widgets-valuators.ads +++ b/spec/fltk-widgets-valuators.ads @@ -38,6 +38,8 @@ package FLTK.Widgets.Valuators is + -- Formatting -- + -- You may override this to change the formatting of the Valuator function Format (This : in Valuator) @@ -46,6 +48,8 @@ package FLTK.Widgets.Valuators is + -- Calculation -- + function Clamp (This : in Valuator; Input : in Long_Float) @@ -65,6 +69,8 @@ package FLTK.Widgets.Valuators is + -- Settings, Value -- + function Get_Minimum (This : in Valuator) return Long_Float; @@ -121,6 +127,8 @@ package FLTK.Widgets.Valuators is + -- Drawing -- + procedure Value_Damage (This : in out Valuator); diff --git a/spec/fltk-widgets.ads b/spec/fltk-widgets.ads index 07f9b2e..67c1625 100644 --- a/spec/fltk-widgets.ads +++ b/spec/fltk-widgets.ads @@ -30,14 +30,6 @@ package FLTK.Widgets is type Widget_Callback is access procedure (Item : in out Widget'Class); - type Callback_Flag is private; - function "+" (Left, Right : in Callback_Flag) return Callback_Flag; - Call_Never : constant Callback_Flag; - When_Changed : constant Callback_Flag; - When_Interact : constant Callback_Flag; - When_Release : constant Callback_Flag; - When_Enter_Key : constant Callback_Flag; - @@ -59,6 +51,8 @@ package FLTK.Widgets is + -- Activity -- + procedure Activate (This : in out Widget); @@ -74,28 +68,53 @@ package FLTK.Widgets is return Boolean; procedure Set_Active + (This : in out Widget); + + procedure Set_Active (This : in out Widget; To : in Boolean); + procedure Clear_Active + (This : in out Widget); + + -- Changed and Output -- + function Has_Changed (This : in Widget) return Boolean; procedure Set_Changed + (This : in out Widget); + + procedure Set_Changed (This : in out Widget; To : in Boolean); + procedure Clear_Changed + (This : in out Widget); + function Is_Output_Only (This : in Widget) return Boolean; procedure Set_Output_Only + (This : in out Widget); + + procedure Set_Output_Only (This : in out Widget; To : in Boolean); + procedure Clear_Output_Only + (This : in out Widget); + + + + + -- Visibility -- + function Is_Visible (This : in Widget) return Boolean; @@ -105,20 +124,40 @@ package FLTK.Widgets is return Boolean; procedure Set_Visible + (This : in out Widget); + + procedure Set_Visible (This : in out Widget; To : in Boolean); + procedure Clear_Visible + (This : in out Widget); + + procedure Show + (This : in out Widget); + + procedure Hide + (This : in out Widget); + + + -- Focus -- function Has_Visible_Focus (This : in Widget) return Boolean; procedure Set_Visible_Focus + (This : in out Widget); + + procedure Set_Visible_Focus (This : in out Widget; To : in Boolean); + procedure Clear_Visible_Focus + (This : in out Widget); + function Take_Focus (This : in out Widget) return Boolean; @@ -130,6 +169,8 @@ package FLTK.Widgets is + -- Colors -- + function Get_Background_Color (This : in Widget) return Color; @@ -146,8 +187,14 @@ package FLTK.Widgets is (This : in out Widget; To : in Color); + procedure Set_Colors + (This : in out Widget; + Back, Sel : in Color); + + + -- Relatives -- function Parent (This : in Widget) @@ -172,13 +219,15 @@ package FLTK.Widgets is return access FLTK.Widgets.Groups.Windows.Window'Class; function Top_Window_Offset - (This : in Widget; - Offset_X, Offset_Y : out Integer) + (This : in Widget; + Offset_X, Offset_Y : out Integer) return access FLTK.Widgets.Groups.Windows.Window'Class; + -- Alignment, Box, Tooltip -- + function Get_Alignment (This : in Widget) return Alignment; @@ -206,6 +255,8 @@ package FLTK.Widgets is + -- Labels -- + function Get_Label (This : in Widget) return String; @@ -214,6 +265,11 @@ package FLTK.Widgets is (This : in out Widget; Text : in String); + procedure Set_Label + (This : in out Widget; + Kind : in Label_Kind; + Text : in String); + function Get_Label_Color (This : in Widget) return Color; @@ -253,6 +309,8 @@ package FLTK.Widgets is + -- Callbacks -- + function Get_Callback (This : in Widget) return Widget_Callback; @@ -264,6 +322,13 @@ package FLTK.Widgets is procedure Do_Callback (This : in out Widget); + procedure Do_Callback + (This : in Widget; + Using : in out Widget); + + procedure Default_Callback + (This : in out Widget'Class); + function Get_When (This : in Widget) return Callback_Flag; @@ -275,6 +340,8 @@ package FLTK.Widgets is + -- Dimensions -- + function Get_X (This : in Widget) return Integer; @@ -295,6 +362,10 @@ package FLTK.Widgets is (This : in out Widget; W, H : in Integer); + procedure Resize + (This : in out Widget; + X, Y, W, H : in Integer); + procedure Reposition (This : in out Widget; X, Y : in Integer); @@ -302,6 +373,8 @@ package FLTK.Widgets is + -- Images -- + function Get_Image (This : in Widget) return access FLTK.Images.Image'Class; @@ -321,26 +394,68 @@ package FLTK.Widgets is + -- Damage, Drawing, Events -- + function Is_Damaged (This : in Widget) return Boolean; - procedure Set_Damaged + function Get_Damage + (This : in Widget) + return Damage_Mask; + + procedure Set_Damage (This : in out Widget; - To : in Boolean); + Mask : in Damage_Mask); - procedure Set_Damaged + procedure Set_Damage (This : in out Widget; - To : in Boolean; + Mask : in Damage_Mask; X, Y, W, H : in Integer); + procedure Clear_Damage + (This : in out Widget; + Mask : in Damage_Mask := Damage_None); + procedure Draw (This : in out Widget); procedure Draw_Label - (This : in Widget; - X, Y, W, H : in Integer; - Align : in Alignment); + (This : in out Widget); + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer); + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer; + Align : in Alignment); + + procedure Draw_Backdrop + (This : in out Widget); + + procedure Draw_Box + (This : in out Widget); + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + Hue : in Color); + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Hue : in Color); + + procedure Draw_Focus + (This : in out Widget); + + procedure Draw_Focus + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer); procedure Redraw (This : in out Widget); @@ -354,6 +469,16 @@ package FLTK.Widgets is return Event_Outcome; + + + -- Miscellaneous -- + + -- Only relevant to MacOS + function Uses_Accents_Menu + (This : in Widget) + return Boolean; + + private @@ -391,15 +516,6 @@ private (This : in out Widget); - type Callback_Flag is new Interfaces.C.unsigned; - - Call_Never : constant Callback_Flag := 0; - When_Changed : constant Callback_Flag := 1; - When_Interact : constant Callback_Flag := 2; - When_Release : constant Callback_Flag := 4; - When_Enter_Key : constant Callback_Flag := 8; - - -- the user data portion should always be a reference back to the Ada binding procedure Callback_Hook (W, U : in Storage.Integer_Address); @@ -457,16 +573,24 @@ private pragma Inline (Is_Active); pragma Inline (Is_Tree_Active); pragma Inline (Set_Active); + pragma Inline (Clear_Active); pragma Inline (Has_Changed); pragma Inline (Set_Changed); + pragma Inline (Clear_Changed); pragma Inline (Is_Output_Only); pragma Inline (Set_Output_Only); + pragma Inline (Clear_Output_Only); + pragma Inline (Is_Visible); pragma Inline (Set_Visible); + pragma Inline (Clear_Visible); + pragma Inline (Show); + pragma Inline (Hide); pragma Inline (Has_Visible_Focus); pragma Inline (Set_Visible_Focus); + pragma Inline (Clear_Visible_Focus); pragma Inline (Take_Focus); pragma Inline (Takes_Events); @@ -474,6 +598,7 @@ private pragma Inline (Set_Background_Color); pragma Inline (Get_Selection_Color); pragma Inline (Set_Selection_Color); + pragma Inline (Set_Colors); pragma Inline (Parent); pragma Inline (Contains); @@ -504,6 +629,7 @@ private pragma Inline (Get_Callback); pragma Inline (Set_Callback); pragma Inline (Do_Callback); + pragma Inline (Default_Callback); pragma Inline (Get_When); pragma Inline (Set_When); @@ -520,13 +646,20 @@ private pragma Inline (Set_Inactive_Image); pragma Inline (Is_Damaged); - pragma Inline (Set_Damaged); + pragma Inline (Get_Damage); + pragma Inline (Set_Damage); pragma Inline (Draw); pragma Inline (Draw_Label); + pragma Inline (Draw_Backdrop); + pragma Inline (Draw_Box); + pragma Inline (Draw_Focus); pragma Inline (Redraw); pragma Inline (Redraw_Label); pragma Inline (Handle); + pragma Inline (Uses_Accents_Menu); + end FLTK.Widgets; + diff --git a/spec/fltk.ads b/spec/fltk.ads index 6e5ef0f..964af79 100644 --- a/spec/fltk.ads +++ b/spec/fltk.ads @@ -6,11 +6,13 @@ with - Ada.Finalization; + Ada.Finalization, + System; private with - Interfaces.C, + Ada.Unchecked_Conversion, + Interfaces.C.Strings, System.Storage_Elements; @@ -33,21 +35,70 @@ package FLTK is -- Text buffers for marshalling purposes will be this size. Buffer_Size : constant Natural := 1024; + -- For image data arrays. + type Size_Type is mod 2 ** System.Word_Size; + subtype Positive_Size is Size_Type range 1 .. Size_Type'Last; - -- Values scale from A/Black to X/White + + -- Color -- + + -- Values scale from A/Black to X/White. type Greyscale is new Character range 'A' .. 'X'; type Color is mod 2**32; type Color_Component is mod 256; - type Color_Component_Array is array (Positive range <>) of aliased Color_Component; + type Color_Component_Array is array (Positive_Size range <>) of aliased Color_Component; + + subtype Blend is Float range 0.0 .. 1.0; + + function RGB_Color + (Light : in Greyscale) + return Color; + + function RGB_Color + (Light : in Color_Component) + return Color; function RGB_Color (R, G, B : in Color_Component) return Color; + function Color_Cube + (R, G, B : in Color_Component) + return Color; + + function Grey_Ramp + (Light : in Greyscale) + return Color; + + function Grey_Ramp + (Light : in Color_Component) + return Color; + + function Darker + (Tone : in Color) + return Color; + + function Lighter + (Tone : in Color) + return Color; + + function Contrast + (Fore, Back : in Color) + return Color; + + function Inactive + (Tone : in Color) + return Color; + + function Color_Average + (Tone1, Tone2 : in Color; + Weight : in Blend := 0.5) + return Color; + -- Examples of RGB colors without the above function -- The lowest byte has to be 00 for the color to be RGB RGB_Red_Color : constant Color := 16#ff000000#; @@ -61,6 +112,9 @@ package FLTK is Inactive_Color : constant Color := 8; Selection_Color : constant Color := 15; + -- X allocation area + Free_Color : constant Color := 16; + -- Standard boxtype colors Grey0_Color : constant Color := 32; Dark3_Color : constant Color := 39; @@ -90,6 +144,8 @@ package FLTK is + -- Alignment -- + -- This should be a bitmask, except there are magic values... type Alignment is private; @@ -124,6 +180,8 @@ package FLTK is + -- Mouse Cursors -- + type Mouse_Cursor_Kind is (Default_Mouse, Arrow_Mouse, @@ -145,14 +203,19 @@ package FLTK is SW_Mouse, W_Mouse, NW_Mouse, - None_Mouse); + None_Mouse) + with Default_Value => Default_Mouse; + -- Keyboard and Mouse Input -- + type Keypress is private; subtype Pressable_Key is Character range Character'Val (32) .. Character'Val (126); + function Press (Key : in Pressable_Key) return Keypress; + Enter_Key : constant Keypress; Keypad_Enter_Key : constant Keypress; Backspace_Key : constant Keypress; @@ -169,20 +232,34 @@ package FLTK is Escape_Key : constant Keypress; Tab_Key : constant Keypress; - type Mouse_Button is (No_Button, Left_Button, Middle_Button, Right_Button); + + type Mouse_Button is + (No_Button, + Left_Button, + Middle_Button, + Right_Button, + Back_Button, + Forward_Button, + Any_Button); + type Key_Combo is private; + function Press (Key : in Pressable_Key) return Key_Combo; function Press (Key : in Keypress) return Key_Combo; function Press (Key : in Mouse_Button) return Key_Combo; + No_Key : constant Key_Combo; + type Modifier is private; + function "+" (Left, Right : in Modifier) return Modifier; function "+" (Left : in Modifier; Right : in Pressable_Key) return Key_Combo; function "+" (Left : in Modifier; Right : in Keypress) return Key_Combo; function "+" (Left : in Modifier; Right : in Mouse_Button) return Key_Combo; function "+" (Left : in Modifier; Right : in Key_Combo) return Key_Combo; + Mod_None : constant Modifier; Mod_Shift : constant Modifier; Mod_Caps_Lock : constant Modifier; @@ -196,86 +273,102 @@ package FLTK is - type Box_Kind is - (No_Box, - Flat_Box, - Up_Box, - Down_Box, - Up_Frame, - Down_Frame, - Thin_Up_Box, - Thin_Down_Box, - Thin_Up_Frame, - Thin_Down_Frame, - Engraved_Box, - Embossed_Box, - Engraved_Frame, - Embossed_Frame, - Border_Box, - Shadow_Box, - Border_Frame, - Shadow_Frame, - Rounded_Box, - RShadow_Box, - Rounded_Frame, - RFlat_Box, - Round_Up_Box, - Round_Down_Box, - Diamond_Up_Box, - Diamond_Down_Box, - Oval_Box, - OShadow_Box, - Oval_Frame, - OFlat_Box, - Plastic_Up_Box, - Plastic_Down_Box, - Plastic_Up_Frame, - Plastic_Down_Frame, - Plastic_Thin_Up_Box, - Plastic_Thin_Down_Box, - Plastic_Round_Up_Box, - Plastic_Round_Down_Box, - Gtk_Up_Box, - Gtk_Down_Box, - Gtk_Up_Frame, - Gtk_Down_Frame, - Gtk_Thin_Up_Box, - Gtk_Thin_Down_Box, - Gtk_Thin_Up_Frame, - Gtk_Thin_Down_Frame, - Gtk_Round_Up_Box, - Gtk_Round_Down_Box, - Gleam_Up_Box, - Gleam_Down_Box, - Gleam_Up_Frame, - Gleam_Down_Frame, - Gleam_Thin_Up_Box, - Gleam_Thin_Down_Box, - Gleam_Round_Up_Box, - Gleam_Round_Down_Box, - Free_Box); - - + -- Box Types -- + type Box_Kind is + (No_Box, + Flat_Box, + Up_Box, + Down_Box, + Up_Frame, + Down_Frame, + Thin_Up_Box, + Thin_Down_Box, + Thin_Up_Frame, + Thin_Down_Frame, + Engraved_Box, + Embossed_Box, + Engraved_Frame, + Embossed_Frame, + Border_Box, + Shadow_Box, + Border_Frame, + Shadow_Frame, + Rounded_Box, + RShadow_Box, + Rounded_Frame, + RFlat_Box, + Round_Up_Box, + Round_Down_Box, + Diamond_Up_Box, + Diamond_Down_Box, + Oval_Box, + OShadow_Box, + Oval_Frame, + OFlat_Box, + Plastic_Up_Box, + Plastic_Down_Box, + Plastic_Up_Frame, + Plastic_Down_Frame, + Plastic_Thin_Up_Box, + Plastic_Thin_Down_Box, + Plastic_Round_Up_Box, + Plastic_Round_Down_Box, + Gtk_Up_Box, + Gtk_Down_Box, + Gtk_Up_Frame, + Gtk_Down_Frame, + Gtk_Thin_Up_Box, + Gtk_Thin_Down_Box, + Gtk_Thin_Up_Frame, + Gtk_Thin_Down_Frame, + Gtk_Round_Up_Box, + Gtk_Round_Down_Box, + Gleam_Up_Box, + Gleam_Down_Box, + Gleam_Up_Frame, + Gleam_Down_Frame, + Gleam_Thin_Up_Box, + Gleam_Thin_Down_Box, + Gleam_Round_Up_Box, + Gleam_Round_Down_Box, + Free_Box); + + function Filled + (Box : in Box_Kind) + return Box_Kind; + + function Frame + (Box : in Box_Kind) + return Box_Kind; + + function Down + (Box : in Box_Kind) + return Box_Kind; + + + + + -- Fonts -- type Font_Kind is - (Helvetica, - Helvetica_Bold, - Helvetica_Italic, - Helvetica_Bold_Italic, - Courier, - Courier_Bold, - Courier_Italic, - Courier_Bold_Italic, - Times, - Times_Bold, - Times_Italic, - Times_Bold_Italic, - Symbol, - Monospace, - Monospace_Bold, - Zapf_Dingbats, - Free_Font); + (Helvetica, + Helvetica_Bold, + Helvetica_Italic, + Helvetica_Bold_Italic, + Courier, + Courier_Bold, + Courier_Italic, + Courier_Bold_Italic, + Times, + Times_Bold, + Times_Italic, + Times_Bold_Italic, + Symbol, + Monospace, + Monospace_Bold, + Zapf_Dingbats, + Free_Font); type Font_Size is new Natural; Normal_Size : constant Font_Size := 14; @@ -285,55 +378,97 @@ package FLTK is + -- Label Types -- + type Label_Kind is - (Normal_Label, - No_Label, - Shadow_Label, - Engraved_Label, - Embossed_Label, - Multi_Label, - Icon_Label, - Image_Label, - Free_Label); + (Normal_Label, + No_Label, + Shadow_Label, + Engraved_Label, + Embossed_Label, + Multi_Label, + Icon_Label, + Image_Label, + Free_Label); + + -- Events -- type Event_Kind is - (No_Event, - Push, - Release, - Enter, - Leave, - Drag, - Focus, - Unfocus, - Keydown, - Keyup, - Close, - Move, - Shortcut, - Deactivate, - Activate, - Hide, - Show, - Paste, - Selection_Clear, - Mouse_Wheel, - DnD_Enter, - DnD_Drag, - DnD_Leave, - DnD_Release, - Screen_Config_Changed, - Fullscreen); + (No_Event, + Push, + Release, + Enter, + Leave, + Drag, + Focus, + Unfocus, + Keydown, + Keyup, + Close, + Move, + Shortcut, + Deactivate, + Activate, + Hide, + Show, + Paste, + Selection_Clear, + Mouse_Wheel, + DnD_Enter, + DnD_Drag, + DnD_Leave, + DnD_Release, + Screen_Config_Changed, + Fullscreen); type Event_Outcome is (Not_Handled, Handled); - type Menu_Flag is private; + -- Callback Flags -- + + type Callback_Flag is record + Changed : Boolean := False; + Interact : Boolean := False; + Release : Boolean := False; + Enter_Key : Boolean := False; + end record; + + function "+" (Left, Right : in Callback_Flag) return Callback_Flag; + function "-" (Left, Right : in Callback_Flag) return Callback_Flag; + + Call_Never : constant Callback_Flag; + When_Changed : constant Callback_Flag; + When_Interact : constant Callback_Flag; + When_Release : constant Callback_Flag; + When_Release_Always : constant Callback_Flag; + When_Enter_Key : constant Callback_Flag; + When_Enter_Key_Always : constant Callback_Flag; + + + + + -- Menu Flags -- + + -- It's easier to have this here rather than in Menu_Items for visibility reasons. + + type Menu_Flag is record + Inactive : Boolean := False; + Toggle : Boolean := False; + Value : Boolean := False; + Radio : Boolean := False; + Invisible : Boolean := False; + Submenu : Boolean := False; + Divider : Boolean := False; + end record; + function "+" (Left, Right : in Menu_Flag) return Menu_Flag; + function "-" (Left, Right : in Menu_Flag) return Menu_Flag; + Flag_Normal : constant Menu_Flag; Flag_Inactive : constant Menu_Flag; Flag_Toggle : constant Menu_Flag; @@ -346,48 +481,64 @@ package FLTK is - type Version_Number is new Natural; - + -- Damage Bits -- + type Damage_Mask is record + Child : Boolean := False; + Expose : Boolean := False; + Scroll : Boolean := False; + Overlay : Boolean := False; + User_1 : Boolean := False; + User_2 : Boolean := False; + Full : Boolean := False; + end record; + function "+" (Left, Right : in Damage_Mask) return Damage_Mask; + function "-" (Left, Right : in Damage_Mask) return Damage_Mask; - function ABI_Check - (ABI_Ver : in Version_Number) - return Boolean; + Damage_None : constant Damage_Mask; + Damage_Child : constant Damage_Mask; + Damage_Expose : constant Damage_Mask; + Damage_Scroll : constant Damage_Mask; + Damage_Overlay : constant Damage_Mask; + Damage_User_1 : constant Damage_Mask; + Damage_User_2 : constant Damage_Mask; + Damage_Full : constant Damage_Mask; - function ABI_Version - return Version_Number; - function API_Version - return Version_Number; - function Version - return Version_Number; + -- Clipboard Attributes -- + Clipboard_Image : constant String; + Clipboard_Plain_Text : constant String; - procedure Awake; - procedure Lock; - procedure Unlock; + -- Versioning -- + type Version_Number is new Natural; + function ABI_Check + (ABI_Ver : in Version_Number) + return Boolean; + function ABI_Version + return Version_Number; - function Is_Damaged - return Boolean; + function API_Version + return Version_Number; - procedure Set_Damaged - (To : in Boolean); + function Version + return Version_Number; - procedure Flush; - procedure Redraw; + -- Event Loop -- + procedure Check; function Check return Boolean; @@ -400,7 +551,7 @@ package FLTK is function Wait (Seconds : in Long_Float) - return Integer; + return Long_Float; function Run return Integer; @@ -437,21 +588,16 @@ private -- Note: This has to be Limited because otherwise the various init subprograms -- wouldn't work, the widget callbacks wouldn't work, deallocation would be -- a mess, really just all sorts of problems. - type Wrapper is new Ada.Finalization.Limited_Controlled with - record - Void_Ptr : Storage.Integer_Address := Null_Pointer; - Needs_Dealloc : Boolean := True; - end record; - - overriding procedure Initialize - (This : in out Wrapper); + type Wrapper is new Ada.Finalization.Limited_Controlled with record + Void_Ptr : Storage.Integer_Address := Null_Pointer; + Needs_Dealloc : Boolean := True; + end record; for Color_Component_Array'Component_Size use Interfaces.C.CHAR_BIT; pragma Convention (C, Color_Component_Array); - pragma Pack (Color_Component_Array); @@ -493,70 +639,70 @@ private -- What delightful magic numbers FLTK cursors are! -- (These correspond to the enum found in Enumerations.H) Cursor_Values : array (Mouse_Cursor_Kind) of Interfaces.C.int := - (Default_Mouse => 0, - Arrow_Mouse => 35, - Crosshair_Mouse => 66, - Wait_Mouse => 76, - Insert_Mouse => 77, - Hand_Mouse => 31, - Help_Mouse => 47, - Move_Mouse => 27, - NS_Mouse => 78, - WE_Mouse => 79, - NWSE_Mouse => 80, - NESW_Mouse => 81, - N_Mouse => 70, - NE_Mouse => 69, - E_Mouse => 49, - SE_Mouse => 8, - S_Mouse => 9, - SW_Mouse => 7, - W_Mouse => 36, - NW_Mouse => 68, - None_Mouse => 255); + (Default_Mouse => 0, + Arrow_Mouse => 35, + Crosshair_Mouse => 66, + Wait_Mouse => 76, + Insert_Mouse => 77, + Hand_Mouse => 31, + Help_Mouse => 47, + Move_Mouse => 27, + NS_Mouse => 78, + WE_Mouse => 79, + NWSE_Mouse => 80, + NESW_Mouse => 81, + N_Mouse => 70, + NE_Mouse => 69, + E_Mouse => 49, + SE_Mouse => 8, + S_Mouse => 9, + SW_Mouse => 7, + W_Mouse => 36, + NW_Mouse => 68, + None_Mouse => 255); type Keypress is new Interfaces.Unsigned_16; type Modifier is new Interfaces.Unsigned_16; - type Key_Combo is - record - Modcode : Modifier; - Keycode : Keypress; - Mousecode : Mouse_Button; - end record; + + type Key_Combo is record + Modcode : Modifier; + Keycode : Keypress; + Mousecode : Mouse_Button; + end record; function To_C (Key : in Key_Combo) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Key_Combo; function To_C (Key : in Keypress) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Keypress; function To_C (Modi : in Modifier) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Modi : in Interfaces.C.int) + (Modi : in Interfaces.C.unsigned) return Modifier; function To_C (Button : in Mouse_Button) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Button : in Interfaces.C.int) + (Button : in Interfaces.C.unsigned) return Mouse_Button; -- these values designed to align with FLTK enumeration types @@ -595,47 +741,127 @@ private - type Menu_Flag is new Interfaces.Unsigned_8; - Flag_Normal : constant Menu_Flag := 2#00000000#; - Flag_Inactive : constant Menu_Flag := 2#00000001#; - Flag_Toggle : constant Menu_Flag := 2#00000010#; - Flag_Value : constant Menu_Flag := 2#00000100#; - Flag_Radio : constant Menu_Flag := 2#00001000#; - Flag_Invisible : constant Menu_Flag := 2#00010000#; - -- Flag_Submenu_Pointer unlikely to be used - Flag_Submenu : constant Menu_Flag := 2#01000000#; - Flag_Divider : constant Menu_Flag := 2#10000000#; + for Callback_Flag use record + Changed at 0 range 0 .. 0; + Interact at 0 range 1 .. 1; + Release at 0 range 2 .. 2; + Enter_Key at 0 range 3 .. 3; + end record; + for Callback_Flag'Size use Interfaces.C.unsigned_char'Size; + Call_Never : constant Callback_Flag := (others => False); + When_Changed : constant Callback_Flag := (Changed => True, others => False); + When_Interact : constant Callback_Flag := (Interact => True, others => False); + When_Release : constant Callback_Flag := (Release => True, others => False); + When_Enter_Key : constant Callback_Flag := (Enter_Key => True, others => False); + When_Release_Always : constant Callback_Flag := + (Release => True, Interact => True, others => False); + When_Enter_Key_Always : constant Callback_Flag := + (Enter_Key => True, Interact => True, others => False); - pragma Import (C, Awake, "fl_awake"); - pragma Import (C, Lock, "fl_lock"); - pragma Import (C, Unlock, "fl_unlock"); + function Flag_To_UChar is new + Ada.Unchecked_Conversion (Callback_Flag, Interfaces.C.unsigned_char); + function UChar_To_Flag is new + Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Callback_Flag); - pragma Import (C, Flush, "fl_flush"); - pragma Import (C, Redraw, "fl_redraw"); + for Menu_Flag use record + Inactive at 0 range 0 .. 0; + Toggle at 0 range 1 .. 1; + Value at 0 range 2 .. 2; + Radio at 0 range 3 .. 3; + Invisible at 0 range 4 .. 4; + -- Submenu_Pointer unused + Submenu at 0 range 6 .. 6; + Divider at 0 range 7 .. 7; + end record; - pragma Inline (ABI_Check); - pragma Inline (ABI_Version); - pragma Inline (API_Version); - pragma Inline (Version); + for Menu_Flag'Size use Interfaces.C.int'Size; + + Flag_Normal : constant Menu_Flag := (others => False); + Flag_Inactive : constant Menu_Flag := (Inactive => True, others => False); + Flag_Toggle : constant Menu_Flag := (Toggle => True, others => False); + Flag_Value : constant Menu_Flag := (Value => True, others => False); + Flag_Radio : constant Menu_Flag := (Radio => True, others => False); + Flag_Invisible : constant Menu_Flag := (Invisible => True, others => False); + -- Flag_Submenu_Pointer unused + Flag_Submenu : constant Menu_Flag := (Submenu => True, others => False); + Flag_Divider : constant Menu_Flag := (Divider => True, others => False); + + function MFlag_To_Cint is new + Ada.Unchecked_Conversion (Menu_Flag, Interfaces.C.int); + + function Cint_To_MFlag is new + Ada.Unchecked_Conversion (Interfaces.C.int, Menu_Flag); + + + + + for Damage_Mask use record + Child at 0 range 0 .. 0; + Expose at 0 range 1 .. 1; + Scroll at 0 range 2 .. 2; + Overlay at 0 range 3 .. 3; + User_1 at 0 range 4 .. 4; + User_2 at 0 range 5 .. 5; + -- bit 6 missing + Full at 0 range 7 .. 7; + end record; + + for Damage_Mask'Size use Interfaces.C.unsigned_char'Size; + + Damage_None : constant Damage_Mask := (others => False); + Damage_Child : constant Damage_Mask := (Child => True, others => False); + Damage_Expose : constant Damage_Mask := (Expose => True, others => False); + Damage_Scroll : constant Damage_Mask := (Scroll => True, others => False); + Damage_Overlay : constant Damage_Mask := (Overlay => True, others => False); + Damage_User_1 : constant Damage_Mask := (User_1 => True, others => False); + Damage_User_2 : constant Damage_Mask := (User_2 => True, others => False); + Damage_Full : constant Damage_Mask := (Full => True, others => False); + + function Mask_To_UChar is new + Ada.Unchecked_Conversion (Damage_Mask, Interfaces.C.unsigned_char); + function UChar_To_Mask is new + Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Damage_Mask); - pragma Inline (Awake); - pragma Inline (Lock); - pragma Inline (Unlock); - pragma Inline (Is_Damaged); - pragma Inline (Set_Damaged); - pragma Inline (Flush); - pragma Inline (Redraw); + clip_image_char_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, clip_image_char_ptr, "fl_clip_image_char_ptr"); + + clip_plain_text_char_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, clip_plain_text_char_ptr, "fl_clip_plain_text_char_ptr"); + + Clipboard_Image : constant String := Interfaces.C.Strings.Value (clip_image_char_ptr); + Clipboard_Plain_Text : constant String := Interfaces.C.Strings.Value (clip_plain_text_char_ptr); + + + + + pragma Inline (RGB_Color); + pragma Inline (Color_Cube); + pragma Inline (Grey_Ramp); + pragma Inline (Darker); + pragma Inline (Lighter); + pragma Inline (Contrast); + pragma Inline (Inactive); + pragma Inline (Color_Average); + + pragma Inline (Filled); + pragma Inline (Frame); + pragma Inline (Down); + + pragma Inline (ABI_Check); + pragma Inline (ABI_Version); + pragma Inline (API_Version); + pragma Inline (Version); pragma Inline (Check); pragma Inline (Ready); @@ -645,3 +871,4 @@ private end FLTK; + diff --git a/test/animated.adb b/test/animated.adb index 42d2a49..4f6f590 100644 --- a/test/animated.adb +++ b/test/animated.adb @@ -34,7 +34,8 @@ is Dimension : constant Integer := 256; - subtype Image_Data is FLTK.Color_Component_Array (1 .. Dimension ** 2 * Channels); + subtype Image_Data is FLTK.Color_Component_Array + (1 .. FLTK.Size_Type (Dimension ** 2 * Channels)); type Image_Data_Array is array (Positive range <>) of Image_Data; @@ -43,7 +44,7 @@ is begin for X in Integer range 0 .. 9 loop for Y in Integer range 0 .. 9 loop - Store (Y * Dimension * Channels + X * Channels + 4) := 255; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 4)) := 255; end loop; end loop; end Black_Box_Corner; @@ -82,10 +83,10 @@ is My_Alpha := FLTK.Color_Component (Float (My_Alpha) * (1.0 - Fill) * 10.0); end if; - Store (Y * Dimension * Channels + X * Channels + 1) := Grey; - Store (Y * Dimension * Channels + X * Channels + 2) := Grey; - Store (Y * Dimension * Channels + X * Channels + 3) := Grey; - Store (Y * Dimension * Channels + X * Channels + 4) := My_Alpha; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 1)) := Grey; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 2)) := Grey; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 3)) := Grey; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 4)) := My_Alpha; end if; end loop; end loop; @@ -106,8 +107,10 @@ is if (X + X_Offset >= 0) and (X + X_Offset < Dimension) then for Y in Integer range Y_Offset - W .. Y_Offset + W - 1 loop Grey := FLTK.Color_Component (abs (Y - Y_Offset)); - Store (Y * Dimension * Channels + (X + X_Offset) * Channels + 3) := Grey; - Store (Y * Dimension * Channels + (X + X_Offset) * Channels + 4) := 127; + Store (FLTK.Size_Type + (Channels * (Y * Dimension + (X + X_Offset)) + 3)) := Grey; + Store (FLTK.Size_Type + (Channels * (Y * Dimension + (X + X_Offset)) + 4)) := 127; end loop; end if; end loop; @@ -130,7 +133,7 @@ is Frame_Image_Data : constant Image_Data_Array := Make_Image_Data; -- This syntax requires Ada 2022, but it allows all overt heap usage to be avoided - Frame_Images : array (Positive range <>) of RGB.RGB_Image := + Frame_Images : constant array (Positive range <>) of RGB.RGB_Image := (for Index in Frame_Image_Data'Range => RGB.Forge.Create (Frame_Image_Data (Index), Dimension, Dimension, Channels)); diff --git a/test/ask.adb b/test/ask.adb index cb12fff..81ab104 100644 --- a/test/ask.adb +++ b/test/ask.adb @@ -16,7 +16,6 @@ with FLTK.Widgets.Boxes, FLTK.Widgets.Buttons, FLTK.Widgets.Buttons.Enter, - FLTK.Widgets.Inputs.Text, FLTK.Widgets.Groups.Windows.Double; use type @@ -38,7 +37,6 @@ is package BX renames FLTK.Widgets.Boxes; package BTN renames FLTK.Widgets.Buttons; package ENT renames FLTK.Widgets.Buttons.Enter; - package INP renames FLTK.Widgets.Inputs.Text; package WD renames FLTK.Widgets.Groups.Windows.Double; @@ -54,7 +52,7 @@ is procedure Rename_Me (Item : in out FLTK.Widgets.Widget'Class) is - Input : String := AK.Text_Input ("Input:", Item.Get_Label); + Input : constant String := AK.Text_Input ("Input:", Item.Get_Label); begin Update_Input_Text (Item, Input); end Rename_Me; @@ -63,7 +61,7 @@ is procedure Rename_Me_Pwd (Item : in out FLTK.Widgets.Widget'Class) is - Input : String := AK.Password ("Input PWD:", Item.Get_Label); + Input : constant String := AK.Password ("Input PWD:", Item.Get_Label); begin Update_Input_Text (Item, Input); end Rename_Me_Pwd; @@ -72,7 +70,7 @@ is procedure Window_Callback (Item : in out FLTK.Widgets.Widget'Class) is - Hotspot : Boolean := AK.Get_Message_Hotspot; + Hotspot : constant Boolean := AK.Get_Message_Hotspot; Reply : AK.Choice_Result; begin AK.Set_Message_Hotspot (False); @@ -91,7 +89,7 @@ is Stop : Boolean := False; procedure Timer_Callback is - Message_Icon : BX.Box_Reference := AK.Get_Message_Icon; + Message_Icon : constant BX.Box_Reference := AK.Get_Message_Icon; My_Color : FLTK.Color; begin if Stop then diff --git a/test/bitmap.adb b/test/bitmap.adb index e6d5094..04f4793 100644 --- a/test/bitmap.adb +++ b/test/bitmap.adb @@ -10,7 +10,6 @@ with FLTK.Images.Bitmaps, - FLTK.Widgets.Buttons, FLTK.Widgets.Buttons.Toggle, FLTK.Widgets.Groups.Windows.Double; @@ -118,7 +117,7 @@ is procedure Button_Callback - (Item : in out FLTK.Widgets.Widget'Class) + (Ignore : in out FLTK.Widgets.Widget'Class) is New_Align : FLTK.Alignment; begin diff --git a/test/button.adb b/test/button.adb new file mode 100644 index 0000000..1cd6557 --- /dev/null +++ b/test/button.adb @@ -0,0 +1,67 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Button/callback test program functionality reproduced in Ada + + +with + + Ada.Command_Line, + FLTK.Asks, + FLTK.Widgets.Buttons, + FLTK.Widgets.Groups.Windows; + + +function Button + return Integer +is + + + package ACom renames Ada.Command_Line; + + package Ask renames FLTK.Asks; + package Wdg renames FLTK.Widgets; + package Btn renames FLTK.Widgets.Buttons; + package Win renames FLTK.Widgets.Groups.Windows; + + + procedure Beep_Callback + (Ignore : in out Wdg.Widget'Class) is + begin + Ask.Beep; + end Beep_Callback; + + + The_Window : Win.Window := Win.Forge.Create (320, 65); + + + procedure Exit_Callback + (Ignore : in out Wdg.Widget'Class) is + begin + ACom.Set_Exit_Status (ACom.Success); + The_Window.Hide; + end Exit_Callback; + + + Button_One : Btn.Button := Btn.Forge.Create (The_Window, 20, 20, 80, 25, "&Beep"); + Button_Two : Btn.Button := Btn.Forge.Create (The_Window, 120, 20, 80, 25, "&No Op"); + Button_Three : Btn.Button := Btn.Forge.Create (The_Window, 220, 20, 80, 25, "E&xit"); + + +begin + + + Button_One.Set_Callback (Beep_Callback'Unrestricted_Access); + Button_Three.Set_Callback (Exit_Callback'Unrestricted_Access); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Button; + + diff --git a/test/buttons.adb b/test/buttons.adb new file mode 100644 index 0000000..a502f44 --- /dev/null +++ b/test/buttons.adb @@ -0,0 +1,58 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Another button test program functionality reproduced in Ada + + +with + + FLTK.Widgets.Buttons.Enter, + FLTK.Widgets.Buttons.Light.Check, + FLTK.Widgets.Buttons.Light.Round, + FLTK.Widgets.Buttons.Repeat, + FLTK.Widgets.Groups.Windows; + + +function Buttons + return Integer +is + + + package Btn renames FLTK.Widgets.Buttons; + package Ent renames FLTK.Widgets.Buttons.Enter; + package Lit renames FLTK.Widgets.Buttons.Light; + package Chk renames FLTK.Widgets.Buttons.Light.Check; + package Ond renames FLTK.Widgets.Buttons.Light.Round; + package Rpt renames FLTK.Widgets.Buttons.Repeat; + package Win renames FLTK.Widgets.Groups.Windows; + + + The_Win : Win.Window := Win.Forge.Create (320, 130); + + + Base : Btn.Button := Btn.Forge.Create (The_Win, 10, 10, 130, 30, "Fl_Button"); + + + Enter : Ent.Enter_Button := Ent.Forge.Create (The_Win, 150, 10, 160, 30, "Fl_Return_Button"); + Repeat : Rpt.Repeat_Button := Rpt.Forge.Create (The_Win, 10, 50, 130, 30, "Fl_Repeat_Button"); + Light : Lit.Light_Button := Lit.Forge.Create (The_Win, 10, 90, 130, 30, "Fl_Light_Button"); + Round : Ond.Round_Button := Ond.Forge.Create (The_Win, 150, 50, 160, 30, "Fl_Round_Button"); + Check : Chk.Check_Button := Chk.Forge.Create (The_Win, 150, 90, 160, 30, "Fl_Check_Button"); + + +begin + + + Base.Set_Tooltip ("This is a Tooltip."); + + The_Win.Show_With_Args; + + return FLTK.Run; + + +end Buttons; + + diff --git a/test/clock.adb b/test/clock.adb new file mode 100644 index 0000000..e550941 --- /dev/null +++ b/test/clock.adb @@ -0,0 +1,50 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Clock test program functionality reproduced in Ada + + +with + + FLTK.Widgets.Clocks.Updated.Round, + FLTK.Widgets.Groups.Windows.Double; + + +function Clock + return Integer +is + + + package CL renames FLTK.Widgets.Clocks.Updated; + package CR renames FLTK.Widgets.Clocks.Updated.Round; + package WD renames FLTK.Widgets.Groups.Windows.Double; + + + Window_One : WD.Double_Window := WD.Forge.Create (220, 220, "Fl_Clock"); + Clock_One : constant CL.Updated_Clock := CL.Forge.Create (Window_One, 0, 0, 220, 220); + + Window_Two : WD.Double_Window := WD.Forge.Create (220, 220, "Fl_Round_Clock"); + Clock_Two : constant CR.Round_Clock := CR.Forge.Create (Window_Two, 0, 0, 220, 220); + + +begin + + + Window_One.Set_Resizable (Clock_One); + Window_Two.Set_Resizable (Clock_Two); + + Window_One.Set_X_Class ("Fl_Clock"); + Window_Two.Set_X_Class ("Fl_Clock"); + + Window_One.Show_With_Args; + Window_Two.Show; + + return FLTK.Run; + + +end Clock; + + diff --git a/test/color_chooser.adb b/test/color_chooser.adb new file mode 100644 index 0000000..1c7537c --- /dev/null +++ b/test/color_chooser.adb @@ -0,0 +1,164 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Color chooser test program functionality reproduced in Ada + + +with + + FLTK.Asks, + FLTK.Draw, + FLTK.Images.RGB, + FLTK.Static, + FLTK.Widgets.Boxes, + FLTK.Widgets.Buttons, + FLTK.Widgets.Groups.Color_Choosers, + FLTK.Widgets.Groups.Windows; + +use type + + FLTK.Color, + FLTK.Size_Type, + FLTK.Asks.Confirm_Result; + + +function Color_Chooser + return Integer +is + + + package Ask renames FLTK.Asks; + package FD renames FLTK.Draw; + package Img renames FLTK.Images.RGB; + package Stc renames FLTK.Static; + package Bx renames FLTK.Widgets.Boxes; + package Btn renames FLTK.Widgets.Buttons; + package CC renames FLTK.Widgets.Groups.Color_Choosers; + package Win renames FLTK.Widgets.Groups.Windows; + + + function Make_Image_Data + (W, H : in Positive) + return FLTK.Color_Component_Array + is + X_Frac, Y_Frac : Long_Float; + Offset : FLTK.Size_Type; + begin + return Data : FLTK.Color_Component_Array (1 .. FLTK.Size_Type (W * H * 3)) do + for Y in 0 .. H - 1 loop + Y_Frac := Long_Float (Y) / Long_Float (H - 1); + for X in 0 .. W - 1 loop + X_Frac := Long_Float (X) / Long_Float (W - 1); + Offset := 3 * FLTK.Size_Type (Y * W + X); + Data (Offset + 1) := + FLTK.Color_Component (255.0 * (1.0 - X_Frac) * (1.0 - Y_Frac)); + Data (Offset + 2) := + FLTK.Color_Component (255.0 * (1.0 - X_Frac) * Y_Frac); + Data (Offset + 3) := + FLTK.Color_Component (255.0 * X_Frac * Y_Frac); + end loop; + end loop; + end return; + end Make_Image_Data; + + + Image_Width, Image_Height : constant Natural := 100; + + The_Image_Data : constant FLTK.Color_Component_Array := + Make_Image_Data (Image_Width, Image_Height); + + + type Pens is new Bx.Box with null record; + + procedure Draw + (This : in out Pens) is + begin + for Offset in 0 .. 3 * 8 - 1 loop + FD.Set_Color (FLTK.Grey0_Color + FLTK.Color (Offset)); + FD.Line + (This.Get_X + Offset, This.Get_Y, + This.Get_X + Offset, This.Get_Y + This.Get_H); + end loop; + end Draw; + + + The_Window : Win.Window := Win.Forge.Create (400, 400); + + The_Box : Bx.Box := Bx.Forge.Create + (The_Window, 30, 30, 340, 340); + Hint_Box : Bx.Box := Bx.Forge.Create + (The_Window, 40, 40, 320, 30, "Pick background color with buttons:"); + + Button_One : Btn.Button := Btn.Forge.Create + (The_Window, 120, 80, 180, 30, "fl_show_colormap()"); + Button_Two : Btn.Button := Btn.Forge.Create + (The_Window, 120, 120, 180, 30, "fl_color_chooser()"); + + Image_Box : Bx.Box := Bx.Forge.Create (The_Window, 160, 190, Image_Width, Image_Height); + The_Image : Img.RGB_Image := Img.Forge.Create (The_Image_Data, Image_Width, Image_Height); + + Box_B : Bx.Box := Bx.Forge.Create (The_Window, 160, 310, 120, 30, "Example of fl_draw_image()"); + + My_Pens : Pens := + (Bx.Forge.Create (The_Window, 60, 180, 3 * 8, 120, "lines") + with null record); + + My_Color : FLTK.Color := FLTK.Background_Color; + + + procedure Callback_One + (Ignore : in out FLTK.Widgets.Widget'Class) is + begin + My_Color := Ask.Show_Colormap (My_Color); + The_Box.Set_Background_Color (My_Color); + Hint_Box.Set_Label_Color (FLTK.Contrast (FLTK.Black_Color, My_Color)); + The_Box.Parent.Redraw; + end Callback_One; + + + procedure Callback_Two + (Ignore : in out FLTK.Widgets.Widget'Class) + is + R, G, B : FLTK.Color_Component; + begin + Stc.Get_Color (My_Color, R, G, B); + if Ask.Color_Chooser ("New color:", R, G, B, CC.HSV) = Ask.Cancel then + return; + end if; + My_Color := FLTK.Free_Color; + Stc.Set_Color (FLTK.Free_Color, R, G, B); + The_Box.Set_Background_Color (FLTK.Free_Color); + Hint_Box.Set_Label_Color (FLTK.Contrast (FLTK.Black_Color, FLTK.Free_Color)); + The_Box.Parent.Redraw; + end Callback_Two; + + +begin + + + Stc.Set_Color (FLTK.Free_Color, 145, 159, 170); + My_Color := FLTK.Free_Color; + + The_Box.Set_Box (FLTK.Thin_Down_Box); + The_Box.Set_Background_Color (My_Color); + + Hint_Box.Set_Alignment (FLTK.Align_Inside); + + Button_One.Set_Callback (Callback_One'Unrestricted_Access); + Button_Two.Set_Callback (Callback_Two'Unrestricted_Access); + + Image_Box.Set_Image (The_Image); + + My_Pens.Set_Alignment (FLTK.Align_Top); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Color_Chooser; + + diff --git a/test/compare.adb b/test/compare.adb index 2273414..a631416 100644 --- a/test/compare.adb +++ b/test/compare.adb @@ -15,11 +15,11 @@ procedure Compare is package TIO renames Ada.Text_IO; package FFN renames FLTK.Filenames; - Aardvark : String := "aardvark"; - Zebra : String := "Zebra"; - Two : String := "item_2"; - Ten : String := "item_10"; - Cap_Ten : String := "Item_10"; + Aardvark : constant String := "aardvark"; + Zebra : constant String := "Zebra"; + Two : constant String := "item_2"; + Ten : constant String := "item_10"; + Cap_Ten : constant String := "Item_10"; begin diff --git a/test/cursor.adb b/test/cursor.adb new file mode 100644 index 0000000..93d3f2b --- /dev/null +++ b/test/cursor.adb @@ -0,0 +1,116 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Cursor test program functionality reproduced in Ada + + +with + + FLTK.Draw, + FLTK.Widgets.Groups.Windows.Double, + FLTK.Widgets.Menus.Choices, + FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + +use type + + FLTK.Callback_Flag; + + +function Cursor + return Integer +is + + + package FD renames FLTK.Draw; + package WD renames FLTK.Widgets.Groups.Windows.Double; + package MC renames FLTK.Widgets.Menus.Choices; + package HV renames FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + + The_Cursor : FLTK.Mouse_Cursor_Kind := FLTK.Default_Mouse; + + Cursor_Index_Low : constant Long_Float := + Long_Float (FLTK.Mouse_Cursor_Kind'Pos (FLTK.Mouse_Cursor_Kind'First)); + Cursor_Index_High : constant Long_Float := + Long_Float (FLTK.Mouse_Cursor_Kind'Pos (FLTK.Mouse_Cursor_Kind'Last)); + + + The_Window : WD.Double_Window := WD.Forge.Create (400, 300); + + The_Choices : MC.Choice := MC.Forge.Create + (The_Window, 80, 100, 200, 25, "Cursor:"); + + The_Slider : HV.Horizontal_Value_Slider := HV.Forge.Create + (The_Window, 80, 180, 310, 30, "Cursor:"); + + + procedure Choice_Callback + (This : in out FLTK.Widgets.Widget'Class) + is + My_Choice : MC.Choice renames MC.Choice (This); + begin + The_Cursor := FLTK.Mouse_Cursor_Kind'Val (My_Choice.Chosen_Index - 1); + The_Slider.Set_Value (Long_Float (FLTK.Mouse_Cursor_Kind'Pos (The_Cursor))); + FD.Set_Cursor (The_Cursor); + end Choice_Callback; + + + procedure Slider_Callback + (This : in out FLTK.Widgets.Widget'Class) + is + My_Slider : HV.Horizontal_Value_Slider renames HV.Horizontal_Value_Slider (This); + begin + The_Cursor := FLTK.Mouse_Cursor_Kind'Val (Integer (My_Slider.Get_Value)); + The_Choices.Set_Chosen (FLTK.Mouse_Cursor_Kind'Pos (The_Cursor) + 1); + FD.Set_Cursor (The_Cursor); + end Slider_Callback; + + +begin + + + The_Choices.Add ("FL_CURSOR_DEFAULT", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_ARROW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_CROSS", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_WAIT", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_INSERT", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_HAND", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_HELP", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_MOVE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NS", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_WE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NWSE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NESW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_N", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_E", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_SE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_S", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_SW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_W", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NONE", Choice_Callback'Unrestricted_Access); + + The_Choices.Set_Callback (Choice_Callback'Unrestricted_Access); + The_Choices.Set_When (FLTK.When_Release + FLTK.When_Interact); + The_Choices.Set_Chosen (1); + + The_Slider.Set_Alignment (FLTK.Align_Left); + The_Slider.Set_Step_Bottom (1); + The_Slider.Set_Precision (0); + The_Slider.Set_Bounds (Cursor_Index_Low, Cursor_Index_High); + The_Slider.Set_Value (Cursor_Index_Low); + The_Slider.Set_Callback (Slider_Callback'Unrestricted_Access); + + The_Window.Set_Resizable (The_Window); + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Cursor; + + diff --git a/test/curve.adb b/test/curve.adb new file mode 100644 index 0000000..45269e8 --- /dev/null +++ b/test/curve.adb @@ -0,0 +1,164 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Curve drawing test program functionality duplicated in Ada + + +pragma Ada_2022; + + +with + + FLTK.Draw, + FLTK.Widgets.Buttons.Toggle, + FLTK.Widgets.Groups.Windows.Double, + FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + +function Curve + return Integer +is + + + package FDR renames FLTK.Draw; + package Tog renames FLTK.Widgets.Buttons.Toggle; + package WD renames FLTK.Widgets.Groups.Windows.Double; + package HV renames FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + + -- More convenient to have these all as floats instead of integers + Arg_Values : array (Positive range <>) of aliased Long_Float := + (20.0, 20.0, 50.0, 200.0, 100.0, 20.0, 200.0, 200.0, 0.0); + + Points : Boolean := False; + + + type Drawing_Widget is new FLTK.Widgets.Widget with null record; + + procedure Draw + (This : in out Drawing_Widget) is + begin + FDR.Push_Clip (This.Get_X, This.Get_Y, This.Get_W, This.Get_H); + FDR.Set_Color (FLTK.Dark3_Color); + FDR.Rect_Fill (This.Get_X, This.Get_Y, This.Get_W, This.Get_H); + FDR.Push_Matrix; + if Arg_Values (9) > 0.001 then + FDR.Translate + (Long_Float (This.Get_X) + Long_Float (This.Get_W) / 2.0, + Long_Float (This.Get_Y) + Long_Float (This.Get_H) / 2.0); + FDR.Rotate (Arg_Values (9)); + FDR.Translate + (-1.0 * (Long_Float (This.Get_X) + Long_Float (This.Get_W) / 2.0), + -1.0 * (Long_Float (This.Get_Y) + Long_Float (This.Get_H) / 2.0)); + end if; + FDR.Translate (Long_Float (This.Get_X), Long_Float (This.Get_Y)); + if not Points then + FDR.Set_Color (FLTK.White_Color); + FDR.Begin_Complex_Polygon; + FDR.Curve + (Arg_Values (1), Arg_Values (2), Arg_Values (3), Arg_Values (4), + Arg_Values (5), Arg_Values (6), Arg_Values (7), Arg_Values (8)); + FDR.End_Complex_Polygon; + end if; + FDR.Set_Color (FLTK.Black_Color); + FDR.Begin_Line; + FDR.Vertex (Arg_Values (1), Arg_Values (2)); + FDR.Vertex (Arg_Values (3), Arg_Values (4)); + FDR.Vertex (Arg_Values (5), Arg_Values (6)); + FDR.Vertex (Arg_Values (7), Arg_Values (8)); + FDR.End_Line; + FDR.Set_Color ((if Points then FLTK.White_Color else FLTK.Red_Color)); + if Points then FDR.Begin_Points; else FDR.Begin_Line; end if; + FDR.Curve + (Arg_Values (1), Arg_Values (2), Arg_Values (3), Arg_Values (4), + Arg_Values (5), Arg_Values (6), Arg_Values (7), Arg_Values (8)); + if Points then FDR.End_Points; else FDR.End_Line; end if; + FDR.Pop_Matrix; + FDR.Pop_Clip; + end Draw; + + + The_Window : WD.Double_Window := WD.Forge.Create (300, 555, "Curve Testing"); + + The_Drawing : Drawing_Widget := + (FLTK.Widgets.Forge.Create (The_Window, 10, 10, 280, 280) + with null record); + + The_Toggle : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 50, 525, 50, 25, "points"); + + + type My_Slider is new HV.Horizontal_Value_Slider with record + Index : Integer range Arg_Values'Range; + end record; + + X0_Str : aliased constant String := "X0"; + Y0_Str : aliased constant String := "Y0"; + X1_Str : aliased constant String := "X1"; + Y1_Str : aliased constant String := "Y1"; + X2_Str : aliased constant String := "X2"; + Y2_Str : aliased constant String := "Y2"; + X3_Str : aliased constant String := "X3"; + Y3_Str : aliased constant String := "Y3"; + Rotate_Str : aliased constant String := "rotate"; + + -- A straight up array of strings is not possible because of the different lengths + Slider_Labels : constant array (Positive range <>) of access constant String := + (X0_Str'Access, Y0_Str'Access, X1_Str'Access, Y1_Str'Access, + X2_Str'Access, Y2_Str'Access, X3_Str'Access, Y3_Str'Access, Rotate_Str'Access); + + -- This syntax requires Ada 2022, but it allows all overt heap usage to be avoided + Sliders : array (Positive range <>) of My_Slider := + (for Place in Slider_Labels'Range => + (HV.Forge.Create (The_Window, 50, 275 + Place * 25, 240, 25, Slider_Labels (Place).all) + with Index => Place)); + + + procedure Slider_Callback + (Item : in out FLTK.Widgets.Widget'Class) + is + Slide : My_Slider renames My_Slider (Item); + begin + Arg_Values (Slide.Index) := Slide.Get_Value; + The_Drawing.Redraw; + end Slider_Callback; + + + procedure Points_Callback + (Item : in out FLTK.Widgets.Widget'Class) + is + Toggle : Tog.Toggle_Button renames Tog.Toggle_Button (Item); + begin + Points := Toggle.Is_On; + The_Drawing.Redraw; + end Points_Callback; + + +begin + + + for Place in Sliders'Range loop + Sliders (Place).Set_Minimum (0.0); + if Place = 9 then + Sliders (Place).Set_Maximum (360.0); + else + Sliders (Place).Set_Maximum (280.0); + end if; + Sliders (Place).Set_Step_Bottom (1); + Sliders (Place).Set_Value (Arg_Values (Place)); + Sliders (Place).Set_Alignment (FLTK.Align_Left); + Sliders (Place).Set_Callback (Slider_Callback'Unrestricted_Access); + end loop; + + The_Toggle.Set_Callback (Points_Callback'Unrestricted_Access); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Curve; + + diff --git a/test/dirlist.adb b/test/dirlist.adb index 1a07515..a7c159a 100644 --- a/test/dirlist.adb +++ b/test/dirlist.adb @@ -39,7 +39,7 @@ begin end if; declare - Name : Fil.Path_String := Fil.Expand (ACom.Argument (1)); + Name : constant Fil.Path_String := Fil.Expand (ACom.Argument (1)); begin if not Fil.Is_Directory (Name) then TIO.Put_Line ("Error: " & Name & " is not a valid directory."); @@ -48,7 +48,7 @@ begin end if; declare - The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Alpha_Sort'Access); + The_List : constant Fil.File_List := Fil.Get_Listing (Name, Fil.Alpha_Sort'Access); begin TIO.Put_Line ("Alphabetical Sort:"); for Index in 1 .. The_List.Length loop @@ -58,7 +58,7 @@ begin end; declare - The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Case_Alpha_Sort'Access); + The_List : constant Fil.File_List := Fil.Get_Listing (Name, Fil.Case_Alpha_Sort'Access); begin TIO.Put_Line ("Case Insensitive Alphabetical Sort:"); for Index in 1 .. The_List.Length loop @@ -68,7 +68,7 @@ begin end; declare - The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Numeric_Sort'Access); + The_List : constant Fil.File_List := Fil.Get_Listing (Name, Fil.Numeric_Sort'Access); begin TIO.Put_Line ("Numeric Sort:"); for Index in 1 .. The_List.Length loop @@ -78,7 +78,8 @@ begin end; declare - The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Case_Numeric_Sort'Access); + The_List : constant Fil.File_List := + Fil.Get_Listing (Name, Fil.Case_Numeric_Sort'Access); begin TIO.Put_Line ("Case Insensitive Numeric Sort:"); for Index in 1 .. The_List.Length loop diff --git a/test/filename.adb b/test/filename.adb new file mode 100644 index 0000000..937fba4 --- /dev/null +++ b/test/filename.adb @@ -0,0 +1,40 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Command_Line, + Ada.Text_IO, + FLTK.Filenames; + + +procedure Filename is + + package ACom renames Ada.Command_Line; + package TIO renames Ada.Text_IO; + package Fil renames FLTK.Filenames; + +begin + + TIO.Put_Line ("Test program for FLTK filename absolute and expand functions."); + TIO.New_Line; + TIO.Put ("Input: "); + + if ACom.Argument_Count /= 1 then + TIO.Put_Line ("Error: Need exactly one filename argument."); + ACom.Set_Exit_Status (ACom.Failure); + return; + end if; + + TIO.Put_Line (ACom.Argument (1)); + TIO.New_Line; + + TIO.Put_Line ("Absolute: " & Fil.Absolute (ACom.Argument (1))); + TIO.Put_Line ("Expanded: " & Fil.Expand (ACom.Argument (1))); + +end Filename; + + diff --git a/test/hello.adb b/test/hello.adb new file mode 100644 index 0000000..1fcdf9d --- /dev/null +++ b/test/hello.adb @@ -0,0 +1,45 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Hello, World! program functionality reproduced in Ada + + +with + + FLTK.Widgets.Boxes, + FLTK.Widgets.Groups.Windows; + + +function Hello + return Integer +is + + + package Bx renames FLTK.Widgets.Boxes; + package Win renames FLTK.Widgets.Groups.Windows; + + + The_Window : Win.Window := Win.Forge.Create (340, 180); + + The_Box : Bx.Box := Bx.Forge.Create (The_Window, 20, 40, 300, 100, "Hello, World!"); + + +begin + + + The_Box.Set_Box (FLTK.Up_Box); + The_Box.Set_Label_Font (FLTK.Helvetica_Bold_Italic); + The_Box.Set_Label_Size (36); + The_Box.Set_Label_Kind (FLTK.Shadow_Label); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Hello; + + diff --git a/test/pixmap.adb b/test/pixmap.adb new file mode 100644 index 0000000..a9cf6b7 --- /dev/null +++ b/test/pixmap.adb @@ -0,0 +1,175 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Pixmap label test program functionality reproduced in Ada + + +with + + Ada.Strings.Unbounded, + FLTK.Images.Pixmaps, + FLTK.Widgets.Buttons.Toggle, + FLTK.Widgets.Groups.Windows.Double; + +use type + + FLTK.Alignment; + + +function Pixmap + return Integer +is + + + package SU renames Ada.Strings.Unbounded; + + function "+" (Str : in String) return SU.Unbounded_String renames SU.To_Unbounded_String; + + package Pix renames FLTK.Images.Pixmaps; + package Btn renames FLTK.Widgets.Buttons; + package Tog renames FLTK.Widgets.Buttons.Toggle; + package WD renames FLTK.Widgets.Groups.Windows.Double; + + + Porsche_Header : constant Pix.Header := (64, 64, 4, 1); + + Porsche_Colors : constant Pix.Color_Definition_Array := + ((Name => +" ", Kind => Pix.Colorful, Value => +"#background"), + (Name => +".", Kind => Pix.Colorful, Value => +"#000000000000"), + (Name => +"X", Kind => Pix.Colorful, Value => +"#ffd100"), + (Name => +"o", Kind => Pix.Colorful, Value => +"#FFFF00000000")); + + Porsche_Data : constant Pix.Pixmap_Data := + (" ", + " .......................... ", + " ..................................... ", + " ............XXXXXXXXXXXXXXXXXXXXXXXX............ ", + " ......XXXXXXX...XX...XXXXXXXX...XXXXXXXXXX...... ", + " ..XXXXXXXXXX..X..XX..XXXX.XXXX..XXXXXXXXXXXXXX.. ", + " ..XXXXXXXXXX..X..XX..XXX..XXXX..X...XXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XX.....XX..XX.XXXXXXXXXXX.. ", + " ..XXXXXXXXX.....XXX..XXX..XXXX..X.XXXXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XXX..XXXX....XXXXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XXX..XXXX..X..XXXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XXX..X.XX..XX..XXXXXXXXXX.. ", + " ..XXXXXXXXX....XXX....XXX..XX....XX..XXXXXXXXX.. ", + " ..XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.. ", + " ..XXXXXXXXX..........................XXXXXXXXX.. ", + " ..XXX.......XXXXXXXXXXX...................XXXX.. ", + " ......XX.XXX.XXX..XXXXX......................... ", + " ..XXXXX.XXX.XXX.XXXX.XX......................... ", + " ..XXXX.XXX.XX.......XXX......................... ", + " ..XXXX.......XXXXXX..XX..ooooooooooooooooooooo.. ", + " ..X.....XXXXXXXXXXXXXXX..ooooooooooooooooooooo.. ", + " ..X...XXXXXXXXXXXXXXXXX..ooooooooooooooooooooo.. ", + " ..X..XXXXXXX.XX.XXXXXXX..ooooooooooooooooooooo.. ", + " ..XXXXX.XXX.XX.XXXXXXXX..ooooooooooooooooooooo.. ", + " ..XXXX.XXX.XX.XX................................ ", + " ..XXXX.X.........X....X.X.X..................... ", + " ..XXXX...XXXXXXX.X..X...X.X.X.X................. ", + " ..X....XXXXXXXXXX.X...X.X.X..................... ", + " ..X...XXXXXXXXXX.XXXXXXXXXXXXXX................. ", + " ..X..XXXXXX.XX.X.XXX...XXXXXXXX................. ", + " ..XXXXX.XX.XX.XX.XX.....XXXXXXX.oooooooooooooo.. ", + " ..XXXX.XX.XX.XX..XX.X...XXXXX.X.oooooooooooooo.. ", + " ..XXXX.X.......X.XXXX...XXXX..X.oooooooooooooo.. ", + " ..X......XXXXXX..XXXX...XXXX..X.oooooooooooooo.. ", + " ..X...XXXXXXXXXX.XXX.....XXX.XX.oooooooooooooo.. ", + " ..X..XXXXXXXXXXX.X...........XX.oooooooooooooo.. ", + " .................X.X.........XX................. ", + " .................X.X.XXXX....XX.XXXXXXXXXXXXXX.. ", + " .................XXX.XXXXX.X.XX.XXX.XX.XXXXXXX.. ", + " ................XXXX.XXX..X..X.XX.XX.XXX.XXX.. ", + " ................XXXXXXXX.XX.XX.X.XX.XXX.XXXX.. ", + " .................XXXXXX.XX.XX.X..........XXX.. ", + " ..oooooooooooooo.XXXXXXXXXX....XXXXXXXX..X.. ", + " ..ooooooooooooooo.XXXXXXXX....XXXXXXXXXXXX.. ", + " ..ooooooooooooooo........XXXXXXX.XX.XXXX.. ", + " ..oooooooooooooooooo..XXXXX.XXX.XX.XX.XX.. ", + " ..ooooooooooooooooo..XXXX.XXX.XX.XX.XX.. ", + " ..ooooooooooooooooo..XXX.XX........XXX.. ", + " ....................XXX....XXXXXX..X.. ", + " ...................XX...XXXXXXXXXXX. ", + " ...................X...XXXXXXXXXXX.. ", + " ..................X..XXXX.XXXXXX.. ", + " .................XXX.XX.XX.XXX.. ", + " ................XX.XX.XX.XXX.. ", + " ..ooooooooooo..XX.......XX.. ", + " ..oooooooooo..X...XXXX.X.. ", + " ..ooooooooo..X..XXXXXX.. ", + " ...ooooooo..X..XXXX... ", + " ....ooooo..XXXXX.... ", + " ....ooo..XXX.... ", + " ....o..X.... ", + " ........ ", + " .... ", + " "); + + + The_Window : WD.Double_Window := WD.Forge.Create (400, 400, "Badgery of Pixmap Labels"); + + The_Button : Btn.Button := Btn.Forge.Create (The_Window, 140, 160, 120, 120, "Pixmap"); + + The_Pixmap : Pix.Pixmap := Pix.Forge.Create (Porsche_Header, Porsche_Colors, Porsche_Data); + De_Pixmap : Pix.Pixmap'Class := The_Pixmap.Copy; + + Left_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 25, 50, 50, 25, "left"); + Right_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 75, 50, 50, 25, "right"); + Top_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 125, 50, 50, 25, "top"); + Bottom_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 175, 50, 50, 25, "bottom"); + Inside_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 225, 50, 50, 25, "inside"); + Over_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 25, 75, 100, 25, "text over"); + Inact_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 125, 75, 100, 25, "inactive"); + + + procedure Button_Callback + (Ignore : in out FLTK.Widgets.Widget'Class) + is + New_Align : FLTK.Alignment; + begin + if Left_Btn.Is_On then New_Align := New_Align + FLTK.Align_Left; end if; + if Right_Btn.Is_On then New_Align := New_Align + FLTK.Align_Right; end if; + if Top_Btn.Is_On then New_Align := New_Align + FLTK.Align_Top; end if; + if Bottom_Btn.Is_On then New_Align := New_Align + FLTK.Align_Bottom; end if; + if Inside_Btn.Is_On then New_Align := New_Align + FLTK.Align_Inside; end if; + if Over_Btn.Is_On then New_Align := New_Align + FLTK.Align_Text_Over_Image; end if; + The_Button.Set_Alignment (New_Align); + + if Inact_Btn.Is_On then + The_Button.Deactivate; + else + The_Button.Activate; + end if; + + The_Window.Redraw; + end Button_Callback; + + +begin + + + De_Pixmap.Inactive; + + The_Button.Set_Image (The_Pixmap); + The_Button.Set_Inactive_Image (De_Pixmap); + + Left_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Right_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Top_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Bottom_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Inside_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Over_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Inact_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + + The_Window.Set_Resizable (The_Window); + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Pixmap; + + @@ -12,27 +12,50 @@ project Tests is for Languages use ("Ada"); for Source_Dirs use ("test"); - for Object_Dir use "obj"; - for Exec_Dir use "bin"; + for Object_Dir use "obj"; + for Exec_Dir use "bin"; for Main use ("adjuster.adb", "ask.adb", "bitmap.adb", + "button.adb", + "buttons.adb", "compare.adb", + "clock.adb", + "color_chooser.adb", + "cursor.adb", "dirlist.adb", - "page_formats.adb"); + "filename.adb", + "hello.adb", + "page_formats.adb", + "pixmap.adb"); package Builder is - for Executable ("adjuster.adb") use "adjuster"; - for Executable ("ask.adb") use "ask"; - for Executable ("bitmap.adb") use "bitmap"; - for Executable ("compare.adb") use "compare"; - for Executable ("dirlist.adb") use "dirlist"; - for Executable ("page_formats.adb") use "page_formats"; + for Executable ("adjuster.adb") use "adjuster"; + for Executable ("ask.adb") use "ask"; + for Executable ("bitmap.adb") use "bitmap"; + for Executable ("button.adb") use "button"; + for Executable ("buttons.adb") use "buttons"; + for Executable ("compare.adb") use "compare"; + for Executable ("clock.adb") use "clock"; + for Executable ("color_chooser.adb") use "color_chooser"; + for Executable ("cursor.adb") use "cursor"; + for Executable ("dirlist.adb") use "dirlist"; + for Executable ("filename.adb") use "filename"; + for Executable ("hello.adb") use "hello"; + for Executable ("page_formats.adb") use "page_formats"; + for Executable ("pixmap.adb") use "pixmap"; + + for Default_Switches ("Ada") use + Common.Builder'Default_Switches ("Ada"); + for Global_Compilation_Switches ("Ada") use + Common.Builder'Global_Compilation_Switches ("Ada"); end Builder; package Compiler renames Common.Compiler; + package Binder renames Common.Binder; + package Linker renames Common.Linker; end Tests; diff --git a/tests_2022.gpr b/tests_2022.gpr index 4217c08..3c3fd92 100644 --- a/tests_2022.gpr +++ b/tests_2022.gpr @@ -12,19 +12,28 @@ project Tests_2022 is for Languages use ("Ada"); for Source_Dirs use ("test"); - for Object_Dir use "obj"; - for Exec_Dir use "bin"; + for Object_Dir use "obj"; + for Exec_Dir use "bin"; for Main use ("animated.adb", - "arc.adb"); + "arc.adb", + "curve.adb"); package Builder is for Executable ("animated.adb") use "animated"; - for Executable ("arc.adb") use "arc"; + for Executable ("arc.adb") use "arc"; + for Executable ("curve.adb") use "curve"; + + for Default_Switches ("Ada") use + Common.Builder'Default_Switches ("Ada"); + for Global_Compilation_Switches ("Ada") use + Common.Builder'Global_Compilation_Switches ("Ada"); end Builder; package Compiler renames Common.Compiler; + package Binder renames Common.Binder; + package Linker renames Common.Linker; end Tests_2022; diff --git a/tool/template.adb b/tool/template.adb index a28fff8..4da7da6 100644 --- a/tool/template.adb +++ b/tool/template.adb @@ -19,7 +19,6 @@ with - Ada.Characters.Latin_1, Ada.Command_Line, Ada.Containers.Indefinite_Ordered_Maps, Ada.Direct_IO, @@ -32,7 +31,6 @@ with procedure Template is - package Latin renames Ada.Characters.Latin_1; package ACom renames Ada.Command_Line; package ADir renames Ada.Directories; package SMap renames Ada.Strings.Maps; @@ -11,16 +11,23 @@ project Tools is for Languages use ("Ada"); for Source_Dirs use ("tool"); - for Object_Dir use "obj"; - for Exec_Dir use "bin"; + for Object_Dir use "obj"; + for Exec_Dir use "bin"; for Main use ("template.adb"); package Builder is for Executable ("template.adb") use "template"; + + for Default_Switches ("Ada") use + Common.Builder'Default_Switches ("Ada"); + for Global_Compilation_Switches ("Ada") use + Common.Builder'Global_Compilation_Switches ("Ada"); end Builder; package Compiler renames Common.Compiler; + package Binder renames Common.Binder; + package Linker renames Common.Linker; end Tools; |