sem_util.adb, [...] (Build_Class_Wide_Clone_Body): Build body of subprogram that has a class-wide condition that contains calls to...

2017-04-27  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb, sem_util.ads (Build_Class_Wide_Clone_Body):
	Build body of subprogram that has a class-wide condition that
	contains calls to other primitives.
	(Build_Class_Wide_Clone_Call); Build a call to the common
	class-wide clone of a subprogram with classwide conditions. The
	body of the subprogram becomes a wrapper for a call to the
	clone. The inherited operation becomes a similar wrapper to which
	modified conditions apply, and the call to the clone includes
	the proper conversion in a call the parent operation.
	(Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id): For a
	subprogram that has a classwide condition that contains calls to
	other primitives, build an internal subprogram that is invoked
	through a type-specific wrapper for all inherited subprograms
	that may have a modified condition.
	* sem_prag.adb (Check_References): If subprogram has a classwide
	condition, create entity for corresponding clone, to be invoked
	through wrapper subprograns.
	(Analyze_Pre_Post_Condition_In_Decl_Part): Do not emit error
	message about placement if pragma isi internally generated.
	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): If subprogram has
	a classwide clone, build body of clone as copy of original body,
	and rewrite original body as a wrapper as a wrapper for a call to
	the clone, so that it incorporates the original pre/postconditions
	of the subprogram.
	* freeze.adb (Check_Inherited_Conditions): For an inherited
	subprogram that inherits a classwide condition, build spec and
	body of corresponding wrapper so that call to inherited operation
	gets the modified conditions.
	* contracts.adb (Analyze_Contracts): If analysis of classwide
	condition has created a clone for a primitive operation, analyze
	declaration of clone.

From-SVN: r247313

7 files changed, 324 insertions, 69 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index cfcf449..354b51a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,37 @@
+2017-04-27  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_util.adb, sem_util.ads (Build_Class_Wide_Clone_Body):
+	Build body of subprogram that has a class-wide condition that
+	contains calls to other primitives.
+	(Build_Class_Wide_Clone_Call); Build a call to the common
+	class-wide clone of a subprogram with classwide conditions. The
+	body of the subprogram becomes a wrapper for a call to the
+	clone. The inherited operation becomes a similar wrapper to which
+	modified conditions apply, and the call to the clone includes
+	the proper conversion in a call the parent operation.
+	(Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id): For a
+	subprogram that has a classwide condition that contains calls to
+	other primitives, build an internal subprogram that is invoked
+	through a type-specific wrapper for all inherited subprograms
+	that may have a modified condition.
+	* sem_prag.adb (Check_References): If subprogram has a classwide
+	condition, create entity for corresponding clone, to be invoked
+	through wrapper subprograns.
+	(Analyze_Pre_Post_Condition_In_Decl_Part): Do not emit error
+	message about placement if pragma isi internally generated.
+	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): If subprogram has
+	a classwide clone, build body of clone as copy of original body,
+	and rewrite original body as a wrapper as a wrapper for a call to
+	the clone, so that it incorporates the original pre/postconditions
+	of the subprogram.
+	* freeze.adb (Check_Inherited_Conditions): For an inherited
+	subprogram that inherits a classwide condition, build spec and
+	body of corresponding wrapper so that call to inherited operation
+	gets the modified conditions.
+	* contracts.adb (Analyze_Contracts): If analysis of classwide
+	condition has created a clone for a primitive operation, analyze
+	declaration of clone.
+
 2017-04-27  Steve Baird  <baird@adacore.com>
 
 	* exp_util.adb (Build_Allocate_Deallocate_Proc):
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index e4dc59e..ce61fdc 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -384,9 +384,23 @@ package body Contracts is
                             N_Generic_Subprogram_Declaration,
                             N_Subprogram_Declaration)
          then
-            Analyze_Entry_Or_Subprogram_Contract
-              (Subp_Id   => Defining_Entity (Decl),
-               Freeze_Id => Freeze_Id);
+            declare
+               Subp_Id : constant Entity_Id := Defining_Entity (Decl);
+
+            begin
+               Analyze_Entry_Or_Subprogram_Contract (Subp_Id, Freeze_Id);
+
+               --  If analysis of a classwide pre/postcondition indicates
+               --  that a class-wide clone is needed, analyze its declaration
+               --  now.  Its body is created when the body of the original
+               --  operation is analyzed (and rewritten).
+
+               if Is_Subprogram (Subp_Id)
+                 and then Present (Class_Wide_Clone (Subp_Id))
+               then
+                  Analyze (Unit_Declaration_Node (Class_Wide_Clone (Subp_Id)));
+               end if;
+            end;
 
          --  Entry or subprogram bodies
 
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 890a6a7..1c8f9e6 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -55,7 +55,6 @@ with Sem_Ch6;   use Sem_Ch6;
 with Sem_Ch7;   use Sem_Ch7;
 with Sem_Ch8;   use Sem_Ch8;
 with Sem_Ch13;  use Sem_Ch13;
-with Sem_Disp;  use Sem_Disp;
 with Sem_Eval;  use Sem_Eval;
 with Sem_Mech;  use Sem_Mech;
 with Sem_Prag;  use Sem_Prag;
@@ -1408,7 +1407,6 @@ package body Freeze is
       New_Prag      : Node_Id;
       Op_Node       : Elmt_Id;
       Par_Prim      : Entity_Id;
-      Par_Type      : Entity_Id;
       Prim          : Entity_Id;
 
    begin
@@ -1459,7 +1457,6 @@ package body Freeze is
 
          if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then
             Par_Prim := Alias (Prim);
-            Par_Type := Find_Dispatching_Type (Par_Prim);
 
             --  Analyze the contract items of the parent operation, before
             --  they are rewritten when inherited.
@@ -1505,80 +1502,53 @@ package body Freeze is
             --  one, and whose inherited expression has been updated above.
             --  These expressions are the arguments of pragmas that are part
             --  of the declarations of the wrapper. The wrapper holds a single
-            --  statement that is a call to the parent primitive, where the
+            --  statement that is a call to the class-wide clone, where the
             --  controlling actuals are conversions to the corresponding type
             --  in the parent primitive:
 
-            --    procedure New_Prim (F1 : T1.; ...) is
-            --       pragma Check (Precondition,  Expr);
+            --    procedure New_Prim (F1 : T1; ...);
+            --    procedure New_Prim (F1 : T1; ...) is
+            --       pragma Check (Precondition, Expr);
             --    begin
-            --       Par_Prim (Par_Type (F1) ..);
+            --       Par_Prim_Clone (Par_Type (F1), ...);
             --    end;
 
-            --  If the primitive is a function the statement is a call
+            --  If the primitive is a function the statement is a return
+            --  statement with a call.
 
             declare
-               Loc        : constant Source_Ptr := Sloc (R);
-               Actuals    : List_Id;
-               Call       : Node_Id;
-               Formal     : Entity_Id;
-               New_F_Spec : Node_Id;
-               New_Formal : Entity_Id;
-               New_Proc   : Node_Id;
-               New_Spec   : Node_Id;
+               Loc      : constant Source_Ptr := Sloc (R);
+               Par_R    : constant Node_Id    := Parent (R);
+               New_Body : Node_Id;
+               New_Decl : Node_Id;
+               New_Spec : Node_Id;
 
             begin
-               Actuals    := Empty_List;
-               New_Spec   := Build_Overriding_Spec (Par_Prim, R);
-               Formal     := First_Formal (Par_Prim);
-               New_F_Spec := First (Parameter_Specifications (New_Spec));
+               New_Spec := Build_Overriding_Spec (Par_Prim, R);
+               New_Decl :=
+                 Make_Subprogram_Declaration (Loc,
+                   Specification => New_Spec);
 
-               while Present (Formal) loop
-                  New_Formal := Defining_Identifier (New_F_Spec);
+               --  Insert the declaration and the body of the wrapper after
+               --  type declaration that generates inherited operation. For
+               --  a null procedure, the declaration implies a null body.
 
-                  --  If controlling argument, add conversion
-
-                  if Etype (Formal) = Par_Type then
-                     Append_To (Actuals,
-                       Make_Type_Conversion (Loc,
-                         New_Occurrence_Of (Par_Type, Loc),
-                         New_Occurrence_Of (New_Formal, Loc)));
-
-                  else
-                     Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
-                  end if;
-
-                  Next_Formal (Formal);
-                  Next (New_F_Spec);
-               end loop;
+               if Nkind (New_Spec) = N_Procedure_Specification
+                 and then Null_Present (New_Spec)
+               then
+                  Insert_After_And_Analyze (Par_R, New_Decl);
 
-               if Ekind (Par_Prim) = E_Procedure then
-                  Call :=
-                    Make_Procedure_Call_Statement (Loc,
-                      Name                   =>
-                        New_Occurrence_Of (Par_Prim, Loc),
-                      Parameter_Associations => Actuals);
                else
-                  Call :=
-                    Make_Simple_Return_Statement (Loc,
-                     Expression =>
-                       Make_Function_Call (Loc,
-                         Name                   =>
-                           New_Occurrence_Of (Par_Prim, Loc),
-                         Parameter_Associations => Actuals));
-               end if;
+                  --  Build body as wrapper to a call to the already built
+                  --  class-wide clone.
 
-               New_Proc :=
-                 Make_Subprogram_Body (Loc,
-                   Specification              => New_Spec,
-                   Declarations               => Decls,
-                   Handled_Statement_Sequence =>
-                     Make_Handled_Sequence_Of_Statements (Loc,
-                       Statements => New_List (Call),
-                       End_Label  => Make_Identifier (Loc, Chars (Prim))));
+                  New_Body :=
+                    Build_Class_Wide_Clone_Call
+                      (Loc, Decls, Par_Prim, New_Spec);
 
-               Insert_After (Parent (R), New_Proc);
-               Analyze (New_Proc);
+                  Insert_List_After_And_Analyze
+                    (Par_R, New_List (New_Decl, New_Body));
+               end if;
             end;
 
             Needs_Wrapper := False;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 49bcc9b..32384d9 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -415,7 +415,7 @@ package body Sem_Ch6 is
          Orig_N := Original_Node (N);
          Remove_Aspects (Orig_N);
 
-         --  Propagate any pragmas that apply to the expression function to the
+         --  Propagate any pragmas that apply to expression function to the
          --  proper body when the expression function acts as a completion.
          --  Aspects are automatically transfered because of node rewriting.
 
@@ -3624,6 +3624,25 @@ package body Sem_Ch6 is
          end if;
       end if;
 
+      --  If the subprogram has a class-wide clone, build its body as a copy
+      --  of the original body, and rewrite body of original subprogram as a
+      --  wrapper that calls the clone.
+
+      if Present (Spec_Id)
+        and then Present (Class_Wide_Clone (Spec_Id))
+        and then (Comes_From_Source (N) or else Was_Expression_Function (N))
+      then
+         Build_Class_Wide_Clone_Body (Spec_Id, N);
+
+         --  This is the new body for the existing primitive operation
+
+         Rewrite (N, Build_Class_Wide_Clone_Call
+           (Sloc (N), New_List, Spec_Id, Parent (Spec_Id)));
+         Set_Has_Completion (Spec_Id, False);
+         Analyze (N);
+         return;
+      end if;
+
       --  Place subprogram on scope stack, and make formals visible. If there
       --  is a spec, the visible entity remains that of the spec.
 
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 10ec8d7..f9e710d 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -4424,6 +4424,14 @@ package body Sem_Prag is
                end if;
             end;
 
+         --  A renaming declaration may inherit a generated pragma, its
+         --  placement comes from expansion, not from source.
+
+         elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
+           and then not Comes_From_Source (N)
+         then
+            null;
+
          --  Otherwise the placement is illegal
 
          else
@@ -23949,6 +23957,9 @@ package body Sem_Prag is
      (N         : Node_Id;
       Freeze_Id : Entity_Id := Empty)
    is
+      Subp_Decl : constant Node_Id   := Find_Related_Declaration_Or_Body (N);
+      Spec_Id   : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
+
       Disp_Typ : Entity_Id;
       --  The dispatching type of the subprogram subject to the pre- or
       --  postcondition.
@@ -23995,6 +24006,18 @@ package body Sem_Prag is
                        ("operation in class-wide condition must be primitive "
                         & "of &", Nod, Disp_Typ);
                   end if;
+
+               --  Otherwise we have a call to an overridden primitive, and
+               --  we will create a common class-wide clone for the body of
+               --  original operation and its eventual inherited versions.
+               --  If the original operation dispatches on result it is
+               --  never inherited and there is no need for a clone.
+
+               elsif not Is_Abstract_Subprogram (Spec_Id)
+                 and then No (Class_Wide_Clone (Spec_Id))
+                 and then not Has_Controlling_Result (Spec_Id)
+               then
+                  Build_Class_Wide_Clone_Decl (Spec_Id);
                end if;
             end;
 
@@ -24027,10 +24050,7 @@ package body Sem_Prag is
 
       --  Local variables
 
-      Subp_Decl : constant Node_Id   := Find_Related_Declaration_Or_Body (N);
-      Spec_Id   : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
-      Expr      : constant Node_Id   := Expression (Get_Argument (N, Spec_Id));
-
+      Expr     : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
       Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
       --  Save the Ghost mode to restore on exit
 
@@ -24116,6 +24136,15 @@ package body Sem_Prag is
          End_Scope;
       end if;
 
+      --  If analysis of the condition indicates that a class-wide clone
+      --  has been created, build and analyze its declaration.
+
+      if Is_Subprogram (Spec_Id)
+        and then Present (Class_Wide_Clone (Spec_Id))
+      then
+         Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
+      end if;
+
       --  Currently it is not possible to inline pre/postconditions on a
       --  subprogram subject to pragma Inline_Always.
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index f924b73..e158905 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -1164,6 +1164,141 @@ package body Sem_Util is
       return Empty;
    end Build_Actual_Subtype_Of_Component;
 
+   ---------------------------------
+   -- Build_Class_Wide_Clone_Body --
+   ---------------------------------
+
+   procedure Build_Class_Wide_Clone_Body
+     (Spec_Id : Entity_Id;
+      Bod     : Node_Id)
+   is
+      Loc        : constant Source_Ptr := Sloc (Bod);
+      Clone_Id   : constant Entity_Id  := Class_Wide_Clone (Spec_Id);
+      Clone_Body : Node_Id;
+
+   begin
+      --  The declaration of the class-wide clone was created when the
+      --  corresponding class-wide condition was analyzed.
+
+      Clone_Body :=
+        Make_Subprogram_Body (Loc,
+          Specification              =>
+            Copy_Subprogram_Spec (Parent (Clone_Id)),
+          Declarations               => Declarations (Bod),
+          Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
+
+      --  The new operation is internal and overriding indicators do not apply
+      --  (the original primitive may have carried one).
+
+      Set_Must_Override (Specification (Clone_Body), False);
+      Insert_Before (Bod, Clone_Body);
+      Analyze (Clone_Body);
+   end Build_Class_Wide_Clone_Body;
+
+   ---------------------------------
+   -- Build_Class_Wide_Clone_Call --
+   ---------------------------------
+
+   function Build_Class_Wide_Clone_Call
+     (Loc     : Source_Ptr;
+      Decls   : List_Id;
+      Spec_Id : Entity_Id;
+      Spec    : Node_Id) return Node_Id
+   is
+      Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
+      Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
+
+      Actuals    : List_Id;
+      Call       : Node_Id;
+      Formal     : Entity_Id;
+      New_Body   : Node_Id;
+      New_F_Spec : Entity_Id;
+      New_Formal : Entity_Id;
+
+   begin
+      Actuals    := Empty_List;
+      Formal     := First_Formal (Spec_Id);
+      New_F_Spec := First (Parameter_Specifications (Spec));
+
+      --  Build parameter association for call to class-wide clone.
+
+      while Present (Formal) loop
+         New_Formal := Defining_Identifier (New_F_Spec);
+
+         --  If controlling argument and operation is inherited, add conversion
+         --  to parent type for the call.
+
+         if Etype (Formal) = Par_Type
+           and then not Is_Empty_List (Decls)
+         then
+            Append_To (Actuals,
+              Make_Type_Conversion (Loc,
+                New_Occurrence_Of (Par_Type, Loc),
+                New_Occurrence_Of (New_Formal, Loc)));
+
+         else
+            Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
+         end if;
+
+         Next_Formal (Formal);
+         Next (New_F_Spec);
+      end loop;
+
+      if Ekind (Spec_Id) = E_Procedure then
+         Call :=
+           Make_Procedure_Call_Statement (Loc,
+             Name                   => New_Occurrence_Of (Clone_Id, Loc),
+             Parameter_Associations => Actuals);
+      else
+         Call :=
+           Make_Simple_Return_Statement (Loc,
+            Expression =>
+              Make_Function_Call (Loc,
+                Name                   => New_Occurrence_Of (Clone_Id, Loc),
+                Parameter_Associations => Actuals));
+      end if;
+
+      New_Body :=
+        Make_Subprogram_Body (Loc,
+          Specification              =>
+            Copy_Subprogram_Spec (Spec),
+          Declarations               => Decls,
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc,
+              Statements => New_List (Call),
+              End_Label  => Make_Identifier (Loc, Chars (Spec_Id))));
+
+      return New_Body;
+   end Build_Class_Wide_Clone_Call;
+
+   ---------------------------------
+   -- Build_Class_Wide_Clone_Decl --
+   ---------------------------------
+
+   procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is
+      Loc      : constant Source_Ptr := Sloc (Spec_Id);
+      Clone_Id : constant Entity_Id  :=
+                   Make_Defining_Identifier (Loc,
+                     New_External_Name (Chars (Spec_Id), Suffix => "CL"));
+
+      Decl : Node_Id;
+      Spec : Node_Id;
+
+   begin
+      Spec := Copy_Subprogram_Spec (Parent (Spec_Id));
+      Set_Must_Override      (Spec, False);
+      Set_Must_Not_Override  (Spec, False);
+      Set_Defining_Unit_Name (Spec, Clone_Id);
+
+      Decl := Make_Subprogram_Declaration (Loc, Spec);
+      Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id)));
+
+      --  Link clone to original subprogram, for use when building body and
+      --  wrapper call to inherited operation.
+
+      Set_Class_Wide_Clone (Spec_Id, Clone_Id);
+   end Build_Class_Wide_Clone_Decl;
+
    -----------------------------
    -- Build_Component_Subtype --
    -----------------------------
@@ -5245,6 +5380,14 @@ package body Sem_Util is
 
       Result := New_Copy_Tree (Spec);
 
+      --  However, the spec of a null procedure carries the corresponding null
+      --  statement of the body (created by the parser), and this cannot be
+      --  shared with the new subprogram spec.
+
+      if Nkind (Result) = N_Procedure_Specification then
+         Set_Null_Statement (Result, Empty);
+      end if;
+
       --  Create a new entity for the defining unit name
 
       Def_Id := Defining_Unit_Name (Result);
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index de0e2a8..7463cea 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -209,6 +209,52 @@ package Sem_Util is
    --  Determine whether a selected component has a type that depends on
    --  discriminants, and build actual subtype for it if so.
 
+   --  Handling of inherited primitives whose ancestor have class-wide
+   --  pre/post conditions.
+
+   --  If a primitive operation of a parent type has a class-wide pre/post
+   --  condition that includes calls to other primitives, and that operation
+   --  is inherited by a descendant type that also overrides some of these
+   --  other primitives, the condition that applies to the inherited
+   --  operation has a modified condition in which the overridden primitives
+   --  have been replaced by the primitives of the descendent type. A call
+   --  to the inherited operation cannot be simply a call to the parent
+   --  operation (with an appropriate conversion) as is the case for other
+   --  inherited operations, but must appear with a wrapper subprogram to which
+   --  the modified conditions apply. Furthermore the call to the parent
+   --  operation must not be subject to the original class-wide condition,
+   --  given that modified conditions apply. To implement these semantics
+   --  economically we create a subprogram body (a "class-wide clone") to
+   --  which no pre/postconditions apply, and we create bodies for the
+   --  original and the inherited operation that have their respective
+   --  pre/post conditions and simply call the clone. The following operations
+   --  take care of constructing declaration and body of the clone, and
+   --  building the calls to it within the appropriate wrappers.
+
+   procedure Build_Class_Wide_Clone_Body
+     (Spec_Id  : Entity_Id;
+      Bod      : Node_Id);
+   --  Build body of subprogram that has a class-wide condition that contains
+   --  calls to other primitives. Spec_Id is the Id of the subprogram, and B
+   --  is its source body, which becomes the body of the clone.
+
+   function Build_Class_Wide_Clone_Call
+    (Loc      : Source_Ptr;
+     Decls    : List_Id;
+     Spec_Id  : Entity_Id;
+     Spec     : Node_Id) return Node_Id;
+   --  Build a call to the common class-wide clone of a subprogram with
+   --  class-wide conditions. The body of the subprogram becomes a wrapper
+   --  for a call to the clone. The inherited operation becomes a similar
+   --  wrapper to which modified conditions apply, and the call to the
+   --  clone includes the proper conversion in a call the parent operation.
+
+   procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id);
+   --  For a subprogram that has a clas-wide condition that contains calls
+   --  to other primitives, build an internal subprogram that is invoked
+   --  through a type-specific wrapper for all inherited subprograms that
+   --  may have a modified condition.
+
    function Build_Default_Subtype
      (T : Entity_Id;
       N : Node_Id) return Entity_Id;