summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--fltk-widgets-menus.adb13
-rw-r--r--fltk-widgets-menus.ads2
-rw-r--r--fltk-widgets.adb10
-rw-r--r--fltk-widgets.ads17
4 files changed, 22 insertions, 20 deletions
diff --git a/fltk-widgets-menus.adb b/fltk-widgets-menus.adb
index 7669820..0f50fc8 100644
--- a/fltk-widgets-menus.adb
+++ b/fltk-widgets-menus.adb
@@ -98,16 +98,13 @@ package body FLTK.Widgets.Menus is
pragma Convention (C, Item_Hook);
procedure Item_Hook
- (M, U : in System.Address) is
-
+ (M, U : in System.Address)
+ is
Ada_Widget : access Widget'Class :=
Widget_Convert.To_Pointer (fl_widget_get_user_data (M));
-
- Action : access Widget_Callback'Class :=
- Callback_Convert.To_Pointer (U);
-
+ Action : Widget_Callback := Callback_Convert.To_Pointer (U);
begin
- Action.Call (Ada_Widget.all);
+ Action.all (Ada_Widget.all);
end Item_Hook;
@@ -116,7 +113,7 @@ package body FLTK.Widgets.Menus is
procedure Add
(This : in out Menu;
Text : in String;
- Action : access Widget_Callback'Class := null;
+ Action : in Widget_Callback := null;
Shortcut : in Shortcut_Key := No_Key;
Flags : in Menu_Flag := Flag_Normal)
is
diff --git a/fltk-widgets-menus.ads b/fltk-widgets-menus.ads
index acb59bd..27b9d4a 100644
--- a/fltk-widgets-menus.ads
+++ b/fltk-widgets-menus.ads
@@ -57,7 +57,7 @@ package FLTK.Widgets.Menus is
procedure Add
(This : in out Menu;
Text : in String;
- Action : access Widget_Callback'Class := null;
+ Action : in Widget_Callback := null;
Shortcut : in Shortcut_Key := No_Key;
Flags : in Menu_Flag := Flag_Normal);
diff --git a/fltk-widgets.adb b/fltk-widgets.adb
index 256b8e6..9ec2350 100644
--- a/fltk-widgets.adb
+++ b/fltk-widgets.adb
@@ -242,7 +242,7 @@ package body FLTK.Widgets is
Ada_Widget : access Widget'Class :=
Widget_Convert.To_Pointer (U);
begin
- Ada_Widget.Callback.Call (Ada_Widget.all);
+ Ada_Widget.Callback.all (Ada_Widget.all);
end Callback_Hook;
@@ -250,10 +250,12 @@ package body FLTK.Widgets is
procedure Set_Callback
(This : in out Widget;
- Func : not null access Widget_Callback'Class) is
+ Func : in Widget_Callback) is
begin
- This.Callback := Func;
- fl_widget_set_callback (This.Void_Ptr, Callback_Hook'Address);
+ if Func /= null then
+ This.Callback := Func;
+ fl_widget_set_callback (This.Void_Ptr, Callback_Hook'Address);
+ end if;
end Set_Callback;
diff --git a/fltk-widgets.ads b/fltk-widgets.ads
index 7af5e2b..d1c4b89 100644
--- a/fltk-widgets.ads
+++ b/fltk-widgets.ads
@@ -5,6 +5,7 @@ with FLTK.Images;
limited with FLTK.Widgets.Groups;
private with System;
private with System.Address_To_Access_Conversions;
+private with Ada.Unchecked_Conversion;
package FLTK.Widgets is
@@ -13,10 +14,8 @@ package FLTK.Widgets is
type Widget is abstract new Wrapper with private;
- type Widget_Callback is interface;
- procedure Call
- (This : in Widget_Callback;
- Item : in out Widget'Class) is abstract;
+ type Widget_Callback is access procedure
+ (Item : in out Widget'Class);
type Font_Size is new Natural;
@@ -87,7 +86,7 @@ package FLTK.Widgets is
procedure Set_Callback
(This : in out Widget;
- Func : not null access Widget_Callback'Class);
+ Func : in Widget_Callback);
function Get_X
@@ -135,13 +134,17 @@ private
type Widget is abstract new Wrapper with
record
- Callback : access Widget_Callback'Class;
+ Callback : Widget_Callback;
Current_Image : access FLTK.Images.Image'Class;
end record;
package Widget_Convert is new System.Address_To_Access_Conversions (Widget'Class);
- package Callback_Convert is new System.Address_To_Access_Conversions (Widget_Callback'Class);
+ -- package Callback_Convert is new System.Address_To_Access_Conversions (Widget_Callback);
+ package Callback_Convert is
+ function To_Pointer is new Ada.Unchecked_Conversion (System.Address, Widget_Callback);
+ function To_Address is new Ada.Unchecked_Conversion (Widget_Callback, System.Address);
+ end Callback_Convert;
function fl_widget_get_user_data