diff options
Diffstat (limited to 'body/fltk-asks.adb')
| -rw-r--r-- | body/fltk-asks.adb | 69 |
1 files changed, 52 insertions, 17 deletions
diff --git a/body/fltk-asks.adb b/body/fltk-asks.adb index 034a674..8d4f900 100644 --- a/body/fltk-asks.adb +++ b/body/fltk-asks.adb @@ -234,9 +234,9 @@ package body FLTK.Asks is - --------------- - -- Cleanup -- - --------------- + ------------------- + -- Destructors -- + ------------------- procedure Finalize (This : in out Dialog_String_Final_Controller) @@ -254,6 +254,21 @@ package body FLTK.Asks is + -------------------- + -- Constructors -- + -------------------- + + -- You can get out of a hole by digging deeper, right? + procedure fl_box_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_box_extra_init, "fl_box_extra_init"); + pragma Inline (fl_box_extra_init); + + + + ----------------------- -- API Subprograms -- ----------------------- @@ -362,13 +377,17 @@ package body FLTK.Asks is (Message, Button1 : in String) return Choice_Result is - Result : Interfaces.C.int := fl_ask_choice + Result : constant Interfaces.C.int := fl_ask_choice (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.Null_Ptr, Interfaces.C.Strings.Null_Ptr); begin return Choice_Result'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Choice; @@ -377,13 +396,17 @@ package body FLTK.Asks is return Choice_Result is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); - Result : Interfaces.C.int := fl_ask_choice + Result : constant Interfaces.C.int := fl_ask_choice (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), Interfaces.C.Strings.Null_Ptr); begin return Choice_Result'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Choice; @@ -393,13 +416,17 @@ package body FLTK.Asks is is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); - Result : Interfaces.C.int := fl_ask_choice + Result : constant Interfaces.C.int := fl_ask_choice (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access)); begin return Choice_Result'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Choice; @@ -407,7 +434,7 @@ package body FLTK.Asks is (Message, Button1 : in String) return Extended_Choice_Result is - Result : Interfaces.C.int := fl_ask_choice_n + Result : constant Interfaces.C.int := fl_ask_choice_n (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.Null_Ptr, @@ -427,7 +454,7 @@ package body FLTK.Asks is return Extended_Choice_Result is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); - Result : Interfaces.C.int := fl_ask_choice_n + Result : constant Interfaces.C.int := fl_ask_choice_n (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), @@ -448,7 +475,7 @@ package body FLTK.Asks is is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); - Result : Interfaces.C.int := fl_ask_choice_n + Result : constant Interfaces.C.int := fl_ask_choice_n (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), @@ -468,7 +495,7 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_input + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_input (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin @@ -493,7 +520,7 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_password + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_password (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin @@ -520,8 +547,8 @@ package body FLTK.Asks is C_R : Interfaces.C.double := Interfaces.C.double (R); C_G : Interfaces.C.double := Interfaces.C.double (G); C_B : Interfaces.C.double := Interfaces.C.double (B); - M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); - Result : Interfaces.C.int := fl_ask_color_chooser + M : constant Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : constant Interfaces.C.int := fl_ask_color_chooser (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin if Result = 1 then @@ -550,8 +577,8 @@ package body FLTK.Asks is C_R : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (R); C_G : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (G); C_B : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (B); - M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); - Result : Interfaces.C.int := fl_ask_color_chooser2 + M : constant Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : constant Interfaces.C.int := fl_ask_color_chooser2 (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin if Result = 1 then @@ -583,7 +610,7 @@ package body FLTK.Asks is Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default), Boolean'Pos (Relative)); @@ -602,7 +629,7 @@ package body FLTK.Asks is Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_file_chooser + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_file_chooser (Interfaces.C.To_C (Message), Interfaces.C.To_C (Filter_Pattern), Interfaces.C.To_C (Default), @@ -685,6 +712,14 @@ begin Wrapper (Icon_Box).Void_Ptr := fl_ask_message_icon; Wrapper (Icon_Box).Needs_Dealloc := False; + fl_box_extra_init + (Storage.To_Integer (Icon_Box'Address), + Interfaces.C.int (Icon_Box.Get_X), + Interfaces.C.int (Icon_Box.Get_Y), + Interfaces.C.int (Icon_Box.Get_W), + Interfaces.C.int (Icon_Box.Get_H), + Interfaces.C.To_C (Icon_Box.Get_Label)); + fl_ask_file_chooser_callback (Storage.To_Integer (File_Chooser_Callback_Hook'Address)); |