[Ada] Support for new aspect Subprogram_Variant on recursive subprograms

gcc/ada/

	* aspects.ads: Introduce Subprogram_Variant aspect with the
	following properties: GNAT-specific, with mandatory expression,
	not a representation aspect, never delayed.
	* contracts.adb (Expand_Subprogram_Contract): Mention new aspect
	in the comment.
	(Add_Contract_Item): Support addition of pragma
	Subprogram_Variant to N_Contract node.
	(Analyze_Entry_Or_Subprogram_Contract): Mention new aspect in
	the comment; add pragma Subprogram_Variant to N_Contract node.
	(Build_Postconditions_Procedure): Adapt call to
	Insert_Before_First_Source_Declaration, which is now reused in
	expansion of new aspect.
	(Process_Contract_Cases_For): Also process Subprogram_Variant,
	which is stored in N_Contract node together with Contract_Cases.
	* contracts.ads (Analyze_Entry_Or_Subprogram_Contract): Mention
	new aspect in the comment.
	(Analyze_Entry_Or_Subprogram_Body_Contract): Likewise.
	* einfo.adb (Get_Pragma): Support retrieval of new pragma.
	* einfo.ads (Get_Pragma): Likewise.
	* exp_ch6.adb (Check_Subprogram_Variant): New routine for
	emitting call to check Subprogram_Variant expressions at run
	time.
	(Expand_Call_Helper): Check Subprogram_Variant expressions at
	recursive calls.
	* exp_prag.adb (Make_Op): Moved from expansion of pragma
	Loop_Variant to Exp_Util, so it is now reused for expansion of
	pragma Subprogram_Variant.
	(Process_Variant): Adapt call to Make_Op after moving it to
	Exp_Util.
	(Expand_Pragma_Subprogram_Variant): New routine.
	* exp_prag.ads (Expand_Pragma_Subprogram_Variant): Likewise.
	* exp_util.adb (Make_Variant_Comparison): Moved from Exp_Prag
	(see above).
	* exp_util.ads (Make_Variant_Comparison): Likewise.
	* inline.adb (Remove_Aspects_And_Pragmas): Handle aspect/pragma
	Subprogram_Variant just like similar contracts.
	* par-prag.adb (Prag): Likewise.
	* sem.adb (Insert_Before_First_Source_Declaration): Moved from
	Contracts (see above).
	* sem.ads (Insert_Before_First_Source_Declaration): Likewise.
	* sem_ch12.adb: Mention new aspect in the comment about
	"Implementation of Generic Contracts", just like similar aspects
	are mentioned there.
	* sem_ch13.adb (Insert_Pragma): Mention new aspect in the
	comment, because this routine is now used for Subprogram_Variant
	just like for other similar aspects.
	(Analyze_Aspect_Specifications): Mention new aspect in comments;
	it is handled just like aspect Contract_Cases.
	(Check_Aspect_At_Freeze_Point): Do not expect aspect
	Subprogram_Variant just like we don't expect aspect
	Contract_Cases.
	* sem_prag.adb (Ensure_Aggregate_Form): Now also used for pragma
	Subprogram_Variant, so update comment.
	(Analyze_Pragma): Add initial checks for pragma
	Subprogram_Variant.
	(Analyze_Subprogram_Variant_In_Decl_Part): New routine with
	secondary checks on the new pragma.
	(Sig_Flags): Handle references within pragma Subprogram_Variant
	expression just like references in similar pragma
	Contract_Cases.
	(Is_Valid_Assertion_Kind): Handle Subprogram_Variant just like
	other similar contracts.
	* sem_prag.ads (Analyze_Subprogram_Variant_In_Decl_Part): New
	routine.
	* sem_res.adb (Same_Or_Aliased_Subprograms): Moved to Sem_Util,
	so it can be reused for detection of recursive calls where
	Subprogram_Variant needs to be verified.
	* sem_util.adb (Is_Subprogram_Contract_Annotation): Handle new
	Subprogram_Variant annotation just like other similar
	annotations.
	(Same_Or_Aliased_Subprograms): Moved from Sem_Res (see above).
	* sem_util.ads (Is_Subprogram_Contract_Annotation): Mention new
	aspect in the comment.
	(Same_Or_Aliased_Subprograms): Moved from Sem_Res (see above).
	* sinfo.ads (N_Contract): Document handling of
	Subprogram_Variant.
	* snames.ads-tmpl: Add name for the internally generated
	procedure with checks for Subprogram_Variant expression, name
	for the new aspect and new pragma corresponding to aspect
	Subprogram_Variant.

1 files changed, 28 insertions, 59 deletions

diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 666a57f..e633e19 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -69,8 +69,8 @@ package body Contracts is
    procedure Expand_Subprogram_Contract (Body_Id : Entity_Id);
    --  Expand the contracts of a subprogram body and its correspoding spec (if
    --  any). This routine processes all [refined] pre- and postconditions as
-   --  well as Contract_Cases, invariants and predicates. Body_Id denotes the
-   --  entity of the subprogram body.
+   --  well as Contract_Cases, Subprogram_Variant, invariants and predicates.
+   --  Body_Id denotes the entity of the subprogram body.
 
    -----------------------
    -- Add_Contract_Item --
@@ -200,7 +200,10 @@ package body Contracts is
          then
             Add_Classification;
 
-         elsif Prag_Nam in Name_Contract_Cases | Name_Test_Case then
+         elsif Prag_Nam in Name_Contract_Cases
+                         | Name_Subprogram_Variant
+                         | Name_Test_Case
+         then
             Add_Contract_Test_Case;
 
          elsif Prag_Nam in Name_Postcondition | Name_Precondition then
@@ -550,8 +553,8 @@ package body Contracts is
       end if;
 
       --  Deal with preconditions, [refined] postconditions, Contract_Cases,
-      --  invariants and predicates associated with body and its spec. Do not
-      --  expand the contract of subprogram body stubs.
+      --  Subprogram_Variant, invariants and predicates associated with body
+      --  and its spec. Do not expand the contract of subprogram body stubs.
 
       if Nkind (Body_Decl) = N_Subprogram_Body then
          Expand_Subprogram_Contract (Body_Id);
@@ -686,6 +689,10 @@ package body Contracts is
                else
                   Analyze_Contract_Cases_In_Decl_Part (Prag, Freeze_Id);
                end if;
+
+            elsif Prag_Nam = Name_Subprogram_Variant then
+               Analyze_Subprogram_Variant_In_Decl_Part (Prag);
+
             else
                pragma Assert (Prag_Nam = Name_Test_Case);
                Analyze_Test_Case_In_Decl_Part (Prag);
@@ -1941,49 +1948,6 @@ package body Contracts is
          Stmts   : List_Id;
          Result  : Entity_Id)
       is
-         procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id);
-         --  Insert node Stmt before the first source declaration of the
-         --  related subprogram's body. If no such declaration exists, Stmt
-         --  becomes the last declaration.
-
-         --------------------------------------------
-         -- Insert_Before_First_Source_Declaration --
-         --------------------------------------------
-
-         procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id) is
-            Decls : constant List_Id := Declarations (Body_Decl);
-            Decl  : Node_Id;
-
-         begin
-            --  Inspect the declarations of the related subprogram body looking
-            --  for the first source declaration.
-
-            if Present (Decls) then
-               Decl := First (Decls);
-               while Present (Decl) loop
-                  if Comes_From_Source (Decl) then
-                     Insert_Before (Decl, Stmt);
-                     return;
-                  end if;
-
-                  Next (Decl);
-               end loop;
-
-               --  If we get there, then the subprogram body lacks any source
-               --  declarations. The body of _Postconditions now acts as the
-               --  last declaration.
-
-               Append (Stmt, Decls);
-
-            --  Ensure that the body has a declaration list
-
-            else
-               Set_Declarations (Body_Decl, New_List (Stmt));
-            end if;
-         end Insert_Before_First_Source_Declaration;
-
-         --  Local variables
-
          Loc       : constant Source_Ptr := Sloc (Body_Decl);
          Params    : List_Id := No_List;
          Proc_Bod  : Node_Id;
@@ -1991,8 +1955,6 @@ package body Contracts is
          Proc_Id   : Entity_Id;
          Proc_Spec : Node_Id;
 
-      --  Start of processing for Build_Postconditions_Procedure
-
       begin
          --  Nothing to do if there are no actions to check on exit
 
@@ -2051,7 +2013,8 @@ package body Contracts is
          --  order reference. The body of _Postconditions must be placed after
          --  the declaration of Temp to preserve correct visibility.
 
-         Insert_Before_First_Source_Declaration (Proc_Decl);
+         Insert_Before_First_Source_Declaration
+           (Proc_Decl, Declarations (Body_Decl));
          Analyze (Proc_Decl);
 
          --  Set an explicit End_Label to override the sloc of the implicit
@@ -2092,14 +2055,20 @@ package body Contracts is
             if Present (Items) then
                Prag := Contract_Test_Cases (Items);
                while Present (Prag) loop
-                  if Pragma_Name (Prag) = Name_Contract_Cases
-                    and then Is_Checked (Prag)
-                  then
-                     Expand_Pragma_Contract_Cases
-                       (CCs     => Prag,
-                        Subp_Id => Subp_Id,
-                        Decls   => Declarations (Body_Decl),
-                        Stmts   => Stmts);
+                  if Is_Checked (Prag) then
+                     if Pragma_Name (Prag) = Name_Contract_Cases then
+                        Expand_Pragma_Contract_Cases
+                          (CCs     => Prag,
+                           Subp_Id => Subp_Id,
+                           Decls   => Declarations (Body_Decl),
+                           Stmts   => Stmts);
+
+                     elsif Pragma_Name (Prag) = Name_Subprogram_Variant then
+                        Expand_Pragma_Subprogram_Variant
+                          (Prag       => Prag,
+                           Subp_Id    => Subp_Id,
+                           Body_Decls => Declarations (Body_Decl));
+                     end if;
                   end if;
 
                   Prag := Next_Pragma (Prag);