diff options
| -rw-r--r-- | src/fltk-event.adb | 70 | ||||
| -rw-r--r-- | src/fltk-file_choosers.adb | 16 | ||||
| -rw-r--r-- | src/fltk-static.adb | 62 | ||||
| -rw-r--r-- | src/fltk-tooltips.adb | 17 | ||||
| -rw-r--r-- | src/fltk-widgets-groups-help_views.adb | 8 | ||||
| -rw-r--r-- | src/fltk-widgets-groups-tabbed.adb | 44 | ||||
| -rw-r--r-- | src/fltk-widgets-groups-text_displays-text_editors.adb | 6 | ||||
| -rw-r--r-- | src/fltk-widgets-groups-windows-double-cairo.adb | 9 | ||||
| -rw-r--r-- | src/fltk-widgets-groups-wizards.adb | 19 | ||||
| -rw-r--r-- | src/fltk-widgets-menus.adb | 18 |
10 files changed, 217 insertions, 52 deletions
diff --git a/src/fltk-event.adb b/src/fltk-event.adb index 6578830..c4933b4 100644 --- a/src/fltk-event.adb +++ b/src/fltk-event.adb @@ -6,6 +6,7 @@ with + Ada.Assertions, Interfaces.C.Strings; use type @@ -17,6 +18,15 @@ use type package body FLTK.Event is + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + procedure fl_event_add_handler (F : in Storage.Integer_Address); pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); @@ -342,10 +352,19 @@ package body FLTK.Event is function Get_Grab - return access FLTK.Widgets.Groups.Windows.Window'Class is + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Grab_Ptr : Storage.Integer_Address := fl_event_get_grab; + Actual_Grab : access FLTK.Widgets.Groups.Windows.Window'Class; begin - return Window_Convert.To_Pointer - (Storage.To_Address (fl_widget_get_user_data (fl_event_get_grab))); + if Grab_Ptr /= Null_Pointer then + Grab_Ptr := fl_widget_get_user_data (Grab_Ptr); + pragma Assert (Grab_Ptr /= Null_Pointer); + Actual_Grab := Window_Convert.To_Pointer (Storage.To_Address (Grab_Ptr)); + end if; + return Actual_Grab; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Grab; @@ -363,10 +382,19 @@ package body FLTK.Event is function Get_Pushed - return access FLTK.Widgets.Widget'Class is + return access FLTK.Widgets.Widget'Class + is + Pushed_Ptr : Storage.Integer_Address := fl_event_get_pushed; + Actual_Pushed : access FLTK.Widgets.Widget'Class; begin - return Widget_Convert.To_Pointer - (Storage.To_Address (fl_widget_get_user_data (fl_event_get_pushed))); + if Pushed_Ptr /= Null_Pointer then + Pushed_Ptr := fl_widget_get_user_data (Pushed_Ptr); + pragma Assert (Pushed_Ptr /= Null_Pointer); + Actual_Pushed := Widget_Convert.To_Pointer (Storage.To_Address (Pushed_Ptr)); + end if; + return Actual_Pushed; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Pushed; @@ -378,10 +406,19 @@ package body FLTK.Event is function Get_Below_Mouse - return access FLTK.Widgets.Widget'Class is + return access FLTK.Widgets.Widget'Class + is + Below_Ptr : Storage.Integer_Address := fl_event_get_belowmouse; + Actual_Below : access FLTK.Widgets.Widget'Class; begin - return Widget_Convert.To_Pointer - (Storage.To_Address (fl_widget_get_user_data (fl_event_get_belowmouse))); + if Below_Ptr /= Null_Pointer then + Below_Ptr := fl_widget_get_user_data (Below_Ptr); + pragma Assert (Below_Ptr /= Null_Pointer); + Actual_Below := Widget_Convert.To_Pointer (Storage.To_Address (Below_Ptr)); + end if; + return Actual_Below; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Below_Mouse; @@ -393,10 +430,19 @@ package body FLTK.Event is function Get_Focus - return access FLTK.Widgets.Widget'Class is + return access FLTK.Widgets.Widget'Class + is + Focus_Ptr : Storage.Integer_Address := fl_event_get_focus; + Actual_Focus : access FLTK.Widgets.Widget'Class; begin - return Widget_Convert.To_Pointer - (Storage.To_Address (fl_widget_get_user_data (fl_event_get_focus))); + if Focus_Ptr /= Null_Pointer then + Focus_Ptr := fl_widget_get_user_data (Focus_Ptr); + pragma Assert (Focus_Ptr /= Null_Pointer); + Actual_Focus := Widget_Convert.To_Pointer (Storage.To_Address (Focus_Ptr)); + end if; + return Actual_Focus; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Focus; diff --git a/src/fltk-file_choosers.adb b/src/fltk-file_choosers.adb index d413f15..3eee496 100644 --- a/src/fltk-file_choosers.adb +++ b/src/fltk-file_choosers.adb @@ -31,6 +31,12 @@ package body FLTK.File_Choosers is -- Functions From C -- ------------------------ + function fl_widget_get_user_data + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); + pragma Inline (fl_widget_get_user_data); + procedure fl_widget_set_user_data (W, D : in Storage.Integer_Address); pragma Import (C, fl_widget_set_user_data, "fl_widget_set_user_data"); @@ -952,8 +958,16 @@ package body FLTK.File_Choosers is is C_Addr : Storage.Integer_Address := fl_file_chooser_add_extra (This.Void_Ptr, Wrapper (Item).Void_Ptr); + Ada_Obj : access Widgets.Widget'Class; begin - return Widget_Convert.To_Pointer (Storage.To_Address (C_Addr)); + if C_Addr /= Null_Pointer then + C_Addr := fl_widget_get_user_data (C_Addr); + pragma Assert (C_Addr /= Null_Pointer); + Ada_Obj := Widget_Convert.To_Pointer (Storage.To_Address (C_Addr)); + end if; + return Ada_Obj; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Eject_Extra; diff --git a/src/fltk-static.adb b/src/fltk-static.adb index 016301b..56b30c0 100644 --- a/src/fltk-static.adb +++ b/src/fltk-static.adb @@ -6,6 +6,7 @@ with + Ada.Assertions, Ada.Containers.Vectors, Interfaces.C.Strings, System.Address_To_Access_Conversions, @@ -20,6 +21,7 @@ use type package body FLTK.Static is + package Chk renames Ada.Assertions; package Conv renames FLTK.Static_Callback_Conversions; @@ -901,10 +903,19 @@ package body FLTK.Static is function Get_First_Window - return access FLTK.Widgets.Groups.Windows.Window'Class is + return access FLTK.Widgets.Groups.Windows.Window'Class + is + First_Ptr : Storage.Integer_Address := fl_static_get_first_window; + Actual_First : access FLTK.Widgets.Groups.Windows.Window'Class; begin - return Window_Convert.To_Pointer - (Storage.To_Address (fl_widget_get_user_data (fl_static_get_first_window))); + if First_Ptr /= Null_Pointer then + First_Ptr := fl_widget_get_user_data (First_Ptr); + pragma Assert (First_Ptr /= Null_Pointer); + Actual_First := Window_Convert.To_Pointer (Storage.To_Address (First_Ptr)); + end if; + return Actual_First; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_First_Window; @@ -917,28 +928,55 @@ package body FLTK.Static is function Get_Next_Window (From : in FLTK.Widgets.Groups.Windows.Window'Class) - return access FLTK.Widgets.Groups.Windows.Window'Class is + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Next_Ptr : Storage.Integer_Address := fl_static_next_window (Wrapper (From).Void_Ptr); + Actual_Next : access FLTK.Widgets.Groups.Windows.Window'Class; begin - return Window_Convert.To_Pointer (Storage.To_Address - (fl_widget_get_user_data (fl_static_next_window (Wrapper (From).Void_Ptr)))); + if Next_Ptr /= Null_Pointer then + Next_Ptr := fl_widget_get_user_data (Next_Ptr); + pragma Assert (Next_Ptr /= Null_Pointer); + Actual_Next := Window_Convert.To_Pointer (Storage.To_Address (Next_Ptr)); + end if; + return Actual_Next; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Next_Window; function Get_Top_Modal - return access FLTK.Widgets.Groups.Windows.Window'Class is + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Modal_Ptr : Storage.Integer_Address := fl_static_modal; + Actual_Modal : access FLTK.Widgets.Groups.Windows.Window'Class; begin - return Window_Convert.To_Pointer - (Storage.To_Address (fl_widget_get_user_data (fl_static_modal))); + if Modal_Ptr /= Null_Pointer then + Modal_Ptr := fl_widget_get_user_data (Modal_Ptr); + pragma Assert (Modal_Ptr /= Null_Pointer); + Actual_Modal := Window_Convert.To_Pointer (Storage.To_Address (Modal_Ptr)); + end if; + return Actual_Modal; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Top_Modal; function Read_Queue - return access FLTK.Widgets.Widget'Class is + return access FLTK.Widgets.Widget'Class + is + Queue_Ptr : Storage.Integer_Address := fl_static_readqueue; + Actual_Queue : access FLTK.Widgets.Widget'Class; begin - return Widget_Convert.To_Pointer - (Storage.To_Address (fl_widget_get_user_data (fl_static_readqueue))); + if Queue_Ptr /= Null_Pointer then + Queue_Ptr := fl_widget_get_user_data (Queue_Ptr); + pragma Assert (Queue_Ptr /= Null_Pointer); + Actual_Queue := Widget_Convert.To_Pointer (Storage.To_Address (Queue_Ptr)); + end if; + return Actual_Queue; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Read_Queue; diff --git a/src/fltk-tooltips.adb b/src/fltk-tooltips.adb index 84e4160..ccdb649 100644 --- a/src/fltk-tooltips.adb +++ b/src/fltk-tooltips.adb @@ -6,6 +6,7 @@ with + Ada.Assertions, Interfaces.C, System.Address_To_Access_Conversions; @@ -17,6 +18,11 @@ use type package body FLTK.Tooltips is + package Chk renames Ada.Assertions; + + + + ------------------------ -- Functions From C -- ------------------------ @@ -174,13 +180,16 @@ package body FLTK.Tooltips is return access FLTK.Widgets.Widget'Class is Widget_Ptr : Storage.Integer_Address := fl_tooltip_get_current; + Actual_Widget : access FLTK.Widgets.Widget'Class; begin if Widget_Ptr /= Null_Pointer then - return Widget_Convert.To_Pointer - (Storage.To_Address (fl_widget_get_user_data (Widget_Ptr))); - else - return null; + Widget_Ptr := fl_widget_get_user_data (Widget_Ptr); + pragma Assert (Widget_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Widget_Ptr)); end if; + return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Target; diff --git a/src/fltk-widgets-groups-help_views.adb b/src/fltk-widgets-groups-help_views.adb index c6f4602..ec8688d 100644 --- a/src/fltk-widgets-groups-help_views.adb +++ b/src/fltk-widgets-groups-help_views.adb @@ -243,9 +243,11 @@ package body FLTK.Widgets.Groups.Help_Views is S : in Interfaces.C.Strings.chars_ptr) return Interfaces.C.Strings.chars_ptr is - Ada_Help_View : access Help_View'Class := - Help_View_Convert.To_Pointer (Storage.To_Address (fl_widget_get_user_data (V))); + User_Data : Storage.Integer_Address := fl_widget_get_user_data (V); + Ada_Help_View : access Help_View'Class; begin + pragma Assert (User_Data /= Null_Pointer); + Ada_Help_View := Help_View_Convert.To_Pointer (Storage.To_Address (User_Data)); if Ada_Help_View.Zelda = null then return S; end if; @@ -257,6 +259,8 @@ package body FLTK.Widgets.Groups.Help_Views is else return Ada_Help_View.Hilda; end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Link_Callback_Hook; diff --git a/src/fltk-widgets-groups-tabbed.adb b/src/fltk-widgets-groups-tabbed.adb index 37556e5..3b62b3c 100644 --- a/src/fltk-widgets-groups-tabbed.adb +++ b/src/fltk-widgets-groups-tabbed.adb @@ -6,12 +6,18 @@ with + Ada.Assertions, Interfaces.C; package body FLTK.Widgets.Groups.Tabbed is + package Chk renames Ada.Assertions; + + + + ------------------------ -- Functions From C -- ------------------------ @@ -186,12 +192,17 @@ package body FLTK.Widgets.Groups.Tabbed is (This : in Tabbed_Group) return access Widget'Class is - Widget_Ptr : Storage.Integer_Address := - fl_tabs_get_push (This.Void_Ptr); - Actual_Widget : access Widget'Class := - Widget_Convert.To_Pointer (Storage.To_Address (fl_widget_get_user_data (Widget_Ptr))); + Push_Ptr : Storage.Integer_Address := fl_tabs_get_push (This.Void_Ptr); + Actual_Widget : access Widget'Class; begin + if Push_Ptr /= Null_Pointer then + Push_Ptr := fl_widget_get_user_data (Push_Ptr); + pragma Assert (Push_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Push_Ptr)); + end if; return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Push; @@ -207,12 +218,17 @@ package body FLTK.Widgets.Groups.Tabbed is (This : in Tabbed_Group) return access Widget'Class is - Widget_Ptr : Storage.Integer_Address := - fl_tabs_get_value (This.Void_Ptr); - Actual_Widget : access Widget'Class := - Widget_Convert.To_Pointer (Storage.To_Address (fl_widget_get_user_data (Widget_Ptr))); + Visible_Ptr : Storage.Integer_Address := fl_tabs_get_value (This.Void_Ptr); + Actual_Widget : access Widget'Class; begin + if Visible_Ptr /= Null_Pointer then + Visible_Ptr := fl_widget_get_user_data (Visible_Ptr); + pragma Assert (Visible_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Visible_Ptr)); + end if; return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Visible; @@ -229,12 +245,18 @@ package body FLTK.Widgets.Groups.Tabbed is Event_X, Event_Y : in Integer) return access Widget'Class is - Widget_Ptr : Storage.Integer_Address := + Which_Ptr : Storage.Integer_Address := fl_tabs_which (This.Void_Ptr, Interfaces.C.int (Event_X), Interfaces.C.int (Event_Y)); - Actual_Widget : access Widget'Class := - Widget_Convert.To_Pointer (Storage.To_Address (fl_widget_get_user_data (Widget_Ptr))); + Actual_Widget : access Widget'Class; begin + if Which_Ptr /= Null_Pointer then + Which_Ptr := fl_widget_get_user_data (Which_Ptr); + pragma Assert (Which_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Which_Ptr)); + end if; return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Which; diff --git a/src/fltk-widgets-groups-text_displays-text_editors.adb b/src/fltk-widgets-groups-text_displays-text_editors.adb index c3fea47..636e368 100644 --- a/src/fltk-widgets-groups-text_displays-text_editors.adb +++ b/src/fltk-widgets-groups-text_displays-text_editors.adb @@ -356,14 +356,16 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is E : in Storage.Integer_Address) return Interfaces.C.int is - Ada_Editor : access Text_Editor'Class := - Editor_Convert.To_Pointer (Storage.To_Address (fl_widget_get_user_data (E))); + Editor_Ptr : Storage.Integer_Address := fl_widget_get_user_data (E); + Ada_Editor : access Text_Editor'Class; Modi : Modifier := FLTK.Event.Last_Modifier; Actual_Key : Keypress := FLTK.Event.Last_Key; -- fuck you FLTK, give me the real code Ada_Key : Key_Combo := To_Ada (To_C (Actual_Key) + To_C (Modi)); Found_Binding : Boolean := False; begin + pragma Assert (Editor_Ptr /= Null_Pointer); + Ada_Editor := Editor_Convert.To_Pointer (Storage.To_Address (Editor_Ptr)); for B of Ada_Editor.Bindings loop if B.Key = Ada_Key then B.Func (Ada_Editor.all); diff --git a/src/fltk-widgets-groups-windows-double-cairo.adb b/src/fltk-widgets-groups-windows-double-cairo.adb index 75cf50a..eedcbd1 100644 --- a/src/fltk-widgets-groups-windows-double-cairo.adb +++ b/src/fltk-widgets-groups-windows-double-cairo.adb @@ -6,6 +6,7 @@ with + Ada.Assertions, Interfaces.C, System.Address_To_Access_Conversions; @@ -13,6 +14,11 @@ with package body FLTK.Widgets.Groups.Windows.Double.Cairo is + package Chk renames Ada.Assertions; + + + + ------------------------ -- Functions From C -- ------------------------ @@ -74,9 +80,12 @@ package body FLTK.Widgets.Groups.Windows.Double.Cairo is Ada_Object : access Cairo_Window'Class := Cairo_Convert.To_Pointer (Ada_Addr); begin + pragma Assert (Ada_Object /= null); if Ada_Object.My_Func /= null then Ada_Object.My_Func (Cairo_Window (Ada_Object.all), Storage.To_Address (Cairo_Addr)); end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Cairo_Draw_Hook; diff --git a/src/fltk-widgets-groups-wizards.adb b/src/fltk-widgets-groups-wizards.adb index 658bf55..0f60c46 100644 --- a/src/fltk-widgets-groups-wizards.adb +++ b/src/fltk-widgets-groups-wizards.adb @@ -6,12 +6,18 @@ with + Ada.Assertions, Interfaces.C; package body FLTK.Widgets.Groups.Wizards is + package Chk renames Ada.Assertions; + + + + ------------------------ -- Functions From C -- ------------------------ @@ -165,12 +171,17 @@ package body FLTK.Widgets.Groups.Wizards is (This : in Wizard) return access Widget'Class is - Widget_Ptr : Storage.Integer_Address := - fl_wizard_get_visible (This.Void_Ptr); - Actual_Widget : access Widget'Class := - Widget_Convert.To_Pointer (Storage.To_Address (fl_widget_get_user_data (Widget_Ptr))); + Visible_Ptr : Storage.Integer_Address := fl_wizard_get_visible (This.Void_Ptr); + Actual_Widget : access Widget'Class; begin + if Visible_Ptr /= Null_Pointer then + Visible_Ptr := fl_widget_get_user_data (Visible_Ptr); + pragma Assert (Visible_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Visible_Ptr)); + end if; return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Get_Visible; diff --git a/src/fltk-widgets-menus.adb b/src/fltk-widgets-menus.adb index be46a72..28653ec 100644 --- a/src/fltk-widgets-menus.adb +++ b/src/fltk-widgets-menus.adb @@ -6,8 +6,9 @@ with - Interfaces.C.Strings, - Ada.Unchecked_Deallocation; + Ada.Assertions, + Ada.Unchecked_Deallocation, + Interfaces.C.Strings; use type @@ -19,6 +20,11 @@ use type package body FLTK.Widgets.Menus is + package Chk renames Ada.Assertions; + + + + ------------------------ -- Functions From C -- ------------------------ @@ -272,11 +278,15 @@ package body FLTK.Widgets.Menus is procedure Item_Hook (M, U : in Storage.Integer_Address) is - Ada_Widget : access Widget'Class := - Widget_Convert.To_Pointer (Storage.To_Address (fl_widget_get_user_data (M))); + C_Ptr : Storage.Integer_Address := fl_widget_get_user_data (M); + Ada_Widget : access Widget'Class; Action : Widget_Callback := Callback_Convert.To_Access (U); begin + pragma Assert (C_Ptr /= Null_Pointer); + Ada_Widget := Widget_Convert.To_Pointer (Storage.To_Address (C_Ptr)); Action.all (Ada_Widget.all); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; end Item_Hook; |