diff options
| -rw-r--r-- | doc/fl.html | 88 | ||||
| -rw-r--r-- | doc/fl_ask.html | 21 | ||||
| -rw-r--r-- | doc/index.html | 1 | ||||
| -rw-r--r-- | src/c_fl_error.cpp | 87 | ||||
| -rw-r--r-- | src/c_fl_error.h | 21 | ||||
| -rw-r--r-- | src/fltk-errors.adb | 101 | ||||
| -rw-r--r-- | src/fltk-errors.ads | 39 |
7 files changed, 337 insertions, 21 deletions
diff --git a/doc/fl.html b/doc/fl.html index 3547287..09b1a3b 100644 --- a/doc/fl.html +++ b/doc/fl.html @@ -26,6 +26,11 @@ <tr> <td> </td> + <td>FLTK.Errors</td> + </tr> + + <tr> + <td> </td> <td>FLTK.Event</td> </tr> @@ -226,6 +231,89 @@ <td>Mouse_Cursor</td> </tr> + <tr> + <td> </td> + <td>Error_Function</td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Attributes</th></tr> + + <tr> +<td><pre> +static void (*atclose)(Fl_Window *, void *); +</pre></td> +<td>Deprecated, set the callback for the Window instead</td> + </tr> + + <tr> +<td><pre> +static char const * const clipboard_image = "image"; +</pre></td> +<td> </td> + </tr> + + <tr> +<td><pre> +static char const * const clipboard_plain_text = "text/plain"; +</pre></td> +<td> </td> + </tr> + + <tr> +<td><pre> +static void (*error)(const char *, ...) = ::error; +</pre></td> +<td><pre> +procedure Default_Error + (Message : in String); + +Current_Error : Error_Function := Default_Error'Access; +</pre>(In FLTK.Errors)</td> + </tr> + + <tr> +<td><pre> +static void (*fatal)(const char *, ...) = ::fatal; +</pre></td> +<td><pre> +procedure Default_Fatal + (Message : in String); + +Current_Fatal : Error_Function := Default_Fatal'Access; +</pre>(In FLTK.Errors)</td> + </tr> + + <tr> +<td><pre> +static const char * const help = helpmsg + 13; +</pre></td> +<td> </td> + </tr> + + <tr> +<td><pre> +static void (*idle)(); +</pre></td> +<td>Should not be used directly</td> + </tr> + + <tr> +<td><pre> +static void (*warning)(const char *, ...) = ::warning; +</pre></td> +<td><pre> +procedure Default_Warning + (Message : in String); + +Current_Warning : Error_Function := Default_Warning'Access; +</pre>(In FLTK.Errors)</td> + </tr> + </table> diff --git a/doc/fl_ask.html b/doc/fl_ask.html index 078c7c8..857f5f5 100644 --- a/doc/fl_ask.html +++ b/doc/fl_ask.html @@ -75,20 +75,6 @@ <tr> <td><pre> -static void (*Fl::error)(const char *, ...) = ::error; -</pre></td> -<td>See FLTK.Errors</td> - </tr> - - <tr> -<td><pre> -static void (*Fl::fatal)(const char *, ...) = ::fatal; -</pre></td> -<td>See FLTK.Errors</td> - </tr> - - <tr> -<td><pre> const char * fl_cancel = "Cancel"; </pre></td> <td><pre> @@ -152,13 +138,6 @@ procedure Set_Yes_String </pre></td> </tr> - <tr> -<td><pre> -static void (*Fl::warning)(const char *, ...) = ::warning; -</pre></td> -<td>See FLTK.Errors</td> - </tr> - </table> diff --git a/doc/index.html b/doc/index.html index 071dc7c..8a6d4d8 100644 --- a/doc/index.html +++ b/doc/index.html @@ -145,6 +145,7 @@ <li><a href="fl_printer.html">FLTK.Devices.Surfaces.Paged.Printers</a></li> <li><a href="fl_draw.html">FLTK.Draw</a></li> <li><a href="fl_preferences.html">FLTK.Environment</a></li> + <li><a href="fl.html">FLTK.Errors</a></li> <li><a href="fl.html">FLTK.Event</a></li> <li><a href="fl_help_dialog.html">FLTK.Help_Dialogs</a></li> <li><a href="fl_image.html">FLTK.Images</a></li> 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; + + |