diff options
| -rw-r--r-- | fltk-widgets-menus.adb | 13 | ||||
| -rw-r--r-- | fltk-widgets-menus.ads | 2 | ||||
| -rw-r--r-- | fltk-widgets.adb | 10 | ||||
| -rw-r--r-- | fltk-widgets.ads | 17 |
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 |