summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--c_fl_widget.cpp7
-rw-r--r--c_fl_widget.h3
-rw-r--r--fltk-widgets.adb33
-rw-r--r--fltk-widgets.ads16
4 files changed, 58 insertions, 1 deletions
diff --git a/c_fl_widget.cpp b/c_fl_widget.cpp
index a503dc1..f700c54 100644
--- a/c_fl_widget.cpp
+++ b/c_fl_widget.cpp
@@ -72,3 +72,10 @@ void * fl_widget_get_parent(WIDGET w) {
return reinterpret_cast<Fl_Widget*>(w)->parent();
}
+
+
+
+void fl_widget_set_callback(WIDGET w, void * cb) {
+ reinterpret_cast<Fl_Widget*>(w)->callback(reinterpret_cast<Fl_Callback_p>(cb));
+}
+
diff --git a/c_fl_widget.h b/c_fl_widget.h
index 8f99d26..3b2561e 100644
--- a/c_fl_widget.h
+++ b/c_fl_widget.h
@@ -24,5 +24,8 @@ extern "C" void fl_widget_set_label_type(WIDGET w, int l);
extern "C" void * fl_widget_get_parent(WIDGET w);
+extern "C" void fl_widget_set_callback(WIDGET w, void * cb);
+
+
#endif
diff --git a/fltk-widgets.adb b/fltk-widgets.adb
index 0f67ddb..3e27cb7 100644
--- a/fltk-widgets.adb
+++ b/fltk-widgets.adb
@@ -71,6 +71,10 @@ package body FLTK.Widgets is
return System.Address;
pragma Import (C, fl_widget_get_parent, "fl_widget_get_parent");
+ procedure fl_widget_set_callback
+ (W, C : in System.Address);
+ pragma Import (C, fl_widget_set_callback, "fl_widget_set_callback");
+
@@ -190,5 +194,34 @@ package body FLTK.Widgets is
end Set_Label_Type;
+
+
+ -- this is the part called by FLTK callbacks
+ -- note that the user data portion is a reference back to the Ada binding
+ procedure Callback_Hook (W, U : in System.Address);
+ pragma Convention (C, Callback_Hook);
+
+ procedure Callback_Hook
+ (W, U : in System.Address) is
+
+ Ada_Widget : access Widget'Class :=
+ Widget_Convert.To_Pointer (U);
+
+ begin
+ Ada_Widget.Callback.Call (Ada_Widget.all);
+ end Callback_Hook;
+
+
+
+
+ procedure Set_Callback
+ (This : in out Widget;
+ Func : not null access Widget_Callback'Class) is
+ begin
+ This.Callback := Func;
+ fl_widget_set_callback (This.Void_Ptr, Callback_Hook'Address);
+ end Set_Callback;
+
+
end FLTK.Widgets;
diff --git a/fltk-widgets.ads b/fltk-widgets.ads
index 3f02302..1c21ca4 100644
--- a/fltk-widgets.ads
+++ b/fltk-widgets.ads
@@ -14,6 +14,12 @@ package FLTK.Widgets is
with Implicit_Dereference => Data;
+ type Widget_Callback is interface;
+ procedure Call
+ (This : in Widget_Callback;
+ Item : in out Widget'Class) is abstract;
+
+
-- would like to move this definition to FLTK.Widgets.Groups somehow
type Group_Cursor (Data : access FLTK.Widgets.Groups.Group'Class) is limited null record
with Implicit_Dereference => Data;
@@ -85,10 +91,18 @@ package FLTK.Widgets is
Label : in Label_Kind);
+ procedure Set_Callback
+ (This : in out Widget;
+ Func : not null access Widget_Callback'Class);
+
+
private
- type Widget is abstract new Wrapper with null record;
+ type Widget is abstract new Wrapper with
+ record
+ Callback : access Widget_Callback'Class;
+ end record;
package Widget_Convert is new System.Address_To_Access_Conversions (Widget'Class);