Merge branch 'topic/37-stub-ada-version' into 'master'

Test: Bump default Ada version to Ada 2012 in stub helpers

Closes #37

See merge request eng/ide/libadalang-tools!264

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;

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;

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,

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
 

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;

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;

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;

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;

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;

testsuite/tests/test/37-stub-ada-version/test.out

@@ -0,0 +1,2 @@
+pragma Ada_2012;
+pragma Ada_2005;

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

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

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;

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;

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;

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;

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;

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]

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

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