diff options
Diffstat (limited to 'gcc/ada/sem_disp.adb')
| -rw-r--r-- | gcc/ada/sem_disp.adb | 207 |
1 files changed, 146 insertions, 61 deletions
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 36efa42..064e2b5 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,37 +23,40 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Debug; use Debug; -with Elists; use Elists; -with Einfo; use Einfo; -with Exp_Disp; use Exp_Disp; -with Exp_Util; use Exp_Util; -with Exp_Ch7; use Exp_Ch7; -with Exp_Tss; use Exp_Tss; -with Errout; use Errout; -with Lib.Xref; use Lib.Xref; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Output; use Output; -with Restrict; use Restrict; -with Rident; use Rident; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Eval; use Sem_Eval; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Snames; use Snames; -with Sinfo; use Sinfo; -with Tbuild; use Tbuild; -with Uintp; use Uintp; -with Warnsw; use Warnsw; +with Aspects; use Aspects; +with Atree; use Atree; +with Debug; use Debug; +with Elists; use Elists; +with Einfo; use Einfo; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; +with Exp_Disp; use Exp_Disp; +with Exp_Util; use Exp_Util; +with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; +with Errout; use Errout; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Snames; use Snames; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Warnsw; use Warnsw; package body Sem_Disp is @@ -517,6 +520,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 +545,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; @@ -565,29 +612,46 @@ package body Sem_Disp is Set_Entity (Name (N), Alias (Subp)); return; - -- An obscure special case: a null procedure may have a class- - -- wide pre/postcondition that includes a call to an abstract - -- subp. Calls within the expression may not have been rewritten - -- as dispatching calls yet, because the null body appears in - -- the current declarative part. The expression will be properly - -- rewritten/reanalyzed when the postcondition procedure is built. - - -- Similarly, if this is a pre/postcondition for an abstract - -- subprogram, it may call another abstract function which is - -- a primitive of an abstract type. The call is non-dispatching - -- but will be legal in overridings of the operation. However, - -- if the call is tag-indeterminate we want to continue with - -- with the error checking below, as this case is illegal even - -- for abstract subprograms (see AI12-0170). - - elsif (Is_Subprogram (Scop) - or else Chars (Scop) = Name_Postcondition) + -- If this is a pre/postcondition for an abstract subprogram, + -- it may call another abstract function that is a primitive + -- of an abstract type. The call is nondispatching but will be + -- legal in overridings of the operation. However, if the call + -- is tag-indeterminate we want to continue with with the error + -- checking below, as this case is illegal even for abstract + -- subprograms (see AI12-0170). + + -- Similarly, as per AI12-0412, a nonabstract subprogram may + -- have a class-wide pre/postcondition that includes a call to + -- an abstract primitive of the subprogram's controlling type. + -- Certain operations (nondispatching calls, 'Access, use as + -- a generic actual) applied to such a nonabstract subprogram + -- are illegal in the case where the type is abstract (see + -- RM 6.1.1(18.2/5)). + + elsif Is_Subprogram (Scop) + and then not Is_Tag_Indeterminate (N) + and then In_Pre_Post_Condition (Call, Class_Wide_Only => True) + + -- The tagged type associated with the called subprogram must be + -- the same as that of the subprogram with a class-wide aspect. + + and then Is_Dispatching_Operation (Scop) and then - ((Is_Abstract_Subprogram (Scop) - and then not Is_Tag_Indeterminate (N)) - or else - (Nkind (Parent (Scop)) = N_Procedure_Specification - and then Null_Present (Parent (Scop)))) + Find_Dispatching_Type (Subp) = Find_Dispatching_Type (Scop) + 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; @@ -602,7 +666,7 @@ package body Sem_Disp is -- provides a tag to make the call dispatching. This requires -- the call to be the actual in an enclosing call, and that -- actual must be controlling. If the call is an operand of - -- equality, the other operand must not ve abstract. + -- equality, the other operand must not be abstract. if not Is_Tagged_Type (Typ) and then not @@ -909,7 +973,6 @@ package body Sem_Disp is end loop; Check_Dispatching_Context (N); - return; elsif Nkind (Parent (N)) in N_Subexpr then Check_Dispatching_Context (N); @@ -924,6 +987,23 @@ package body Sem_Disp is return; end if; + -- If this is a nondispatching call to a nonabstract subprogram + -- and the subprogram has any Pre'Class or Post'Class aspects with + -- nonstatic values, then report an error. This is specified by + -- RM 6.1.1(18.2/5) (by AI12-0412). + + if No (Control) + and then not Is_Abstract_Subprogram (Subp_Entity) + and then + Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Subp_Entity) + then + Error_Msg_N + ("nondispatching call to nonabstract subprogram of " + & "abstract type with nonstatic class-wide " + & "pre/postconditions", + N); + end if; + else -- If dispatching on result, the enclosing call, if any, will -- determine the controlling argument. Otherwise this is the @@ -1147,7 +1227,7 @@ package body Sem_Disp is -- primitives. -- 3. Subprograms associated with stream attributes (built by - -- New_Stream_Subprogram) + -- New_Stream_Subprogram) or with the Put_Image attribute. -- 4. Wrappers built for inherited operations with inherited class- -- wide conditions, where the conditions include calls to other @@ -1176,8 +1256,11 @@ package body Sem_Disp is or else Get_TSS_Name (Subp) = TSS_Stream_Read or else Get_TSS_Name (Subp) = TSS_Stream_Write + or else Get_TSS_Name (Subp) = TSS_Put_Image - or else Present (Contract (Overridden_Operation (Subp))) + or else + (Is_Wrapper (Subp) + and then Present (LSP_Subprogram (Subp))) or else GNATprove_Mode); @@ -2137,6 +2220,8 @@ package body Sem_Disp is while Present (Elmt) loop if Node (Elmt) = Orig_Prim then Set_Overridden_Operation (S, Prim); + Set_Is_Ada_2022_Only (S, + Is_Ada_2022_Only (Prim)); Set_Alias (Prim, Orig_Prim); return Prim; end if; @@ -2582,8 +2667,7 @@ package body Sem_Disp is procedure Override_Dispatching_Operation (Tagged_Type : Entity_Id; Prev_Op : Entity_Id; - New_Op : Entity_Id; - Is_Wrapper : Boolean := False) + New_Op : Entity_Id) is Elmt : Elmt_Id; Prim : Node_Id; @@ -2660,7 +2744,7 @@ package body Sem_Disp is -- wrappers of controlling functions since (at this stage) -- they are not yet decorated. - if not Is_Wrapper then + if not Is_Wrapper (New_Op) then Check_Subtype_Conformant (New_Op, Prim); Set_Is_Abstract_Subprogram (Prim, @@ -2699,6 +2783,7 @@ package body Sem_Disp is Set_Alias (Prev_Op, New_Op); Set_DTC_Entity (Prev_Op, Empty); Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op)); + Set_Is_Ada_2022_Only (New_Op, Is_Ada_2022_Only (Prev_Op)); end if; end Override_Dispatching_Operation; |