diff options
| -rw-r--r-- | c_fl_widget.cpp | 7 | ||||
| -rw-r--r-- | c_fl_widget.h | 3 | ||||
| -rw-r--r-- | fltk-widgets.adb | 33 | ||||
| -rw-r--r-- | fltk-widgets.ads | 16 |
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); |