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