[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).

1 files changed, 58 insertions, 0 deletions

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