diff --git a/src/test-actions.adb b/src/test-actions.adb index 224b9333..1978db14 100644 --- a/src/test-actions.adb +++ b/src/test-actions.adb @@ -213,6 +213,9 @@ package body Test.Actions is Test.Common.Instrument := Arg (Cmd, Dump_Test_Inputs); + Test.Common.Lang_Version := + Utils.Command_Lines.Common.Ada_Version_Switches.Arg (Cmd); + if Arg (Cmd, Passed_Tests) /= null then if Arg (Cmd, Passed_Tests).all = "hide" then Test.Common.Show_Passed_Tests := False; diff --git a/src/test-common.ads b/src/test-common.ads index a3ad26c6..1af7a818 100755 --- a/src/test-common.ads +++ b/src/test-common.ads @@ -43,6 +43,8 @@ with Langkit_Support.Slocs; use Langkit_Support.Slocs; with TGen.Libgen; +with Utils.Command_Lines.Common; use Utils.Command_Lines.Common; + package Test.Common is package String_Set is new @@ -449,6 +451,10 @@ package Test.Common is Instr_Suffix : constant String := "-gnattest-instr"; -- Suffix for object subdirs containing instrumented sources + + Lang_Version : Ada_Version_Type := Ada_2012; + -- Language version to be inserted in the pragma in stub helper units. + private Need_Lib_Support : Lib_Support_Status := Not_Needed; diff --git a/src/test-stub.adb b/src/test-stub.adb index 63b440d2..057cce90 100755 --- a/src/test-stub.adb +++ b/src/test-stub.adb @@ -51,7 +51,8 @@ with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Characters.Handling; use Ada.Characters.Handling; -with Utils.Command_Lines; use Utils.Command_Lines; +with Utils.Command_Lines; use Utils.Command_Lines; +with Utils.Command_Lines.Common; with Utils.Environment; package body Test.Stub is @@ -142,6 +143,10 @@ package body Test.Stub is -- Analyzes type definition and detects if only the limited view is -- available. If so, Is_Limited and Is_Abstract are not to be applied. + function Is_Anon_Access_To_Subp (Param_Type : Type_Expr) return Boolean; + -- Returns whether Param_Type represents an anonymous access to subprogram + -- type. + function Filter_Private_Parameters (Param_List : Stubbed_Parameter_Lists.List) return Stubbed_Parameter_Lists.List; @@ -282,10 +287,13 @@ package body Test.Stub is -- Puts header of generated stub explaining where user code should be put procedure Put_Import_Section - (Markered_Data : in out Markered_Data_Maps.Map; - Add_Import : Boolean := False; - Add_Pragma_05 : Boolean := False); + (Markered_Data : in out Markered_Data_Maps.Map; + Add_Import : Boolean := False; + Add_Language_Version : Boolean := False); -- Puts or regenerates markered section for with clauses + -- + -- The included version is the one defined through the Ada_Version_Switch + -- argument, if defined, or Ada_2012 otherwise. procedure Put_Lines (MD : Markered_Data_Type; Comment_Out : Boolean); @@ -786,10 +794,11 @@ package body Test.Stub is ------------------------ procedure Put_Import_Section - (Markered_Data : in out Markered_Data_Maps.Map; - Add_Import : Boolean := False; - Add_Pragma_05 : Boolean := False) + (Markered_Data : in out Markered_Data_Maps.Map; + Add_Import : Boolean := False; + Add_Language_Version : Boolean := False) is + use Utils.Command_Lines.Common; ID : constant Markered_Data_Id := (Import_MD, new String'(""), @@ -834,8 +843,16 @@ package body Test.Stub is S_Put (3, "with Ada.Real_Time;"); New_Line_Count; end if; - if Add_Pragma_05 then - S_Put (0, "pragma Ada_2005;"); + if Add_Language_Version then + S_Put + (0, + "pragma " + & (case Test.Common.Lang_Version is + when Ada_83 => "Ada_83", + when Ada_95 => "Ada_95", + when Ada_2005 => "Ada_2005", + when Ada_2012 => "Ada_2012") + & ";"); New_Line_Count; end if; end if; @@ -1975,6 +1992,7 @@ package body Test.Stub is or else Is_Abstract (SP.Type_Elem.As_Type_Expr) or else Is_Limited (SP.Type_Elem.As_Type_Expr) or else Is_Fully_Private (SP.Type_Elem.As_Type_Expr) + or else Is_Anon_Access_To_Subp (SP.Type_Elem.As_Type_Expr) then S_Put ((Level + 1) * Indent_Level, @@ -2768,6 +2786,15 @@ package body Test.Stub is return True; end Is_Only_Limited_Withed; + ---------------------------- + -- Is_Anon_Access_To_Subp -- + ---------------------------- + + function Is_Anon_Access_To_Subp (Param_Type : Type_Expr) return Boolean is + (Param_Type.Kind in Ada_Anonymous_Type + and then Param_Type.As_Anonymous_Type.F_Type_Decl.F_Type_Def.Kind + in Ada_Access_To_Subp_Def); + ------------------------- -- Generate_Entry_Body -- ------------------------- @@ -3255,19 +3282,24 @@ package body Test.Stub is Cur : Stubbed_Parameter_Lists.Cursor; Empty_Case : Boolean := Param_List.Is_Empty; - Abstract_Res_Profile : constant Boolean := + Skip_Res : constant Boolean := not Empty_Case and then not Param_List.Last_Element.Type_Elem.Is_Null and then not Is_Only_Limited_Withed (Param_List.Last_Element.Type_Elem.As_Type_Expr) - and then Is_Abstract (Param_List.Last_Element.Type_Elem.As_Type_Expr); + and then + (Is_Abstract (Param_List.Last_Element.Type_Elem.As_Type_Expr) + or else Is_Anon_Access_To_Subp + (Param_List.Last_Element.Type_Elem.As_Type_Expr)); + -- Do not generate a setter for abstract types, or anonymous access-to- + -- subprogram types. SP : Stubbed_Parameter; Count : Natural; begin Trace (Me, "Generating default setter spec for " & Node.Spec_Name.all); - if Abstract_Res_Profile and then not Empty_Case then + if Skip_Res and then not Empty_Case then -- No need to keep it in the parameters list Param_List.Delete_Last; end if; @@ -3391,12 +3423,17 @@ package body Test.Stub is Cur : Stubbed_Parameter_Lists.Cursor; Empty_Case : Boolean := Param_List.Is_Empty; - Abstract_Res_Profile : constant Boolean := + Skip_Res : constant Boolean := not Empty_Case and then not Param_List.Last_Element.Type_Elem.Is_Null and then not Is_Only_Limited_Withed (Param_List.Last_Element.Type_Elem.As_Type_Expr) - and then Is_Abstract (Param_List.Last_Element.Type_Elem.As_Type_Expr); + and then + (Is_Abstract (Param_List.Last_Element.Type_Elem.As_Type_Expr) + or else Is_Anon_Access_To_Subp + (Param_List.Last_Element.Type_Elem.As_Type_Expr)); + -- Do not generate a setter for abstract types, or anonymous access-to- + -- subprogram types. SP : Stubbed_Parameter; @@ -3405,7 +3442,7 @@ package body Test.Stub is Non_Limited_Parameters : Boolean := False; begin Trace (Me, "Generating default setter body for " & Node.Spec_Name.all); - if Abstract_Res_Profile and then not Empty_Case then + if Skip_Res and then not Empty_Case then -- No need to keep it in the parameters list Param_List.Delete_Last; end if; @@ -3585,7 +3622,7 @@ package body Test.Stub is Create (Tmp_File_Name); Reset_Line_Counter; - Put_Import_Section (Markered_Subp_Data, Add_Pragma_05 => True); + Put_Import_Section (Markered_Subp_Data, Add_Language_Version => True); S_Put (0, diff --git a/testsuite/tests/test/195-repeated-pragmas/test.out b/testsuite/tests/test/195-repeated-pragmas/test.out index 4c06350a..6fef1f9c 100644 --- a/testsuite/tests/test/195-repeated-pragmas/test.out +++ b/testsuite/tests/test/195-repeated-pragmas/test.out @@ -5,7 +5,7 @@ -- -- end read only -pragma Ada_2005; +pragma Ada_2012; -- begin read only -- end read only @@ -33,7 +33,7 @@ end Input.Stub_Data; -- -- end read only -pragma Ada_2005; +pragma Ada_2012; -- begin read only -- end read only diff --git a/testsuite/tests/test/37-stub-ada-version/dep.adb b/testsuite/tests/test/37-stub-ada-version/dep.adb new file mode 100644 index 00000000..88c1a2ec --- /dev/null +++ b/testsuite/tests/test/37-stub-ada-version/dep.adb @@ -0,0 +1,6 @@ +package body Dep is + + function Get_Acc (X : aliased Integer) return Int_Acc is + (X'Unrestricted_Access); + +end Dep; diff --git a/testsuite/tests/test/37-stub-ada-version/dep.ads b/testsuite/tests/test/37-stub-ada-version/dep.ads new file mode 100644 index 00000000..447f1bd2 --- /dev/null +++ b/testsuite/tests/test/37-stub-ada-version/dep.ads @@ -0,0 +1,7 @@ +package Dep is + + type Int_Acc is access all Integer; + + function Get_Acc (X : aliased Integer) return Int_Acc; + +end Dep; diff --git a/testsuite/tests/test/37-stub-ada-version/pkg.adb b/testsuite/tests/test/37-stub-ada-version/pkg.adb new file mode 100644 index 00000000..e7dc6739 --- /dev/null +++ b/testsuite/tests/test/37-stub-ada-version/pkg.adb @@ -0,0 +1,10 @@ +with Dep; + +package body Pkg is + + function Make_Acc (X : aliased Integer) return Dep.Int_Acc is + begin + return Dep.Get_Acc (X); + end Make_Acc; + +end Pkg; diff --git a/testsuite/tests/test/37-stub-ada-version/pkg.ads b/testsuite/tests/test/37-stub-ada-version/pkg.ads new file mode 100644 index 00000000..7aab936a --- /dev/null +++ b/testsuite/tests/test/37-stub-ada-version/pkg.ads @@ -0,0 +1,7 @@ +with Dep; + +package Pkg is + + function Make_Acc (X : aliased Integer) return Dep.Int_Acc; + +end Pkg; diff --git a/testsuite/tests/test/37-stub-ada-version/prj.gpr b/testsuite/tests/test/37-stub-ada-version/prj.gpr new file mode 100644 index 00000000..89412524 --- /dev/null +++ b/testsuite/tests/test/37-stub-ada-version/prj.gpr @@ -0,0 +1,11 @@ +project Prj is + + for Object_Dir use "obj"; + + package Compiler is + + for Default_Switches ("Ada") use ("-gnat12"); + + end Compiler; + +end Prj; diff --git a/testsuite/tests/test/37-stub-ada-version/test.out b/testsuite/tests/test/37-stub-ada-version/test.out new file mode 100644 index 00000000..ba69f358 --- /dev/null +++ b/testsuite/tests/test/37-stub-ada-version/test.out @@ -0,0 +1,2 @@ +pragma Ada_2012; +pragma Ada_2005; diff --git a/testsuite/tests/test/37-stub-ada-version/test.sh b/testsuite/tests/test/37-stub-ada-version/test.sh new file mode 100644 index 00000000..c2beeb3d --- /dev/null +++ b/testsuite/tests/test/37-stub-ada-version/test.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +gnattest -P prj.gpr --stub -q --stubs-dir=./stub_default +gprbuild -P obj/gnattest_stub/harness/test_drivers.gpr -q + +# Check we have Ada_2012 by default +grep "pragma Ada_2012;" ./obj/stub_default/Prj/dep-stub_data.ads + +# Same thing, but with Ada_2005 +gnattest -P prj.gpr --stub -q --stubs-dir=./stub_05 -gnat05 +gprbuild -P obj/gnattest_stub/harness/test_drivers.gpr -q + +grep "pragma Ada_2005;" ./obj/stub_05/Prj/dep-stub_data.ads diff --git a/testsuite/tests/test/37-stub-ada-version/test.yaml b/testsuite/tests/test/37-stub-ada-version/test.yaml new file mode 100644 index 00000000..2f3a961b --- /dev/null +++ b/testsuite/tests/test/37-stub-ada-version/test.yaml @@ -0,0 +1,6 @@ +description: + Check that the stubs generated by gnattest are compatible with Ada 2012. + This used not to be the case because gnattest added a pragma Ada_2005 in + some of the stub data units. + +driver: shell_script diff --git a/testsuite/tests/test/37-stub-anon-subp-acc/dep.adb b/testsuite/tests/test/37-stub-anon-subp-acc/dep.adb new file mode 100644 index 00000000..a67068ab --- /dev/null +++ b/testsuite/tests/test/37-stub-anon-subp-acc/dep.adb @@ -0,0 +1,12 @@ +package body Dep is + + function Get_CB return access function (X : aliased Integer) return Int_Acc + is + begin + return Get_Acc'Unrestricted_Access; + end Get_CB; + + function Get_Acc (X : aliased Integer) return Int_Acc is + (X'Unrestricted_Access); + +end Dep; diff --git a/testsuite/tests/test/37-stub-anon-subp-acc/dep.ads b/testsuite/tests/test/37-stub-anon-subp-acc/dep.ads new file mode 100644 index 00000000..d46a438b --- /dev/null +++ b/testsuite/tests/test/37-stub-anon-subp-acc/dep.ads @@ -0,0 +1,9 @@ +package Dep is + + type Int_Acc is access all Integer; + + function Get_Acc (X : aliased Integer) return Int_Acc; + + function Get_CB return access function (X : aliased Integer) return Int_Acc; + +end Dep; diff --git a/testsuite/tests/test/37-stub-anon-subp-acc/pkg.adb b/testsuite/tests/test/37-stub-anon-subp-acc/pkg.adb new file mode 100644 index 00000000..d4fb8e8c --- /dev/null +++ b/testsuite/tests/test/37-stub-anon-subp-acc/pkg.adb @@ -0,0 +1,12 @@ +with Dep; + +package body Pkg is + + function Make_Acc (X : aliased Integer) return Dep.Int_Acc is + CB : access function (X : aliased Integer) return Dep.Int_Acc := + Dep.Get_CB; + begin + return CB (X); + end Make_Acc; + +end Pkg; diff --git a/testsuite/tests/test/37-stub-anon-subp-acc/pkg.ads b/testsuite/tests/test/37-stub-anon-subp-acc/pkg.ads new file mode 100644 index 00000000..7aab936a --- /dev/null +++ b/testsuite/tests/test/37-stub-anon-subp-acc/pkg.ads @@ -0,0 +1,7 @@ +with Dep; + +package Pkg is + + function Make_Acc (X : aliased Integer) return Dep.Int_Acc; + +end Pkg; diff --git a/testsuite/tests/test/37-stub-anon-subp-acc/prj.gpr b/testsuite/tests/test/37-stub-anon-subp-acc/prj.gpr new file mode 100644 index 00000000..89412524 --- /dev/null +++ b/testsuite/tests/test/37-stub-anon-subp-acc/prj.gpr @@ -0,0 +1,11 @@ +project Prj is + + for Object_Dir use "obj"; + + package Compiler is + + for Default_Switches ("Ada") use ("-gnat12"); + + end Compiler; + +end Prj; diff --git a/testsuite/tests/test/37-stub-anon-subp-acc/test.out b/testsuite/tests/test/37-stub-anon-subp-acc/test.out new file mode 100644 index 00000000..57475089 --- /dev/null +++ b/testsuite/tests/test/37-stub-anon-subp-acc/test.out @@ -0,0 +1 @@ +dep.adb:63:10: warning: Stub for Get_CB is unimplemented, this might affect some tests [enabled by default] diff --git a/testsuite/tests/test/37-stub-anon-subp-acc/test.sh b/testsuite/tests/test/37-stub-anon-subp-acc/test.sh new file mode 100644 index 00000000..ba7f8e47 --- /dev/null +++ b/testsuite/tests/test/37-stub-anon-subp-acc/test.sh @@ -0,0 +1,4 @@ +#!/bin/bash + +gnattest -P prj.gpr --stub -q +gprbuild -P obj/gnattest_stub/harness/test_drivers.gpr -q diff --git a/testsuite/tests/test/37-stub-anon-subp-acc/test.yaml b/testsuite/tests/test/37-stub-anon-subp-acc/test.yaml new file mode 100644 index 00000000..2f3a961b --- /dev/null +++ b/testsuite/tests/test/37-stub-anon-subp-acc/test.yaml @@ -0,0 +1,6 @@ +description: + Check that the stubs generated by gnattest are compatible with Ada 2012. + This used not to be the case because gnattest added a pragma Ada_2005 in + some of the stub data units. + +driver: shell_script