[Ada] Move generation of range checks for entry families to expander

Message ID 20200707092736.GA41603@adacore.com
State New
Headers show
Series
  • [Ada] Move generation of range checks for entry families to expander
Related show

Commit Message

Pierre-Marie de Rodat July 7, 2020, 9:27 a.m.
This converts the generation of range checks for entry families to the
separate analysis and generation model: the semantic analyzer sets the
Do_Range_Check flag on the node to be range-checked and then later the
expander generates the actual range check.  This also removes a useless
conditional construct in Resolve_Indexed_Component.

No functional changes.

Tested on x86_64-pc-linux-gnu, committed on trunk

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) <Attribute_Count>: 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.

Patch

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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);