From d2e59934c4f79791b337470e9ef7c34ef66b1b49 Mon Sep 17 00:00:00 2001 From: Gary Dismukes Date: Mon, 7 Dec 2020 01:58:10 -0500 Subject: [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). --- gcc/ada/sem_disp.adb | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) (limited to 'gcc/ada/sem_disp.adb') 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 -- cgit v1.1