4 files changed, 248 insertions, 0 deletions
diff --git a/src/c_fl_error.cpp b/src/c_fl_error.cpp
new file mode 100644
index 0000000..17c45a0
--- /dev/null
+++ b/src/c_fl_error.cpp
@@ -0,0 +1,87 @@
+
+
+//  Programmed by Jedidiah Barber
+//  Released into the public domain
+
+
+#include <FL/Fl.H>
+#include <stdarg.h>
+#include "c_fl_error.h"
+
+
+
+
+//  Exports from Ada
+
+extern "C" void error_warning_hook(const char * m);
+extern "C" void error_error_hook(const char * m);
+extern "C" void error_fatal_hook(const char * m);
+
+
+//  This is the size used internally in FLTK anyway
+const int bsize = 1024;
+
+
+//  Some prep needed to convert vargs to a single char*
+
+void warning_hook_prep(const char * m, ...) {
+    va_list args;
+    char buf[bsize];
+    va_start(args, m);
+    vsnprintf(buf, bsize, m, args);
+    va_end(args);
+    error_warning_hook(buf);
+}
+
+void error_hook_prep(const char * m, ...) {
+    va_list args;
+    char buf[bsize];
+    va_start(args, m);
+    vsnprintf(buf, bsize, m, args);
+    va_end(args);
+    error_error_hook(buf);
+}
+
+void fatal_hook_prep(const char * m, ...) {
+    va_list args;
+    char buf[bsize];
+    va_start(args, m);
+    vsnprintf(buf, bsize, m, args);
+    va_end(args);
+    error_fatal_hook(buf);
+}
+
+
+
+
+//  Original function pointers
+
+void (*original_warning)(const char *, ...) = Fl::warning;
+void (*original_error)(const char *, ...) = Fl::error;
+void (*original_fatal)(const char *, ...) = Fl::fatal;
+
+
+void fl_error_default_warning(const char * m) {
+    (*original_warning)(m);
+}
+
+void fl_error_default_error(const char * m) {
+    (*original_error)(m);
+}
+
+void fl_error_default_fatal(const char * m) {
+    (*original_fatal)(m);
+}
+
+
+
+
+//  Tying it all together
+
+void fl_error_set_hooks() {
+    Fl::warning = &warning_hook_prep;
+    Fl::error = &error_hook_prep;
+    Fl::fatal = &fatal_hook_prep;
+}
+
+
diff --git a/src/c_fl_error.h b/src/c_fl_error.h
new file mode 100644
index 0000000..263a42b
--- /dev/null
+++ b/src/c_fl_error.h
@@ -0,0 +1,21 @@
+
+
+//  Programmed by Jedidiah Barber
+//  Released into the public domain
+
+
+#ifndef FL_ERROR_GUARD
+#define FL_ERROR_GUARD
+
+
+extern "C" void fl_error_default_warning(const char * m);
+extern "C" void fl_error_default_error(const char * m);
+extern "C" void fl_error_default_fatal(const char * m);
+
+
+extern "C" void fl_error_set_hooks();
+
+
+#endif
+
+
diff --git a/src/fltk-errors.adb b/src/fltk-errors.adb
new file mode 100644
index 0000000..ef31002
--- /dev/null
+++ b/src/fltk-errors.adb
@@ -0,0 +1,101 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+with
+
+    Interfaces.C.Strings;
+
+
+package body FLTK.Errors is
+
+
+    procedure fl_error_default_warning
+           (M : in Interfaces.C.char_array);
+    pragma Import (C, fl_error_default_warning, "fl_error_default_warning");
+    pragma Inline (fl_error_default_warning);
+
+    procedure fl_error_default_error
+           (M : in Interfaces.C.char_array);
+    pragma Import (C, fl_error_default_error, "fl_error_default_error");
+    pragma Inline (fl_error_default_error);
+
+    procedure fl_error_default_fatal
+           (M : in Interfaces.C.char_array);
+    pragma Import (C, fl_error_default_fatal, "fl_error_default_fatal");
+    pragma Inline (fl_error_default_fatal);
+
+    procedure fl_error_set_hooks;
+    pragma Import (C, fl_error_set_hooks, "fl_error_set_hooks");
+    pragma Inline (fl_error_set_hooks);
+
+
+
+
+    procedure Warning_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr);
+    pragma Export (C, Warning_Hook, "error_warning_hook");
+
+    procedure Warning_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr) is
+    begin
+        Current_Warning (Interfaces.C.Strings.Value (C_Mess));
+    end Warning_Hook;
+
+
+    procedure Error_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr);
+    pragma Export (C, Error_Hook, "error_error_hook");
+
+    procedure Error_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr) is
+    begin
+        Current_Error (Interfaces.C.Strings.Value (C_Mess));
+    end Error_Hook;
+
+
+    procedure Fatal_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr);
+    pragma Export (C, Fatal_Hook, "error_fatal_hook");
+
+    procedure Fatal_Hook
+           (C_Mess : in Interfaces.C.Strings.chars_ptr) is
+    begin
+        Current_Fatal (Interfaces.C.Strings.Value (C_Mess));
+    end Fatal_Hook;
+
+
+
+
+    procedure Default_Warning
+           (Message : in String) is
+    begin
+        fl_error_default_warning (Interfaces.C.To_C (Message));
+    end Default_Warning;
+
+
+    procedure Default_Error
+           (Message : in String) is
+    begin
+        fl_error_default_error (Interfaces.C.To_C (Message));
+    end Default_Error;
+
+
+    procedure Default_Fatal
+           (Message : in String) is
+    begin
+        fl_error_default_fatal (Interfaces.C.To_C (Message));
+    end Default_Fatal;
+
+
+begin
+
+
+    fl_error_set_hooks;
+
+
+end FLTK.Errors;
+
+
diff --git a/src/fltk-errors.ads b/src/fltk-errors.ads
new file mode 100644
index 0000000..6cdea54
--- /dev/null
+++ b/src/fltk-errors.ads
@@ -0,0 +1,39 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+package FLTK.Errors is
+
+
+    type Error_Function is not null access procedure
+           (Message : in String);
+
+
+    procedure Default_Warning
+           (Message : in String);
+
+    procedure Default_Error
+           (Message : in String);
+
+    procedure Default_Fatal
+           (Message : in String);
+
+
+    Current_Warning : Error_Function := Default_Warning'Access;
+    Current_Error   : Error_Function := Default_Error'Access;
+    Current_Fatal   : Error_Function := Default_Fatal'Access;
+
+
+private
+
+
+    pragma Inline (Default_Warning);
+    pragma Inline (Default_Error);
+    pragma Inline (Default_Fatal);
+
+
+end FLTK.Errors;
+
+