[Ada] AI12-0397: Default_Initial_Condition expressions for derived types

gcc/ada/

	* exp_util.adb (Add_Own_DIC): Suppress expansion of a DIC pragma
	when the pragma occurs for an abstract type, since that could
	lead to a call to an abstract function, and such DIC checks can
	never be performed for abstract types in any case.
	* sem_disp.adb (Check_Dispatching_Context): Suppress the check
	for illegal calls to abstract subprograms when the call occurs
	within a Default_Initial_Condition aspect and the call is passed
	the current instance as an actual.
	(Has_Controlling_Current_Instance_Actual): New function to test
	a call to see if it has any actuals given by direct references
	to a current instance of a type
	* sem_res.adb (Resolve_Actuals): Issue an error for a call
	within a DIC aspect to a nonprimitive subprogram with an actual
	given by the name of the DIC type's current instance (which will
	show up as a reference to the formal parameter of a DIC
	procedure).

3 files changed, 105 insertions, 6 deletions

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index cf4059a..36af89b 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -1854,12 +1854,18 @@ package body Exp_Util is
          end if;
 
          --  Once the DIC assertion expression is fully processed, add a check
-         --  to the statements of the DIC procedure.
-
-         Add_DIC_Check
-           (DIC_Prag => DIC_Prag,
-            DIC_Expr => Expr,
-            Stmts    => Stmts);
+         --  to the statements of the DIC procedure (unless the type is an
+         --  abstract type, in which case we don't want the possibility of
+         --  generating a call to an abstract function of the type; such DIC
+         --  procedures can never be called in any case, so not generating the
+         --  check at all is OK).
+
+         if not Is_Abstract_Type (DIC_Typ) then
+            Add_DIC_Check
+              (DIC_Prag => DIC_Prag,
+               DIC_Expr => Expr,
+               Stmts    => Stmts);
+         end if;
       end Add_Own_DIC;
 
       ---------------------
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 36efa42..360e73c 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -517,6 +517,12 @@ package body Sem_Disp is
          procedure Abstract_Context_Error;
          --  Error for abstract call dispatching on result is not dispatching
 
+         function Has_Controlling_Current_Instance_Actual_In_DIC
+           (Call : Node_Id) return Boolean;
+         --  Return True if the subprogram call Call has a controlling actual
+         --  given directly by a current instance referenced within a DIC
+         --  aspect.
+
          ----------------------------
          -- Abstract_Context_Error --
          ----------------------------
@@ -536,6 +542,44 @@ package body Sem_Disp is
             end if;
          end Abstract_Context_Error;
 
+         ----------------------------------------
+         -- Has_Current_Instance_Actual_In_DIC --
+         ----------------------------------------
+
+         function Has_Controlling_Current_Instance_Actual_In_DIC
+           (Call : Node_Id) return Boolean
+         is
+            A : Node_Id;
+            F : Entity_Id;
+         begin
+            F := First_Formal (Subp_Entity);
+            A := First_Actual (Call);
+
+            while Present (F) loop
+
+               --  Return True if the actual denotes a current instance (which
+               --  will be represented by an in-mode formal of the enclosing
+               --  DIC_Procedure) passed to a controlling formal. We don't have
+               --  to worry about controlling access formals here, because its
+               --  illegal to apply Access (etc.) attributes to a current
+               --  instance within an aspect (by AI12-0068).
+
+               if Is_Controlling_Formal (F)
+                 and then Nkind (A) = N_Identifier
+                 and then Ekind (Entity (A)) = E_In_Parameter
+                 and then Is_Subprogram (Scope (Entity (A)))
+                 and then Is_DIC_Procedure (Scope (Entity (A)))
+               then
+                  return True;
+               end if;
+
+               Next_Formal (F);
+               Next_Actual (A);
+            end loop;
+
+            return False;
+         end Has_Controlling_Current_Instance_Actual_In_DIC;
+
          --  Local variables
 
          Scop : constant Entity_Id := Current_Scope_No_Loops;
@@ -591,6 +635,20 @@ package body Sem_Disp is
             then
                null;
 
+            --  Similarly to the dispensation for postconditions, a call to
+            --  an abstract function within a Default_Initial_Condition aspect
+            --  can be legal when passed a current instance of the type. Such
+            --  a call will be effectively mapped to a call to a primitive of
+            --  a descendant type (see AI12-0397, as well as AI12-0170), so
+            --  doesn't need to be dispatching. We test for being within a DIC
+            --  procedure, since that's where the call will be analyzed.
+
+            elsif Is_Subprogram (Scop)
+              and then Is_DIC_Procedure (Scop)
+              and then Has_Controlling_Current_Instance_Actual_In_DIC (Call)
+            then
+               null;
+
             elsif Ekind (Current_Scope) = E_Function
               and then Nkind (Unit_Declaration_Node (Scop)) =
                          N_Generic_Subprogram_Declaration
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 39907ae..fb551d3 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5036,6 +5036,41 @@ package body Sem_Res is
                end if;
             end if;
 
+            --  (AI12-0397): The target of a subprogram call that occurs within
+            --  the expression of an Default_Initial_Condition aspect and has
+            --  an actual that is the current instance of the type must be
+            --  either a primitive of the type or a class-wide subprogram,
+            --  because the type of the current instance in such an aspect is
+            --  considered to be a notional formal derived type whose only
+            --  operations correspond to the primitives of the enclosing type.
+            --  Nonprimitives can be called, but the current instance must be
+            --  converted rather than passed directly. Note that a current
+            --  instance of a type with DIC will occur as a reference to an
+            --  in-mode formal of an enclosing DIC procedure or partial DIC
+            --  procedure. (It seems that this check should perhaps also apply
+            --  to calls within Type_Invariant'Class, but not Type_Invariant,
+            --  aspects???)
+
+            if Nkind (A) = N_Identifier
+              and then Ekind (Entity (A)) = E_In_Parameter
+
+              and then Is_Subprogram (Scope (Entity (A)))
+              and then Is_DIC_Procedure (Scope (Entity (A)))
+
+              --  We check Comes_From_Source to exclude inherited primitives
+              --  from being flagged, because such subprograms turn out to not
+              --  always have the Is_Primitive flag set. ???
+
+              and then Comes_From_Source (Nam)
+
+              and then not Is_Primitive (Nam)
+              and then not Is_Class_Wide_Type (Etype (F))
+            then
+               Error_Msg_NE
+                 ("call to nonprimitive & with current instance not allowed " &
+                  "for aspect", A, Nam);
+            end if;
+
             Next_Actual (A);
 
          --  Case where actual is not present