diff options
Diffstat (limited to 'src/fltk_binding')
43 files changed, 500 insertions, 409 deletions
diff --git a/src/fltk_binding/fltk-text_buffers.adb b/src/fltk_binding/fltk-text_buffers.adb index 12a6a73..52f475d 100644 --- a/src/fltk_binding/fltk-text_buffers.adb +++ b/src/fltk_binding/fltk-text_buffers.adb @@ -23,8 +23,10 @@ package body FLTK.Text_Buffers is procedure Finalize (This : in out Text_Buffer) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_text_buffer (This.Void_Ptr); + if This.Void_Ptr /= System.Null_Address then + if This in Text_Buffer then + free_fl_text_buffer (This.Void_Ptr); + end if; end if; end Finalize; @@ -35,14 +37,12 @@ package body FLTK.Text_Buffers is (Requested_Size : in Natural := 0; Preferred_Gap_Size : in Natural := 1024) return Text_Buffer is - - VP : System.Address; - begin - VP := new_fl_text_buffer + return This : Text_Buffer do + This.Void_Ptr := new_fl_text_buffer (Interfaces.C.int (Requested_Size), Interfaces.C.int (Preferred_Gap_Size)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + end return; end Create; diff --git a/src/fltk_binding/fltk-text_buffers.ads b/src/fltk_binding/fltk-text_buffers.ads index 902c978..2dae75d 100644 --- a/src/fltk_binding/fltk-text_buffers.ads +++ b/src/fltk_binding/fltk-text_buffers.ads @@ -4,7 +4,8 @@ package FLTK.Text_Buffers is type Text_Buffer is new Wrapper with private; - type Text_Buffer_Access is access all Text_Buffer; + type Text_Buffer_Cursor (Data : access Text_Buffer'Class) is limited null record + with Implicit_Dereference => Data; function Create diff --git a/src/fltk_binding/fltk-widgets-boxes.adb b/src/fltk_binding/fltk-widgets-boxes.adb index 8f1f759..17f8975 100644 --- a/src/fltk_binding/fltk-widgets-boxes.adb +++ b/src/fltk_binding/fltk-widgets-boxes.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Boxes is function new_fl_box (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_box, "new_fl_box"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Boxes is procedure Finalize (This : in out Box) is begin + Finalize (Widget (This)); if (This.Void_Ptr /= System.Null_Address) then - free_fl_box (This.Void_Ptr); + if This in Box then + free_fl_box (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Boxes is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Box is - - VP : System.Address; - begin - VP := new_fl_box + return This : Box do + This.Void_Ptr := new_fl_box (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-boxes.ads b/src/fltk_binding/fltk-widgets-boxes.ads index e8a7b83..00f84d4 100644 --- a/src/fltk_binding/fltk-widgets-boxes.ads +++ b/src/fltk_binding/fltk-widgets-boxes.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Boxes is type Box is new Widget with private; - type Box_Access is access all Box; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Box; diff --git a/src/fltk_binding/fltk-widgets-buttons-enter.adb b/src/fltk_binding/fltk-widgets-buttons-enter.adb index a5e2c07..196cae1 100644 --- a/src/fltk_binding/fltk-widgets-buttons-enter.adb +++ b/src/fltk_binding/fltk-widgets-buttons-enter.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons.Enter is function new_fl_return_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_return_button, "new_fl_return_button"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Buttons.Enter is procedure Finalize (This : in out Enter_Button) is begin + Finalize (Button (This)); if (This.Void_Ptr /= System.Null_Address) then - free_fl_return_button (This.Void_Ptr); + if This in Enter_Button then + free_fl_return_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Buttons.Enter is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Enter_Button is - - VP : System.Address; - begin - VP := new_fl_return_button + return This : Enter_Button do + This.Void_Ptr := new_fl_return_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-buttons-enter.ads b/src/fltk_binding/fltk-widgets-buttons-enter.ads index 9e5abf6..1db7308 100644 --- a/src/fltk_binding/fltk-widgets-buttons-enter.ads +++ b/src/fltk_binding/fltk-widgets-buttons-enter.ads @@ -1,16 +1,17 @@ -- Return Buttons, but return is a reserved word, so they're Enter Buttons instead + + package FLTK.Widgets.Buttons.Enter is type Enter_Button is new Button with private; - type Enter_Button_Access is access all Enter_Button; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Enter_Button; diff --git a/src/fltk_binding/fltk-widgets-buttons-light-check.adb b/src/fltk_binding/fltk-widgets-buttons-light-check.adb index ebaf9ce..e73bca0 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light-check.adb +++ b/src/fltk_binding/fltk-widgets-buttons-light-check.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons.Light.Check is function new_fl_check_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_check_button, "new_fl_check_button"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Buttons.Light.Check is procedure Finalize (This : in out Check_Button) is begin + Finalize (Light_Button (This)); if (This.Void_Ptr /= System.Null_Address) then - free_fl_check_button (This.Void_Ptr); + if This in Check_Button then + free_fl_check_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Buttons.Light.Check is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Check_Button is - - VP : System.Address; - begin - VP := new_fl_check_button + return This : Check_Button do + This.Void_Ptr := new_fl_check_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-buttons-light-check.ads b/src/fltk_binding/fltk-widgets-buttons-light-check.ads index 68e5c17..1ab34f0 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light-check.ads +++ b/src/fltk_binding/fltk-widgets-buttons-light-check.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Buttons.Light.Check is type Check_Button is new Light_Button with private; - type Check_Button_Access is access all Check_Button; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Check_Button; diff --git a/src/fltk_binding/fltk-widgets-buttons-light-radio.adb b/src/fltk_binding/fltk-widgets-buttons-light-radio.adb index 6f99f05..1c1e0da 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light-radio.adb +++ b/src/fltk_binding/fltk-widgets-buttons-light-radio.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons.Light.Radio is function new_fl_radio_light_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_radio_light_button, "new_fl_radio_light_button"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Buttons.Light.Radio is procedure Finalize (This : in out Radio_Light_Button) is begin + Finalize (Light_Button (This)); if (This.Void_Ptr /= System.Null_Address) then - free_fl_radio_light_button (This.Void_Ptr); + if This in Radio_Light_Button then + free_fl_radio_light_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Buttons.Light.Radio is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Radio_Light_Button is - - VP : System.Address; - begin - VP := new_fl_radio_light_button + return This : Radio_Light_Button do + This.Void_Ptr := new_fl_radio_light_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-buttons-light-radio.ads b/src/fltk_binding/fltk-widgets-buttons-light-radio.ads index 072ff33..bad0a92 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light-radio.ads +++ b/src/fltk_binding/fltk-widgets-buttons-light-radio.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Buttons.Light.Radio is type Radio_Light_Button is new Light_Button with private; - type Radio_Light_Button_Access is access all Radio_Light_Button; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Radio_Light_Button; diff --git a/src/fltk_binding/fltk-widgets-buttons-light-round-radio.adb b/src/fltk_binding/fltk-widgets-buttons-light-round-radio.adb index 9fc8076..299c350 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light-round-radio.adb +++ b/src/fltk_binding/fltk-widgets-buttons-light-round-radio.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons.Light.Round.Radio is function new_fl_radio_round_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_radio_round_button, "new_fl_radio_round_button"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Buttons.Light.Round.Radio is procedure Finalize (This : in out Radio_Round_Button) is begin + Finalize (Round_Button (This)); if (This.Void_Ptr /= System.Null_Address) then - free_fl_radio_round_button (This.Void_Ptr); + if This in Radio_Round_Button then + free_fl_radio_round_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Buttons.Light.Round.Radio is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Radio_Round_Button is - - VP : System.Address; - begin - VP := new_fl_radio_round_button + return This : Radio_Round_Button do + This.Void_Ptr := new_fl_radio_round_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-buttons-light-round-radio.ads b/src/fltk_binding/fltk-widgets-buttons-light-round-radio.ads index 7d21ad7..ad1eec7 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light-round-radio.ads +++ b/src/fltk_binding/fltk-widgets-buttons-light-round-radio.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Buttons.Light.Round.Radio is type Radio_Round_Button is new Round_Button with private; - type Radio_Round_Button_Access is access all Radio_Round_Button; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Radio_Round_Button; diff --git a/src/fltk_binding/fltk-widgets-buttons-light-round.adb b/src/fltk_binding/fltk-widgets-buttons-light-round.adb index 555dcc4..553814b 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light-round.adb +++ b/src/fltk_binding/fltk-widgets-buttons-light-round.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons.Light.Round is function new_fl_round_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_round_button, "new_fl_round_button"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Buttons.Light.Round is procedure Finalize (This : in out Round_Button) is begin + Finalize (Light_Button (This)); if (This.Void_Ptr /= System.Null_Address) then - free_fl_round_button (This.Void_Ptr); + if This in Round_Button then + free_fl_round_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Buttons.Light.Round is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Round_Button is - - VP : System.Address; - begin - VP := new_fl_round_button + return This : Round_Button do + This.Void_Ptr := new_fl_round_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-buttons-light-round.ads b/src/fltk_binding/fltk-widgets-buttons-light-round.ads index 0209d4b..7cb99b8 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light-round.ads +++ b/src/fltk_binding/fltk-widgets-buttons-light-round.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Buttons.Light.Round is type Round_Button is new Light_Button with private; - type Round_Button_Access is access all Round_Button; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Round_Button; diff --git a/src/fltk_binding/fltk-widgets-buttons-light.adb b/src/fltk_binding/fltk-widgets-buttons-light.adb index 18e179d..29f9968 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light.adb +++ b/src/fltk_binding/fltk-widgets-buttons-light.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons.Light is function new_fl_light_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_light_button, "new_fl_light_button"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Buttons.Light is procedure Finalize (This : in out Light_Button) is begin + Finalize (Button (This)); if (This.Void_Ptr /= System.Null_Address) then - free_fl_light_button (This.Void_Ptr); + if This in Light_Button then + free_fl_light_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Buttons.Light is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Light_Button is - - VP : System.Address; - begin - VP := new_fl_light_button + return This : Light_Button do + This.Void_Ptr := new_fl_light_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-buttons-light.ads b/src/fltk_binding/fltk-widgets-buttons-light.ads index a3a11b3..6fe7a76 100644 --- a/src/fltk_binding/fltk-widgets-buttons-light.ads +++ b/src/fltk_binding/fltk-widgets-buttons-light.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Buttons.Light is type Light_Button is new Button with private; - type Light_Button_Access is access all Light_Button; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Light_Button; diff --git a/src/fltk_binding/fltk-widgets-buttons-radio.adb b/src/fltk_binding/fltk-widgets-buttons-radio.adb index 4a26178..8ca6f44 100644 --- a/src/fltk_binding/fltk-widgets-buttons-radio.adb +++ b/src/fltk_binding/fltk-widgets-buttons-radio.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons.Radio is function new_fl_radio_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_radio_button, "new_fl_radio_button"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Buttons.Radio is procedure Finalize (This : in out Radio_Button) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_radio_button (This.Void_Ptr); + Finalize (Button (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Radio_Button then + free_fl_radio_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Buttons.Radio is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Radio_Button is - - VP : System.Address; - begin - VP := new_fl_radio_button + return This : Radio_Button do + This.Void_Ptr := new_fl_radio_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-buttons-radio.ads b/src/fltk_binding/fltk-widgets-buttons-radio.ads index 55a9725..cf14eeb 100644 --- a/src/fltk_binding/fltk-widgets-buttons-radio.ads +++ b/src/fltk_binding/fltk-widgets-buttons-radio.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Buttons.Radio is type Radio_Button is new Button with private; - type Radio_Button_Access is access all Radio_Button; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Radio_Button; diff --git a/src/fltk_binding/fltk-widgets-buttons-repeat.adb b/src/fltk_binding/fltk-widgets-buttons-repeat.adb index 55644cb..2f2c195 100644 --- a/src/fltk_binding/fltk-widgets-buttons-repeat.adb +++ b/src/fltk_binding/fltk-widgets-buttons-repeat.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons.Repeat is function new_fl_repeat_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_repeat_button, "new_fl_repeat_button"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Buttons.Repeat is procedure Finalize (This : in out Repeat_Button) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_repeat_button (This.Void_Ptr); + Finalize (Button (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Repeat_Button then + free_fl_repeat_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Buttons.Repeat is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Repeat_Button is - - VP : System.Address; - begin - VP := new_fl_repeat_button + return This : Repeat_Button do + This.Void_Ptr := new_fl_repeat_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-buttons-repeat.ads b/src/fltk_binding/fltk-widgets-buttons-repeat.ads index 0334bcd..5c27b40 100644 --- a/src/fltk_binding/fltk-widgets-buttons-repeat.ads +++ b/src/fltk_binding/fltk-widgets-buttons-repeat.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Buttons.Repeat is type Repeat_Button is new Button with private; - type Repeat_Button_Access is access all Repeat_Button; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Repeat_Button; diff --git a/src/fltk_binding/fltk-widgets-buttons-toggle.adb b/src/fltk_binding/fltk-widgets-buttons-toggle.adb index b6e7dc2..995f8bf 100644 --- a/src/fltk_binding/fltk-widgets-buttons-toggle.adb +++ b/src/fltk_binding/fltk-widgets-buttons-toggle.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons.Toggle is function new_fl_toggle_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_toggle_button, "new_fl_toggle_button"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Buttons.Toggle is procedure Finalize (This : in out Toggle_Button) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_toggle_button (This.Void_Ptr); + Finalize (Button (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Toggle_Button then + free_fl_toggle_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Buttons.Toggle is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Toggle_Button is - - VP : System.Address; - begin - VP := new_fl_toggle_button + return This : Toggle_Button do + This.Void_Ptr := new_fl_toggle_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-buttons-toggle.ads b/src/fltk_binding/fltk-widgets-buttons-toggle.ads index f472dee..a8f4181 100644 --- a/src/fltk_binding/fltk-widgets-buttons-toggle.ads +++ b/src/fltk_binding/fltk-widgets-buttons-toggle.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Buttons.Toggle is type Toggle_Button is new Button with private; - type Toggle_Button_Access is access all Toggle_Button; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Toggle_Button; diff --git a/src/fltk_binding/fltk-widgets-buttons.adb b/src/fltk_binding/fltk-widgets-buttons.adb index d74718a..2f2f938 100644 --- a/src/fltk_binding/fltk-widgets-buttons.adb +++ b/src/fltk_binding/fltk-widgets-buttons.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Buttons is function new_fl_button (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_button, "new_fl_button"); @@ -38,8 +38,11 @@ package body FLTK.Widgets.Buttons is procedure Finalize (This : in out Button) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_button (This.Void_Ptr); + Finalize (Widget (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Button then + free_fl_button (This.Void_Ptr); + end if; end if; end Finalize; @@ -48,48 +51,46 @@ package body FLTK.Widgets.Buttons is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Button is - - VP : System.Address; - begin - VP := new_fl_button + return This : Button do + This.Void_Ptr := new_fl_button (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; function Get_State - (B : in Button'Class) + (This : in Button) return State is begin - return State'Val (fl_button_get_state (B.Void_Ptr)); + return State'Val (fl_button_get_state (This.Void_Ptr)); end Get_State; procedure Set_State - (B : in out Button'Class; - S : in State) is + (This : in out Button; + St : in State) is begin - fl_button_set_state (B.Void_Ptr, State'Pos (S)); + fl_button_set_state (This.Void_Ptr, State'Pos (St)); end Set_State; procedure Set_Only - (B : in out Button'Class) is + (This : in out Button) is begin - fl_button_set_only (B.Void_Ptr); + fl_button_set_only (This.Void_Ptr); end Set_Only; diff --git a/src/fltk_binding/fltk-widgets-buttons.ads b/src/fltk_binding/fltk-widgets-buttons.ads index 42f6e8b..a31ed79 100644 --- a/src/fltk_binding/fltk-widgets-buttons.ads +++ b/src/fltk_binding/fltk-widgets-buttons.ads @@ -4,7 +4,6 @@ package FLTK.Widgets.Buttons is type Button is new Widget with private; - type Button_Access is access all Button; type State is (On, Off); @@ -12,22 +11,22 @@ package FLTK.Widgets.Buttons is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Button; function Get_State - (B : in Button'Class) + (This : in Button) return State; procedure Set_State - (B : in out Button'Class; - S : in State); + (This : in out Button; + St : in State); procedure Set_Only - (B : in out Button'Class); + (This : in out Button); private diff --git a/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.adb b/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.adb index ccf3a94..f5eead6 100644 --- a/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.adb +++ b/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is function new_fl_text_editor (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_text_editor, "new_fl_text_editor"); @@ -31,8 +31,11 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is procedure Finalize (This : in out Text_Editor) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_text_editor (This.Void_Ptr); + Finalize (Text_Display (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Text_Editor then + free_fl_text_editor (This.Void_Ptr); + end if; end if; end Finalize; @@ -41,20 +44,18 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Text_Editor is - - VP : System.Address; - begin - VP := new_fl_text_editor + return This : Text_Editor do + This.Void_Ptr := new_fl_text_editor (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP, Buffer => null); + Interfaces.C.To_C (Text)); + fl_group_end (This.Void_Ptr); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.ads b/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.ads index c29b107..5b179b9 100644 --- a/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.ads +++ b/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is type Text_Editor is new Text_Display with private; - type Text_Editor_Access is access all Text_Editor; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Text_Editor; diff --git a/src/fltk_binding/fltk-widgets-groups-text_displays.adb b/src/fltk_binding/fltk-widgets-groups-text_displays.adb index 5907185..46d1026 100644 --- a/src/fltk_binding/fltk-widgets-groups-text_displays.adb +++ b/src/fltk_binding/fltk-widgets-groups-text_displays.adb @@ -70,8 +70,11 @@ package body FLTK.Widgets.Groups.Text_Displays is procedure Finalize (This : in out Text_Display) is begin + Finalize (Group (This)); if (This.Void_Ptr /= System.Null_Address) then - free_fl_text_display (This.Void_Ptr); + if This in Text_Display then + free_fl_text_display (This.Void_Ptr); + end if; end if; end Finalize; @@ -80,101 +83,99 @@ package body FLTK.Widgets.Groups.Text_Displays is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Text_Display is - - VP : System.Address; - begin - VP := new_fl_text_display + return This : Text_Display do + This.Void_Ptr := new_fl_text_display (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP, Buffer => null); + Interfaces.C.To_C (Text)); + fl_group_end (This.Void_Ptr); + end return; end Create; function Get_Buffer - (TD : in Text_Display'Class) - return Text_Buffer_Access is + (This : in Text_Display) + return Text_Buffer_Cursor is begin - return TD.Buffer; + return Ref : Text_Buffer_Cursor (This.Buffer); end Get_Buffer; procedure Set_Buffer - (TD : in out Text_Display'Class; - TB : aliased in out Text_Buffer) is + (This : in out Text_Display; + Buff : in out Text_Buffer) is begin - fl_text_display_set_buffer (TD.Void_Ptr, Wrapper (TB).Void_Ptr); - TD.Buffer := TB'Access; + This.Buffer := Buff'Unchecked_Access; + fl_text_display_set_buffer (This.Void_Ptr, Wrapper (Buff).Void_Ptr); end Set_Buffer; function Get_Text_Color - (TD : in Text_Display'Class) + (This : in Text_Display) return Color is begin - return Color (fl_text_display_get_text_color (TD.Void_Ptr)); + return Color (fl_text_display_get_text_color (This.Void_Ptr)); end Get_Text_Color; procedure Set_Text_Color - (TD : in out Text_Display'Class; - C : in Color) is + (This : in out Text_Display; + Col : in Color) is begin - fl_text_display_set_text_color (TD.Void_Ptr, Interfaces.C.int (C)); + fl_text_display_set_text_color (This.Void_Ptr, Interfaces.C.int (Col)); end Set_Text_Color; function Get_Text_Font - (TD : in Text_Display'Class) + (This : in Text_Display) return Font_Kind is begin - return Font_Kind'Val (fl_text_display_get_text_font (TD.Void_Ptr)); + return Font_Kind'Val (fl_text_display_get_text_font (This.Void_Ptr)); end Get_Text_Font; procedure Set_Text_Font - (TD : in out Text_Display'Class; - F : in Font_Kind) is + (This : in out Text_Display; + Font : in Font_Kind) is begin - fl_text_display_set_text_font (TD.Void_Ptr, Font_Kind'Pos (F)); + fl_text_display_set_text_font (This.Void_Ptr, Font_Kind'Pos (Font)); end Set_Text_Font; function Get_Text_Size - (TD : in Text_Display'Class) + (This : in Text_Display) return Font_Size is begin - return Font_Size (fl_text_display_get_text_size (TD.Void_Ptr)); + return Font_Size (fl_text_display_get_text_size (This.Void_Ptr)); end Get_Text_Size; procedure Set_Text_Size - (TD : in out Text_Display'Class; - S : in Font_Size) is + (This : in out Text_Display; + Size : in Font_Size) is begin - fl_text_display_set_text_size (TD.Void_Ptr, Interfaces.C.int (S)); + fl_text_display_set_text_size (This.Void_Ptr, Interfaces.C.int (Size)); end Set_Text_Size; diff --git a/src/fltk_binding/fltk-widgets-groups-text_displays.ads b/src/fltk_binding/fltk-widgets-groups-text_displays.ads index 86ca8b9..bb99e78 100644 --- a/src/fltk_binding/fltk-widgets-groups-text_displays.ads +++ b/src/fltk_binding/fltk-widgets-groups-text_displays.ads @@ -8,53 +8,52 @@ package FLTK.Widgets.Groups.Text_Displays is type Text_Display is new Group with private; - type Text_Display_Access is access all Text_Display; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Text_Display; function Get_Buffer - (TD : in Text_Display'Class) - return Text_Buffer_Access; + (This : in Text_Display) + return Text_Buffer_Cursor; procedure Set_Buffer - (TD : in out Text_Display'Class; - TB : aliased in out Text_Buffer); + (This : in out Text_Display; + Buff : in out Text_Buffer); function Get_Text_Color - (TD : in Text_Display'Class) + (This : in Text_Display) return Color; procedure Set_Text_Color - (TD : in out Text_Display'Class; - C : in Color); + (This : in out Text_Display; + Col : in Color); function Get_Text_Font - (TD : in Text_Display'Class) + (This : in Text_Display) return Font_Kind; procedure Set_Text_Font - (TD : in out Text_Display'Class; - F : in Font_Kind); + (This : in out Text_Display; + Font : in Font_Kind); function Get_Text_Size - (TD : in Text_Display'Class) + (This : in Text_Display) return Font_Size; procedure Set_Text_Size - (TD : in out Text_Display'Class; - S : in Font_Size); + (This : in out Text_Display; + Size : in Font_Size); private @@ -62,7 +61,7 @@ private type Text_Display is new Group with record - Buffer : Text_Buffer_Access; + Buffer : access Text_Buffer; end record; diff --git a/src/fltk_binding/fltk-widgets-groups-windows-double.adb b/src/fltk_binding/fltk-widgets-groups-windows-double.adb index 21eeab3..66cf625 100644 --- a/src/fltk_binding/fltk-widgets-groups-windows-double.adb +++ b/src/fltk_binding/fltk-widgets-groups-windows-double.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Groups.Windows.Double is function new_fl_double_window (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_double_window, "new_fl_double_window"); @@ -40,8 +40,11 @@ package body FLTK.Widgets.Groups.Windows.Double is procedure Finalize (This : in out Double_Window) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_double_window (This.Void_Ptr); + Finalize (Window (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Double_Window then + free_fl_double_window (This.Void_Ptr); + end if; end if; end Finalize; @@ -50,20 +53,18 @@ package body FLTK.Widgets.Groups.Windows.Double is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Double_Window is - - VP : System.Address; - begin - VP := new_fl_double_window + return This : Double_Window do + This.Void_Ptr := new_fl_double_window (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + fl_group_end (This.Void_Ptr); + end return; end Create; @@ -72,24 +73,22 @@ package body FLTK.Widgets.Groups.Windows.Double is function Create (W, H : in Integer) return Double_Window is - - VP : System.Address; - begin - VP := new_fl_double_window2 + return This : Double_Window do + This.Void_Ptr := new_fl_double_window2 (Interfaces.C.int (W), Interfaces.C.int (H)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + fl_group_end (This.Void_Ptr); + end return; end Create; procedure Show - (W : in Double_Window) is + (This : in Double_Window) is begin - fl_double_window_show (W.Void_Ptr); + fl_double_window_show (This.Void_Ptr); end Show; diff --git a/src/fltk_binding/fltk-widgets-groups-windows-double.ads b/src/fltk_binding/fltk-widgets-groups-windows-double.ads index 5e93da1..20b5362 100644 --- a/src/fltk_binding/fltk-widgets-groups-windows-double.ads +++ b/src/fltk_binding/fltk-widgets-groups-windows-double.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Groups.Windows.Double is type Double_Window is new Window with private; - type Double_Window_Access is access all Double_Window; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Double_Window; @@ -19,7 +18,7 @@ package FLTK.Widgets.Groups.Windows.Double is procedure Show - (W : in Double_Window); + (This : in Double_Window); private diff --git a/src/fltk_binding/fltk-widgets-groups-windows-single-menu.adb b/src/fltk_binding/fltk-widgets-groups-windows-single-menu.adb index dde040f..26fd5ab 100644 --- a/src/fltk_binding/fltk-widgets-groups-windows-single-menu.adb +++ b/src/fltk_binding/fltk-widgets-groups-windows-single-menu.adb @@ -62,8 +62,11 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is procedure Finalize (This : in out Menu_Window) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_menu_window (This.Void_Ptr); + Finalize (Single_Window (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Menu_Window then + free_fl_menu_window (This.Void_Ptr); + end if; end if; end Finalize; @@ -72,20 +75,18 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Menu_Window is - - VP : System.Address; - begin - VP := new_fl_menu_window + return This : Menu_Window do + This.Void_Ptr := new_fl_menu_window (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + fl_group_end (This.Void_Ptr); + end return; end Create; @@ -94,52 +95,50 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is function Create (W, H : in Integer) return Menu_Window is - - VP : System.Address; - begin - VP := new_fl_menu_window2 + return This : Menu_Window do + This.Void_Ptr := new_fl_menu_window2 (Interfaces.C.int (W), Interfaces.C.int (H)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + fl_group_end (This.Void_Ptr); + end return; end Create; procedure Show - (M : in Menu_Window) is + (This : in Menu_Window) is begin - fl_menu_window_show (M.Void_Ptr); + fl_menu_window_show (This.Void_Ptr); end Show; procedure Hide - (M : in Menu_Window) is + (This : in Menu_Window) is begin - fl_menu_window_hide (M.Void_Ptr); + fl_menu_window_hide (This.Void_Ptr); end Hide; procedure Flush - (M : in out Menu_Window) is + (This : in out Menu_Window) is begin - fl_menu_window_flush (M.Void_Ptr); + fl_menu_window_flush (This.Void_Ptr); end Flush; function Get_Overlay - (M : in Menu_Window) + (This : in Menu_Window) return Boolean is begin - if fl_menu_window_overlay (M.Void_Ptr) = 0 then + if fl_menu_window_overlay (This.Void_Ptr) = 0 then return False; else return True; @@ -149,13 +148,13 @@ package body FLTK.Widgets.Groups.Windows.Single.Menu is procedure Set_Overlay - (M : in out Menu_Window; - V : in Boolean) is + (This : in out Menu_Window; + Value : in Boolean) is begin - if V then - fl_menu_window_set_overlay (M.Void_Ptr); + if Value then + fl_menu_window_set_overlay (This.Void_Ptr); else - fl_menu_window_clear_overlay (M.Void_Ptr); + fl_menu_window_clear_overlay (This.Void_Ptr); end if; end Set_Overlay; diff --git a/src/fltk_binding/fltk-widgets-groups-windows-single-menu.ads b/src/fltk_binding/fltk-widgets-groups-windows-single-menu.ads index 7e10426..f5d88e7 100644 --- a/src/fltk_binding/fltk-widgets-groups-windows-single-menu.ads +++ b/src/fltk_binding/fltk-widgets-groups-windows-single-menu.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Groups.Windows.Single.Menu is type Menu_Window is new Single_Window with private; - type Menu_Window_Access is access all Menu_Window; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Menu_Window; @@ -19,25 +18,25 @@ package FLTK.Widgets.Groups.Windows.Single.Menu is procedure Show - (M : in Menu_Window); + (This : in Menu_Window); procedure Hide - (M : in Menu_Window); + (This : in Menu_Window); procedure Flush - (M : in out Menu_Window); + (This : in out Menu_Window); function Get_Overlay - (M : in Menu_Window) + (This : in Menu_Window) return Boolean; procedure Set_Overlay - (M : in out Menu_Window; - V : in Boolean); + (This : in out Menu_Window; + Value : in Boolean); private diff --git a/src/fltk_binding/fltk-widgets-groups-windows-single.adb b/src/fltk_binding/fltk-widgets-groups-windows-single.adb index e3b6f79..7a9cd32 100644 --- a/src/fltk_binding/fltk-widgets-groups-windows-single.adb +++ b/src/fltk_binding/fltk-widgets-groups-windows-single.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Groups.Windows.Single is function new_fl_single_window (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_single_window, "new_fl_single_window"); @@ -44,8 +44,11 @@ package body FLTK.Widgets.Groups.Windows.Single is procedure Finalize (This : in out Single_Window) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_single_window (This.Void_Ptr); + Finalize (Window (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Single_Window then + free_fl_single_window (This.Void_Ptr); + end if; end if; end Finalize; @@ -54,20 +57,18 @@ package body FLTK.Widgets.Groups.Windows.Single is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Single_Window is - - VP : System.Address; - begin - VP := new_fl_single_window + return This : Single_Window do + This.Void_Ptr := new_fl_single_window (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + fl_group_end (This.Void_Ptr); + end return; end Create; @@ -76,33 +77,31 @@ package body FLTK.Widgets.Groups.Windows.Single is function Create (W, H : in Integer) return Single_Window is - - VP : System.Address; - begin - VP := new_fl_single_window2 + return This : Single_Window do + This.Void_Ptr := new_fl_single_window2 (Interfaces.C.int (W), Interfaces.C.int (H)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + fl_group_end (This.Void_Ptr); + end return; end Create; procedure Show - (S : in Single_Window) is + (This : in Single_Window) is begin - fl_single_window_show (S.Void_Ptr); + fl_single_window_show (This.Void_Ptr); end Show; procedure Flush - (S : in out Single_Window) is + (This : in out Single_Window) is begin - fl_single_window_flush (S.Void_Ptr); + fl_single_window_flush (This.Void_Ptr); end Flush; diff --git a/src/fltk_binding/fltk-widgets-groups-windows-single.ads b/src/fltk_binding/fltk-widgets-groups-windows-single.ads index 1587678..07a2bca 100644 --- a/src/fltk_binding/fltk-widgets-groups-windows-single.ads +++ b/src/fltk_binding/fltk-widgets-groups-windows-single.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Groups.Windows.Single is type Single_Window is new Window with private; - type Single_Window_Access is access all Single_Window; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Single_Window; @@ -19,11 +18,11 @@ package FLTK.Widgets.Groups.Windows.Single is procedure Show - (S : in Single_Window); + (This : in Single_Window); procedure Flush - (S : in out Single_Window); + (This : in out Single_Window); private diff --git a/src/fltk_binding/fltk-widgets-groups-windows.adb b/src/fltk_binding/fltk-widgets-groups-windows.adb index 806ebf3..c9d01f3 100644 --- a/src/fltk_binding/fltk-widgets-groups-windows.adb +++ b/src/fltk_binding/fltk-widgets-groups-windows.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Groups.Windows is function new_fl_window (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_window, "new_fl_window"); @@ -40,8 +40,11 @@ package body FLTK.Widgets.Groups.Windows is procedure Finalize (This : in out Window) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_window (This.Void_Ptr); + Finalize (Group (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Window then + free_fl_window (This.Void_Ptr); + end if; end if; end Finalize; @@ -50,20 +53,18 @@ package body FLTK.Widgets.Groups.Windows is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Window is - - VP : System.Address; - begin - VP := new_fl_window + return This : Window do + This.Void_Ptr := new_fl_window (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + fl_group_end (This.Void_Ptr); + end return; end Create; @@ -72,22 +73,22 @@ package body FLTK.Widgets.Groups.Windows is function Create (W, H : in Integer) return Window is - - VP : System.Address; - begin - VP := new_fl_window2 (Interfaces.C.int (W), Interfaces.C.int (H)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + return This : Window do + This.Void_Ptr := new_fl_window2 + (Interfaces.C.int (W), + Interfaces.C.int (H)); + fl_group_end (This.Void_Ptr); + end return; end Create; procedure Show - (W : in Window) is + (This : in Window) is begin - fl_window_show (W.Void_Ptr); + fl_window_show (This.Void_Ptr); end Show; diff --git a/src/fltk_binding/fltk-widgets-groups-windows.ads b/src/fltk_binding/fltk-widgets-groups-windows.ads index 714d6dd..54d855f 100644 --- a/src/fltk_binding/fltk-widgets-groups-windows.ads +++ b/src/fltk_binding/fltk-widgets-groups-windows.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Groups.Windows is type Window is new Group with private; - type Window_Access is access all Window; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Window; @@ -19,7 +18,7 @@ package FLTK.Widgets.Groups.Windows is procedure Show - (W : in Window); + (This : in Window); private diff --git a/src/fltk_binding/fltk-widgets-groups.adb b/src/fltk_binding/fltk-widgets-groups.adb index 0098842..b515cc5 100644 --- a/src/fltk_binding/fltk-widgets-groups.adb +++ b/src/fltk_binding/fltk-widgets-groups.adb @@ -3,6 +3,8 @@ with Interfaces.C; with System; use type System.Address; +with Ada.Containers.Vectors; +use type Ada.Containers.Count_Type; package body FLTK.Widgets.Groups is @@ -10,7 +12,7 @@ package body FLTK.Widgets.Groups is function new_fl_group (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_group, "new_fl_group"); @@ -30,10 +32,10 @@ package body FLTK.Widgets.Groups is (G : in System.Address); pragma Import (C, fl_group_clear, "fl_group_clear"); - function fl_group_find - (G, W : in System.Address) - return Interfaces.C.int; - pragma Import (C, fl_group_find, "fl_group_find"); + -- function fl_group_find + -- (G, W : in System.Address) + -- return Interfaces.C.int; + -- pragma Import (C, fl_group_find, "fl_group_find"); procedure fl_group_insert (G, W : in System.Address; @@ -52,11 +54,27 @@ package body FLTK.Widgets.Groups is + procedure Initialize + (This : in out Group) is + begin + Initialize (Widget (This)); + This.Widget_List := Widget_Vectors.Empty_Vector; + end Initialize; + + + + procedure Finalize (This : in out Group) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_group (This.Void_Ptr); + Finalize (Widget (This)); + if This.Void_Ptr /= System.Null_Address then + while This.Widget_List.Length > 0 loop + This.Remove (This.Widget_List.Last_Index); + end loop; + if This in Group then + free_fl_group (This.Void_Ptr); + end if; end if; end Finalize; @@ -65,38 +83,55 @@ package body FLTK.Widgets.Groups is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Group is - - VP : System.Address; - begin - VP := new_fl_group + return This : Group do + This.Void_Ptr := new_fl_group (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - fl_group_end (VP); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + fl_group_end (This.Void_Ptr); + end return; end Create; procedure Add - (This : in out Group'Class; - Item : in Widget'Class) is + (This : in out Group; + Item : in out Widget'Class) is begin + if Item.Parent /= null then + Item.Parent.Remove (Item); + end if; + This.Widget_List.Append (Item'Unchecked_Access); + Item.Parent := This'Unchecked_Access; fl_group_add (This.Void_Ptr, Item.Void_Ptr); end Add; + function Child + (This : in Group; + Place : in Index) + return Widget_Cursor is + begin + return Ref : Widget_Cursor (This.Widget_List.Element (Place)); + end Child; + + + + procedure Clear - (This : in out Group'Class) is + (This : in out Group) is begin + while This.Widget_List.Length > 0 loop + This.Remove (This.Widget_List.Last_Index); + end loop; fl_group_clear (This.Void_Ptr); end Clear; @@ -104,21 +139,26 @@ package body FLTK.Widgets.Groups is function Find - (This : in Group'Class; - Item : in Widget'Class) + (This : in Group; + Item : in out Widget'Class) return Index is begin - return Index (fl_group_find (This.Void_Ptr, Item.Void_Ptr)); + return This.Widget_List.Find_Index (Item'Unchecked_Access); end Find; procedure Insert - (This : in out Group'Class; - Item : in Widget'Class; + (This : in out Group; + Item : in out Widget'Class; Place : in Index) is begin + if Item.Parent /= null then + Item.Parent.Remove (Item); + end if; + This.Widget_List.Insert (Place, Item'Unchecked_Access); + Item.Parent := This'Unchecked_Access; fl_group_insert (This.Void_Ptr, Item.Void_Ptr, @@ -129,9 +169,11 @@ package body FLTK.Widgets.Groups is procedure Remove - (This : in out Group'Class; - Item : in Widget'Class) is + (This : in out Group; + Item : in out Widget'Class) is begin + Item.Parent := null; + This.Widget_List.Delete (This.Find (Item)); fl_group_remove (This.Void_Ptr, Item.Void_Ptr); end Remove; @@ -139,9 +181,11 @@ package body FLTK.Widgets.Groups is procedure Remove - (This : in out Group'Class; + (This : in out Group; Place : in Index) is begin + This.Widget_List.Element (Place).Parent := null; + This.Widget_List.Delete (Place); fl_group_remove2 (This.Void_Ptr, Interfaces.C.int (Place)); end Remove; diff --git a/src/fltk_binding/fltk-widgets-groups.ads b/src/fltk_binding/fltk-widgets-groups.ads index d38bb54..aa52083 100644 --- a/src/fltk_binding/fltk-widgets-groups.ads +++ b/src/fltk_binding/fltk-widgets-groups.ads @@ -1,64 +1,73 @@ --- need to add a Vector to keep track of the children added to a group, and --- to change their Void_Ptrs to null addresses if Clear or Finalize are --- called, otherwise bad things will happen - --- similarly, Widgets need to keep track of their parent so that Insert --- will work correctly +private with Ada.Containers.Vectors; package FLTK.Widgets.Groups is type Group is new Widget with private; - type Group_Access is access all Group; - - - type Index is new Integer; + type Index is new Positive; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Group; procedure Add - (This : in out Group'Class; - Item : in Widget'Class); + (This : in out Group; + Item : in out Widget'Class); + + + function Child + (This : in Group; + Place : in Index) + return Widget_Cursor; procedure Clear - (This : in out Group'Class); + (This : in out Group); function Find - (This : in Group'Class; - Item : in Widget'Class) + (This : in Group; + Item : in out Widget'Class) return Index; procedure Insert - (This : in out Group'Class; - Item : in Widget'Class; + (This : in out Group; + Item : in out Widget'Class; Place : in Index); procedure Remove - (This : in out Group'Class; - Item : in Widget'Class); + (This : in out Group; + Item : in out Widget'Class); procedure Remove - (This : in out Group'Class; + (This : in out Group; Place : in Index); private - type Group is new Widget with null record; + type Widget_Access is access all Widget'Class; + package Widget_Vectors is new Ada.Containers.Vectors (Index, Widget_Access); + + + type Group is new Widget with + record + Widget_List : Widget_Vectors.Vector; + end record; + + + overriding procedure Initialize + (This : in out Group); overriding procedure Finalize diff --git a/src/fltk_binding/fltk-widgets-inputs.adb b/src/fltk_binding/fltk-widgets-inputs.adb index e378684..37d99e7 100644 --- a/src/fltk_binding/fltk-widgets-inputs.adb +++ b/src/fltk_binding/fltk-widgets-inputs.adb @@ -10,7 +10,7 @@ package body FLTK.Widgets.Inputs is function new_fl_input (X, Y, W, H : in Interfaces.C.int; - Label : in Interfaces.C.char_array) + Text : in Interfaces.C.char_array) return System.Address; pragma Import (C, new_fl_input, "new_fl_input"); @@ -24,8 +24,11 @@ package body FLTK.Widgets.Inputs is procedure Finalize (This : in out Input) is begin - if (This.Void_Ptr /= System.Null_Address) then - free_fl_input (This.Void_Ptr); + Finalize (Widget (This)); + if This.Void_Ptr /= System.Null_Address then + if This in Input then + free_fl_input (This.Void_Ptr); + end if; end if; end Finalize; @@ -34,19 +37,17 @@ package body FLTK.Widgets.Inputs is function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Input is - - VP : System.Address; - begin - VP := new_fl_input + return This : Input do + This.Void_Ptr := new_fl_input (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.To_C (Label)); - return (Ada.Finalization.Limited_Controlled with Void_Ptr => VP); + Interfaces.C.To_C (Text)); + end return; end Create; diff --git a/src/fltk_binding/fltk-widgets-inputs.ads b/src/fltk_binding/fltk-widgets-inputs.ads index b0b8ca8..c1ebfbb 100644 --- a/src/fltk_binding/fltk-widgets-inputs.ads +++ b/src/fltk_binding/fltk-widgets-inputs.ads @@ -4,12 +4,11 @@ package FLTK.Widgets.Inputs is type Input is new Widget with private; - type Input_Access is access all Input; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Input; diff --git a/src/fltk_binding/fltk-widgets.adb b/src/fltk_binding/fltk-widgets.adb index 5529a6d..39ffb66 100644 --- a/src/fltk_binding/fltk-widgets.adb +++ b/src/fltk_binding/fltk-widgets.adb @@ -2,6 +2,7 @@ with Interfaces.C; with System; +with FLTK.Widgets.Groups; package body FLTK.Widgets is @@ -50,81 +51,102 @@ package body FLTK.Widgets is + procedure Finalize + (This : in out Widget) is + begin + if This.Parent /= null then + This.Parent.Remove (This); + end if; + end Finalize; + + + + + function Parent + (This : in Widget) + return Group_Cursor is + begin + return Ref : Group_Cursor (Data => This.Parent); + end Parent; + + + + function Get_Box - (W : in Widget'Class) + (This : in Widget) return Box_Kind is begin - return Box_Kind'Val (fl_widget_get_box (W.Void_Ptr)); + return Box_Kind'Val (fl_widget_get_box (This.Void_Ptr)); end Get_Box; procedure Set_Box - (W : in out Widget'Class; - B : in Box_Kind) is + (This : in out Widget; + Box : in Box_Kind) is begin - fl_widget_set_box (W.Void_Ptr, Box_Kind'Pos (B)); + fl_widget_set_box (This.Void_Ptr, Box_Kind'Pos (Box)); end Set_Box; function Get_Label_Font - (W : in Widget'Class) + (This : in Widget) return Font_Kind is begin - return Font_Kind'Val (fl_widget_get_label_font (W.Void_Ptr)); + return Font_Kind'Val (fl_widget_get_label_font (This.Void_Ptr)); end Get_Label_Font; procedure Set_Label_Font - (W : in out Widget'Class; - F : in Font_Kind) is + (This : in out Widget; + Font : in Font_Kind) is begin - fl_widget_set_label_font (W.Void_Ptr, Font_Kind'Pos (F)); + fl_widget_set_label_font (This.Void_Ptr, Font_Kind'Pos (Font)); end Set_Label_Font; function Get_Label_Size - (W : in Widget'Class) + (This : in Widget) return Font_Size is begin - return Font_Size (fl_widget_get_label_size (W.Void_Ptr)); + return Font_Size (fl_widget_get_label_size (This.Void_Ptr)); end Get_Label_Size; procedure Set_Label_Size - (W : in out Widget'Class; - S : in Font_Size) is + (This : in out Widget; + Size : in Font_Size) is begin - fl_widget_set_label_size (W.Void_Ptr, Interfaces.C.int (S)); + fl_widget_set_label_size (This.Void_Ptr, Interfaces.C.int (Size)); end Set_Label_Size; function Get_Label_Type - (W : in Widget'Class) + (This : in Widget) return Label_Kind is begin - return Label_Kind'Val (fl_widget_get_label_type (W.Void_Ptr)); + return Label_Kind'Val (fl_widget_get_label_type (This.Void_Ptr)); end Get_Label_Type; procedure Set_Label_Type - (W : in out Widget'Class; - L : in Label_Kind) is + (This : in out Widget; + Label : in Label_Kind) is begin - fl_widget_set_label_type (W.Void_Ptr, Label_Kind'Pos (L)); + fl_widget_set_label_type (This.Void_Ptr, Label_Kind'Pos (Label)); end Set_Label_Type; diff --git a/src/fltk_binding/fltk-widgets.ads b/src/fltk_binding/fltk-widgets.ads index 9c696ed..9910dee 100644 --- a/src/fltk_binding/fltk-widgets.ads +++ b/src/fltk_binding/fltk-widgets.ads @@ -1,72 +1,89 @@ with FLTK.Enums; use FLTK.Enums; +limited with FLTK.Widgets.Groups; package FLTK.Widgets is type Widget is abstract new Wrapper with private; - type Widget_Access is access all Widget; + type Widget_Cursor (Data : access Widget'Class) is limited null record + with Implicit_Dereference => Data; - type Font_Size is new Natural; - Normal_Size : constant Font_Size := 14; + -- 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; + type Font_Size is new Natural; + Normal_Size : constant Font_Size := 14; type Color is new Natural; function Create (X, Y, W, H : in Integer; - Label : in String) + Text : in String) return Widget is abstract; + function Parent + (This : in Widget) + return Group_Cursor; + + function Get_Box - (W : in Widget'Class) + (This : in Widget) return Box_Kind; procedure Set_Box - (W : in out Widget'Class; - B : in Box_Kind); + (This : in out Widget; + Box : in Box_Kind); function Get_Label_Font - (W : in Widget'Class) + (This : in Widget) return Font_Kind; procedure Set_Label_Font - (W : in out Widget'Class; - F : in Font_Kind); + (This : in out Widget; + Font : in Font_Kind); function Get_Label_Size - (W : in Widget'Class) + (This : in Widget) return Font_Size; procedure Set_Label_Size - (W : in out Widget'Class; - S : in Font_Size); + (This : in out Widget; + Size : in Font_Size); function Get_Label_Type - (W : in Widget'Class) + (This : in Widget) return Label_Kind; procedure Set_Label_Type - (W : in out Widget'Class; - L : in Label_Kind); + (This : in out Widget; + Label : in Label_Kind); private - type Widget is abstract new Wrapper with null record; + type Widget is abstract new Wrapper with + record + Parent : access FLTK.Widgets.Groups.Group; + end record; + + + overriding procedure Finalize + (This : in out Widget); end FLTK.Widgets; diff --git a/src/fltk_binding/fltk.ads b/src/fltk_binding/fltk.ads index 51f05c1..c1844a6 100644 --- a/src/fltk_binding/fltk.ads +++ b/src/fltk_binding/fltk.ads @@ -10,8 +10,10 @@ package FLTK is function Run return Integer; - -- ugly implementation thing; never use this - -- just ignore the hand moving behind the curtain here + -- ugly implementation detail, never use this + -- just ignore the hand moving behind the curtain + -- (this is necessary so things like text_buffers and + -- widgets can talk to each other behind the binding) type Wrapper is abstract new Ada.Finalization.Limited_Controlled with private; |