From 451187a3e58b4102dd8bb34589fa388a19c090bd Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sun, 10 May 2020 22:02:44 +0200 Subject: [PATCH] [Ada] Move generation of range checks for entry families to expander gcc/ada/ * checks.ads (Expander Routines): Update the description of the Do_Range_Check mechanism. * checks.adb (Selected_Range_Checks): Fix typo. * exp_ch9.adb: Add with and use clause for Checks. (Actual_Index_Expression): Generate a range check if requested. (Entry_Index_Expression): Likewise. * sem_attr.adb (Resolve_Attribute) : Call Apply_Scalar_Range_Check instead of Apply_Range_Check. * sem_ch9.adb (Analyze_Accept_Statement): Likewise. * sem_res.adb (Resolve_Entry): Likewise, after having set the actual index type on the prefix of the indexed component. (Resolve_Indexed_Component): Remove useless conditional construct. --- gcc/ada/checks.adb | 2 +- gcc/ada/checks.ads | 20 ++++++++++---------- gcc/ada/exp_ch9.adb | 16 ++++++++++++++++ gcc/ada/sem_attr.adb | 2 +- gcc/ada/sem_ch9.adb | 6 +++--- gcc/ada/sem_res.adb | 23 +++++++++++++++-------- 6 files changed, 46 insertions(+), 23 deletions(-) diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8ead721d443..6f1bb18d9b5 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -354,7 +354,7 @@ package body Checks is Target_Typ : Entity_Id; Source_Typ : Entity_Id; Warn_Node : Node_Id) return Check_Result; - -- Like Apply_Range_Checks, except it doesn't modify anything, just + -- Like Apply_Range_Check, except it does not modify anything, just -- returns a list of nodes as described in the spec of this package -- for the Range_Check function. diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index c39dc29b2ef..aca1b7eea60 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -674,13 +674,13 @@ package Checks is -- Expander Routines -- ----------------------- - -- Some of the earlier processing for checks results in temporarily setting - -- the Do_Range_Check flag rather than actually generating checks. Probably - -- we could eliminate the Do_Range_Check flag entirely and generate checks - -- earlier, but this is a delicate area and it seems safer to implement the - -- following routines, which are called later on in the expansion process. - -- They check the Do_Range_Check flag and if it is set, generate the actual - -- checks and reset the flag. + -- In most cases, the processing for range checks done by semantic analysis + -- only results in setting the Do_Range_Check flag, rather than actually + -- generating checks. The following routines must be called later on in the + -- expansion process upon seeing the Do_Range_Check flag; they generate the + -- actual checks and reset the flag. The remaining cases where range checks + -- are still directly generated during semantic analysis occur as part of + -- the processing of constraints in (sub)type and object declarations. procedure Generate_Range_Check (N : Node_Id; @@ -694,11 +694,11 @@ package Checks is -- if raised. -- -- Note: if the expander is not active, or if we are in GNATprove mode, - -- then we do not generate explicit range code. Instead we just turn the + -- then we do not generate explicit range checks. Instead we just turn the -- Do_Range_Check flag on, since in these cases that's what we want to see -- in the tree (GNATprove in particular depends on this flag being set). If - -- we generate the actual range check, then we make sure the flag is off, - -- since the code we generate takes complete care of the check. + -- we generate the actual range checks, then we make sure the flag is off + -- afterward, since the code we generate takes complete care of the checks. -- -- Historical note: We used to just pass on the Do_Range_Check flag to the -- back end to generate the check, but now in code-generation mode we never diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 945e1098b3d..70fdf1d1851 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -589,6 +590,14 @@ package body Exp_Ch9 is if Present (Index) then S := Entry_Index_Type (Ent); + -- First make sure the index is in range if requested. The index type + -- has been directly set on the prefix, see Resolve_Entry. + + if Do_Range_Check (Index) then + Generate_Range_Check + (Index, Etype (Prefix (Parent (Index))), CE_Range_Check_Failed); + end if; + Expr := Make_Op_Add (Sloc, Left_Opnd => Num, @@ -5624,6 +5633,13 @@ package body Exp_Ch9 is if Present (Index) then S := Entry_Index_Type (Ent); + -- First make sure the index is in range if requested. The index type + -- is the pristine Entry_Index_Type of the entry. + + if Do_Range_Check (Index) then + Generate_Range_Check (Index, S, CE_Range_Check_Failed); + end if; + Expr := Make_Op_Add (Sloc, Left_Opnd => Num, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index b04b2313bcf..7a2f5953d38 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -11698,7 +11698,7 @@ package body Sem_Attr is Fam : constant Entity_Id := Entity (Prefix (P)); begin Resolve (Indx, Entry_Index_Type (Fam)); - Apply_Range_Check (Indx, Entry_Index_Type (Fam)); + Apply_Scalar_Range_Check (Indx, Entry_Index_Type (Fam)); end; end if; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index f16a48dfb15..4fe3c9b361a 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -915,12 +915,12 @@ package body Sem_Ch9 is end loop; end; - if Ekind (E) = E_Entry_Family then + if Ekind (Entry_Nam) = E_Entry_Family then if No (Index) then Error_Msg_N ("missing entry index in accept for entry family", N); else - Analyze_And_Resolve (Index, Entry_Index_Type (E)); - Apply_Range_Check (Index, Entry_Index_Type (E)); + Analyze_And_Resolve (Index, Entry_Index_Type (Entry_Nam)); + Apply_Scalar_Range_Check (Index, Entry_Index_Type (Entry_Nam)); end if; elsif Present (Index) then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index eabde9176cc..0e6acf7d3a1 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7836,7 +7836,7 @@ package body Sem_Res is -- to the discriminant of the same name in the target task. If the -- entry name is the target of a requeue statement and the entry is -- in the current protected object, the bound to be used is the - -- discriminal of the object (see Apply_Range_Checks for details of + -- discriminal of the object (see Apply_Range_Check for details of -- the transformation). ----------------------------- @@ -8002,6 +8002,17 @@ package body Sem_Res is Nam := Entity (Selector_Name (Prefix (Entry_Name))); Resolve (Prefix (Prefix (Entry_Name))); Resolve_Implicit_Dereference (Prefix (Prefix (Entry_Name))); + + -- We do not resolve the prefix because an Entry_Family has no type, + -- although it has the semantics of an array since it can be indexed. + -- In order to perform the associated range check, we would need to + -- build an array type on the fly and set it on the prefix, but this + -- would be wasteful since only the index type matters. Therefore we + -- attach this index type directly, so that Actual_Index_Expression + -- can pick it up later in order to generate the range check. + + Set_Etype (Prefix (Entry_Name), Actual_Index_Type (Nam)); + Index := First (Expressions (Entry_Name)); Resolve (Index, Entry_Index_Type (Nam)); @@ -8017,7 +8028,7 @@ package body Sem_Res is if Nkind (Index) = N_Parameter_Association then Error_Msg_N ("expect expression for entry index", Index); else - Apply_Range_Check (Index, Actual_Index_Type (Nam)); + Apply_Scalar_Range_Check (Index, Etype (Prefix (Entry_Name))); end if; end if; end Resolve_Entry; @@ -9071,15 +9082,11 @@ package body Sem_Res is Resolve (Expr, Standard_Positive); else - while Present (Index) and Present (Expr) loop + while Present (Index) and then Present (Expr) loop Resolve (Expr, Etype (Index)); Check_Unset_Reference (Expr); - if Is_Scalar_Type (Etype (Expr)) then - Apply_Scalar_Range_Check (Expr, Etype (Index)); - else - Apply_Range_Check (Expr, Get_Actual_Subtype (Index)); - end if; + Apply_Scalar_Range_Check (Expr, Etype (Index)); Next_Index (Index); Next (Expr); -- 2.30.2