From 74cb50a7f7e14cec7195d30e50b76e17969c9e62 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Mon, 13 Jan 2025 12:29:26 +1300 Subject: Help_Dialog now has Show_With_Args --- src/c_fl_help_dialog.cpp | 4 ++ src/c_fl_help_dialog.h | 7 +-- src/fltk-help_dialogs.adb | 15 +++++++ src/fltk-help_dialogs.ads | 4 ++ src/fltk-show_argv.adb | 50 ++++++++++++++++++++++ src/fltk-show_argv.ads | 35 +++++++++++++++ src/fltk-widgets-groups-windows-double-overlay.adb | 3 +- src/fltk-widgets-groups-windows-double.adb | 3 +- src/fltk-widgets-groups-windows-opengl.adb | 3 +- src/fltk-widgets-groups-windows-single.adb | 3 +- src/fltk-widgets-groups-windows.adb | 41 ++---------------- src/fltk-widgets-groups-windows.ads | 13 ------ 12 files changed, 120 insertions(+), 61 deletions(-) create mode 100644 src/fltk-show_argv.adb create mode 100644 src/fltk-show_argv.ads (limited to 'src') diff --git a/src/c_fl_help_dialog.cpp b/src/c_fl_help_dialog.cpp index 9888df9..5eb719e 100644 --- a/src/c_fl_help_dialog.cpp +++ b/src/c_fl_help_dialog.cpp @@ -26,6 +26,10 @@ void fl_help_dialog_show(HELPDIALOG d) { reinterpret_cast(d)->show(); } +void fl_help_dialog_show2(HELPDIALOG d, int c, void * v) { + reinterpret_cast(d)->show(c, static_cast(v)); +} + void fl_help_dialog_hide(HELPDIALOG d) { reinterpret_cast(d)->hide(); } diff --git a/src/c_fl_help_dialog.h b/src/c_fl_help_dialog.h index 03846c2..ddabce8 100644 --- a/src/c_fl_help_dialog.h +++ b/src/c_fl_help_dialog.h @@ -8,20 +8,15 @@ #define FL_HELP_DIALOG_GUARD - - typedef void* HELPDIALOG; - - extern "C" HELPDIALOG new_fl_help_dialog(); extern "C" void free_fl_help_dialog(HELPDIALOG d); - - extern "C" void fl_help_dialog_show(HELPDIALOG d); +extern "C" void fl_help_dialog_show2(HELPDIALOG d, int c, void * v); extern "C" void fl_help_dialog_hide(HELPDIALOG d); extern "C" int fl_help_dialog_visible(HELPDIALOG d); diff --git a/src/fltk-help_dialogs.adb b/src/fltk-help_dialogs.adb index c7cf870..fc5ab07 100644 --- a/src/fltk-help_dialogs.adb +++ b/src/fltk-help_dialogs.adb @@ -6,6 +6,7 @@ with + FLTK.Show_Argv, Interfaces.C.Strings; use type @@ -38,6 +39,13 @@ package body FLTK.Help_Dialogs is pragma Import (C, fl_help_dialog_show, "fl_help_dialog_show"); pragma Inline (fl_help_dialog_show); + procedure fl_help_dialog_show2 + (D : in Storage.Integer_Address; + C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_help_dialog_show2, "fl_help_dialog_show2"); + pragma Inline (fl_help_dialog_show2); + procedure fl_help_dialog_hide (D : in Storage.Integer_Address); pragma Import (C, fl_help_dialog_hide, "fl_help_dialog_hide"); @@ -199,6 +207,13 @@ package body FLTK.Help_Dialogs is end Show; + procedure Show_With_Args + (This : in out Help_Dialog) is + begin + FLTK.Show_Argv.Dispatch (fl_help_dialog_show2'Access, This.Void_Ptr); + end Show_With_Args; + + procedure Hide (This : in out Help_Dialog) is begin diff --git a/src/fltk-help_dialogs.ads b/src/fltk-help_dialogs.ads index ebe59df..655e357 100644 --- a/src/fltk-help_dialogs.ads +++ b/src/fltk-help_dialogs.ads @@ -36,6 +36,9 @@ package FLTK.Help_Dialogs is procedure Show (This : in out Help_Dialog); + procedure Show_With_Args + (This : in out Help_Dialog); + procedure Hide (This : in out Help_Dialog); @@ -120,6 +123,7 @@ private pragma Inline (Show); + pragma Inline (Show_With_Args); pragma Inline (Hide); pragma Inline (Is_Visible); diff --git a/src/fltk-show_argv.adb b/src/fltk-show_argv.adb new file mode 100644 index 0000000..52e22e2 --- /dev/null +++ b/src/fltk-show_argv.adb @@ -0,0 +1,50 @@ + + +-- 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/src/fltk-show_argv.ads b/src/fltk-show_argv.ads new file mode 100644 index 0000000..231b875 --- /dev/null +++ b/src/fltk-show_argv.ads @@ -0,0 +1,35 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +private package FLTK.Show_Argv is + + + -- Used for implementing show(argc,argv) + + 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/src/fltk-widgets-groups-windows-double-overlay.adb b/src/fltk-widgets-groups-windows-double-overlay.adb index 3b16b62..53ba257 100644 --- a/src/fltk-widgets-groups-windows-double-overlay.adb +++ b/src/fltk-widgets-groups-windows-double-overlay.adb @@ -6,6 +6,7 @@ with + FLTK.Show_Argv, Interfaces.C, System.Address_To_Access_Conversions; @@ -222,7 +223,7 @@ package body FLTK.Widgets.Groups.Windows.Double.Overlay is procedure Show_With_Args (This : in out Overlay_Window) is begin - Dispatch_Show_With_Args (fl_overlay_window_show2'Access, This.Void_Ptr); + FLTK.Show_Argv.Dispatch (fl_overlay_window_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/src/fltk-widgets-groups-windows-double.adb b/src/fltk-widgets-groups-windows-double.adb index 044bf38..bb7e3da 100644 --- a/src/fltk-widgets-groups-windows-double.adb +++ b/src/fltk-widgets-groups-windows-double.adb @@ -6,6 +6,7 @@ with + FLTK.Show_Argv, Interfaces.C; @@ -190,7 +191,7 @@ package body FLTK.Widgets.Groups.Windows.Double is procedure Show_With_Args (This : in out Double_Window) is begin - Dispatch_Show_With_Args (fl_double_window_show2'Access, This.Void_Ptr); + FLTK.Show_Argv.Dispatch (fl_double_window_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/src/fltk-widgets-groups-windows-opengl.adb b/src/fltk-widgets-groups-windows-opengl.adb index 1b8bea7..e949f2d 100644 --- a/src/fltk-widgets-groups-windows-opengl.adb +++ b/src/fltk-widgets-groups-windows-opengl.adb @@ -6,6 +6,7 @@ with + FLTK.Show_Argv, Interfaces.C, System; @@ -316,7 +317,7 @@ package body FLTK.Widgets.Groups.Windows.OpenGL is procedure Show_With_Args (This : in out GL_Window) is begin - Dispatch_Show_With_Args (fl_gl_window_show2'Access, This.Void_Ptr); + FLTK.Show_Argv.Dispatch (fl_gl_window_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/src/fltk-widgets-groups-windows-single.adb b/src/fltk-widgets-groups-windows-single.adb index 6e7c7c1..a74b122 100644 --- a/src/fltk-widgets-groups-windows-single.adb +++ b/src/fltk-widgets-groups-windows-single.adb @@ -6,6 +6,7 @@ with + FLTK.Show_Argv, Interfaces.C; @@ -178,7 +179,7 @@ package body FLTK.Widgets.Groups.Windows.Single is procedure Show_With_Args (This : in out Single_Window) is begin - Dispatch_Show_With_Args (fl_single_window_show2'Access, This.Void_Ptr); + FLTK.Show_Argv.Dispatch (fl_single_window_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/src/fltk-widgets-groups-windows.adb b/src/fltk-widgets-groups-windows.adb index afd17ae..b79f937 100644 --- a/src/fltk-widgets-groups-windows.adb +++ b/src/fltk-widgets-groups-windows.adb @@ -8,7 +8,8 @@ with Ada.Command_Line, Interfaces.C.Strings, - FLTK.Images.RGB; + FLTK.Images.RGB, + FLTK.Show_Argv; use type @@ -299,42 +300,6 @@ package body FLTK.Widgets.Groups.Windows is - ------------------------ - -- Internal Utility -- - ------------------------ - - function Create_Argv - return Interfaces.C.Strings.chars_ptr_array - is - package ICS renames Interfaces.C.Strings; - package ACom renames Ada.Command_Line; - - Result : ICS.chars_ptr_array (0 .. Interfaces.C.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 (Interfaces.C.size_t (Index)) := ICS.New_String (ACom.Argument (Index)); - end loop; - return Result; - end Create_Argv; - - - procedure Dispatch_Show_With_Args - (Func : in Show_With_Args_Func; - CObj : in Storage.Integer_Address) - is - Argv : Interfaces.C.Strings.chars_ptr_array := Create_Argv; - begin - Func (CObj, Interfaces.C.int (Ada.Command_Line.Argument_Count + 1), - Storage.To_Integer (Argv (Argv'First)'Address)); - for Ptr of Argv loop - Interfaces.C.Strings.Free (Ptr); - end loop; - end Dispatch_Show_With_Args; - - - - ------------------- -- Destructors -- ------------------- @@ -432,7 +397,7 @@ package body FLTK.Widgets.Groups.Windows is procedure Show_With_Args (This : in out Window) is begin - Dispatch_Show_With_Args (fl_window_show2'Access, This.Void_Ptr); + FLTK.Show_Argv.Dispatch (fl_window_show2'Access, This.Void_Ptr); end Show_With_Args; diff --git a/src/fltk-widgets-groups-windows.ads b/src/fltk-widgets-groups-windows.ads index 97d79d9..d00d3d7 100644 --- a/src/fltk-widgets-groups-windows.ads +++ b/src/fltk-widgets-groups-windows.ads @@ -235,19 +235,6 @@ private with Inline; - -- Used for implementing show(argc,argv) - type Show_With_Args_Func is access procedure - (CObj : in Storage.Integer_Address; - Argc : in Interfaces.C.int; - Argv : in Storage.Integer_Address); - - pragma Convention (C, Show_With_Args_Func); - - procedure Dispatch_Show_With_Args - (Func : in Show_With_Args_Func; - CObj : in Storage.Integer_Address); - - pragma Inline (Show); pragma Inline (Show_With_Args); pragma Inline (Hide); -- cgit