[Ada] Small cleanup in Apply_Range_Check implementation

Message ID 20200619082833.GA31243@adacore.com
State New
Headers show
Series
  • [Ada] Small cleanup in Apply_Range_Check implementation
Related show

Commit Message

Pierre-Marie de Rodat June 19, 2020, 8:28 a.m.
The procedure Apply_Range_Check is the only caller of the procedure
Apply_Selected_Range_Checks and always passes Do_Static as False,
which means that the True path is unreachable in the latter, so this
change merges the latter in the former.

Moveover, it adds a new parameter Insert_Node to Apply_Range_Check
with the same semantics as other similar routines, namely that it
gives the insertion point of the checks if not Empty. This makes it
possible for Analyze_Subtype_Declaration to call it in the array
case too (it already calls it in the scalar case) instead of using
the awkward Get_Range_Checks/Insert_Range_Checks interface.

No functional changes.

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

2020-06-19  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* checks.ads (Apply_Static_Length_Check): Move up.
	(Apply_Range_Check): Add parameter Insert_Node.
	* checks.adb (Apply_Selected_Range_Checks): Merge into...
	(Apply_Range_Check): ...this.  Add parameter Insert_Node,
	pass it as Warn_Node to Selected_Range_Checks and use it
	as insertion point for the checks.
	* sem_ch3.adb (Analyze_Subtype_Declaration): Rewrite block
	dealing with the range checks for the subtype indication.
	Use local variable and call Apply_Range_Check in both cases.

Patch

--- gcc/ada/checks.adb
+++ gcc/ada/checks.adb
@@ -240,16 +240,6 @@  package body Checks is
    --  described for the above routines. The Do_Static flag indicates that
    --  only a static check is to be done.
 
-   procedure Apply_Selected_Range_Checks
-     (Expr       : Node_Id;
-      Target_Typ : Entity_Id;
-      Source_Typ : Entity_Id;
-      Do_Static  : Boolean);
-   --  This is the subprogram that does all the work for Apply_Range_Check.
-   --  Expr, Target_Typ and Source_Typ are as described for the above
-   --  routine. The Do_Static flag indicates that only a static check is
-   --  to be done.
-
    procedure Compute_Range_For_Arithmetic_Op
      (Op       : Node_Kind;
       Lo_Left  : Uint;
@@ -364,8 +354,8 @@  package body Checks is
       Target_Typ : Entity_Id;
       Source_Typ : Entity_Id;
       Warn_Node  : Node_Id) return Check_Result;
-   --  Like Apply_Selected_Range_Checks, except it doesn't modify anything,
-   --  just returns a list of nodes as described in the spec of this package
+   --  Like Apply_Range_Checks, except it doesn't modify anything, just
+   --  returns a list of nodes as described in the spec of this package
    --  for the Range_Check function.
 
    ------------------------------
@@ -2910,13 +2900,107 @@  package body Checks is
    -----------------------
 
    procedure Apply_Range_Check
-     (Expr       : Node_Id;
-      Target_Typ : Entity_Id;
-      Source_Typ : Entity_Id := Empty)
+     (Expr        : Node_Id;
+      Target_Typ  : Entity_Id;
+      Source_Typ  : Entity_Id := Empty;
+      Insert_Node : Node_Id   := Empty)
    is
+      Checks_On : constant Boolean :=
+                    not Index_Checks_Suppressed (Target_Typ)
+                      or else
+                    not Range_Checks_Suppressed (Target_Typ);
+
+      Loc : constant Source_Ptr := Sloc (Expr);
+
+      Cond     : Node_Id;
+      R_Cno    : Node_Id;
+      R_Result : Check_Result;
+
    begin
-      Apply_Selected_Range_Checks
-        (Expr, Target_Typ, Source_Typ, Do_Static => False);
+      --  Only apply checks when generating code. In GNATprove mode, we do not
+      --  apply the checks, but we still call Selected_Range_Checks to possibly
+      --  issue errors on SPARK code when a run-time error can be detected at
+      --  compile time.
+
+      if not GNATprove_Mode then
+         if not Expander_Active or not Checks_On then
+            return;
+         end if;
+      end if;
+
+      R_Result :=
+        Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Insert_Node);
+
+      if GNATprove_Mode then
+         return;
+      end if;
+
+      for J in 1 .. 2 loop
+         R_Cno := R_Result (J);
+         exit when No (R_Cno);
+
+         --  The range check requires runtime evaluation. Depending on what its
+         --  triggering condition is, the check may be converted into a compile
+         --  time constraint check.
+
+         if Nkind (R_Cno) = N_Raise_Constraint_Error
+           and then Present (Condition (R_Cno))
+         then
+            Cond := Condition (R_Cno);
+
+            --  Insert the range check before the related context. Note that
+            --  this action analyses the triggering condition.
+
+            if Present (Insert_Node) then
+               Insert_Action (Insert_Node, R_Cno);
+            else
+               Insert_Action (Expr, R_Cno);
+            end if;
+
+            --  The triggering condition evaluates to True, the range check
+            --  can be converted into a compile time constraint check.
+
+            if Is_Entity_Name (Cond)
+              and then Entity (Cond) = Standard_True
+            then
+               --  Since an N_Range is technically not an expression, we have
+               --  to set one of the bounds to C_E and then just flag the
+               --  N_Range. The warning message will point to the lower bound
+               --  and complain about a range, which seems OK.
+
+               if Nkind (Expr) = N_Range then
+                  Apply_Compile_Time_Constraint_Error
+                    (Low_Bound (Expr),
+                     "static range out of bounds of}??",
+                     CE_Range_Check_Failed,
+                     Ent => Target_Typ,
+                     Typ => Target_Typ);
+
+                  Set_Raises_Constraint_Error (Expr);
+
+               else
+                  Apply_Compile_Time_Constraint_Error
+                    (Expr,
+                     "static value out of range of}??",
+                     CE_Range_Check_Failed,
+                     Ent => Target_Typ,
+                     Typ => Target_Typ);
+               end if;
+            end if;
+
+         --  The range check raises Constraint_Error explicitly
+
+         elsif Present (Insert_Node) then
+            R_Cno :=
+              Make_Raise_Constraint_Error (Sloc (Insert_Node),
+                Reason => CE_Range_Check_Failed);
+
+            Insert_Action (Insert_Node, R_Cno);
+
+         else
+            Install_Static_Check (R_Cno, Loc);
+         end if;
+      end loop;
    end Apply_Range_Check;
 
    ------------------------------
@@ -3429,111 +3513,6 @@  package body Checks is
       end loop;
    end Apply_Selected_Length_Checks;
 
-   ---------------------------------
-   -- Apply_Selected_Range_Checks --
-   ---------------------------------
-
-   procedure Apply_Selected_Range_Checks
-     (Expr       : Node_Id;
-      Target_Typ : Entity_Id;
-      Source_Typ : Entity_Id;
-      Do_Static  : Boolean)
-   is
-      Checks_On : constant Boolean :=
-                    not Index_Checks_Suppressed (Target_Typ)
-                      or else
-                    not Range_Checks_Suppressed (Target_Typ);
-
-      Loc : constant Source_Ptr := Sloc (Expr);
-
-      Cond     : Node_Id;
-      R_Cno    : Node_Id;
-      R_Result : Check_Result;
-
-   begin
-      --  Only apply checks when generating code. In GNATprove mode, we do not
-      --  apply the checks, but we still call Selected_Range_Checks to possibly
-      --  issue errors on SPARK code when a run-time error can be detected at
-      --  compile time.
-
-      if not GNATprove_Mode then
-         if not Expander_Active or not Checks_On then
-            return;
-         end if;
-      end if;
-
-      R_Result :=
-        Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Empty);
-
-      if GNATprove_Mode then
-         return;
-      end if;
-
-      for J in 1 .. 2 loop
-         R_Cno := R_Result (J);
-         exit when No (R_Cno);
-
-         --  The range check requires runtime evaluation. Depending on what its
-         --  triggering condition is, the check may be converted into a compile
-         --  time constraint check.
-
-         if Nkind (R_Cno) = N_Raise_Constraint_Error
-           and then Present (Condition (R_Cno))
-         then
-            Cond := Condition (R_Cno);
-
-            --  Insert the range check before the related context. Note that
-            --  this action analyses the triggering condition.
-
-            Insert_Action (Expr, R_Cno);
-
-            --  The triggering condition evaluates to True, the range check
-            --  can be converted into a compile time constraint check.
-
-            if Is_Entity_Name (Cond)
-              and then Entity (Cond) = Standard_True
-            then
-               --  Since an N_Range is technically not an expression, we have
-               --  to set one of the bounds to C_E and then just flag the
-               --  N_Range. The warning message will point to the lower bound
-               --  and complain about a range, which seems OK.
-
-               if Nkind (Expr) = N_Range then
-                  Apply_Compile_Time_Constraint_Error
-                    (Low_Bound (Expr),
-                     "static range out of bounds of}??",
-                     CE_Range_Check_Failed,
-                     Ent => Target_Typ,
-                     Typ => Target_Typ);
-
-                  Set_Raises_Constraint_Error (Expr);
-
-               else
-                  Apply_Compile_Time_Constraint_Error
-                    (Expr,
-                     "static value out of range of}??",
-                     CE_Range_Check_Failed,
-                     Ent => Target_Typ,
-                     Typ => Target_Typ);
-               end if;
-
-            --  If we were only doing a static check, or if checks are not
-            --  on, then we want to delete the check, since it is not needed.
-            --  We do this by replacing the if statement by a null statement
-
-            elsif Do_Static then
-               Remove_Warning_Messages (R_Cno);
-               Rewrite (R_Cno, Make_Null_Statement (Loc));
-            end if;
-
-         --  The range check raises Constraint_Error explicitly
-
-         else
-            Install_Static_Check (R_Cno, Loc);
-         end if;
-      end loop;
-   end Apply_Selected_Range_Checks;
-
    -------------------------------
    -- Apply_Static_Length_Check --
    -------------------------------

--- gcc/ada/checks.ads
+++ gcc/ada/checks.ads
@@ -578,10 +578,20 @@  package Checks is
    --  which the check is to be done. Used to filter out specific cases where
    --  the check is superfluous.
 
-   procedure Apply_Range_Check
+   procedure Apply_Static_Length_Check
      (Expr       : Node_Id;
       Target_Typ : Entity_Id;
       Source_Typ : Entity_Id := Empty);
+   --  Tries to determine statically whether the two array types source type
+   --  and Target_Typ have the same length. If it can be determined at compile
+   --  time that they do not, then an N_Raise_Constraint_Error node replaces
+   --  Expr, and a warning message is issued.
+
+   procedure Apply_Range_Check
+     (Expr        : Node_Id;
+      Target_Typ  : Entity_Id;
+      Source_Typ  : Entity_Id := Empty;
+      Insert_Node : Node_Id   := Empty);
    --  For a Node of kind N_Range, constructs a range check action that tests
    --  first that the range is not null and then that the range is contained in
    --  the Target_Typ range.
@@ -606,14 +616,8 @@  package Checks is
    --  The source type is used by type conversions to unconstrained array
    --  types to retrieve the corresponding bounds.
 
-   procedure Apply_Static_Length_Check
-     (Expr       : Node_Id;
-      Target_Typ : Entity_Id;
-      Source_Typ : Entity_Id := Empty);
-   --  Tries to determine statically whether the two array types source type
-   --  and Target_Typ have the same length. If it can be determined at compile
-   --  time that they do not, then an N_Raise_Constraint_Error node replaces
-   --  Expr, and a warning message is issued.
+   --  Insert_Node indicates the node where the check should be inserted.
+   --  If it is empty, then the check is inserted directly at Expr instead.
 
    procedure Apply_Scalar_Range_Check
      (Expr       : Node_Id;

--- gcc/ada/sem_ch3.adb
+++ gcc/ada/sem_ch3.adb
@@ -5266,7 +5266,6 @@  package body Sem_Ch3 is
       Skip : Boolean := False)
    is
       Id       : constant Entity_Id := Defining_Identifier (N);
-      R_Checks : Check_Result;
       T        : Entity_Id;
 
    begin
@@ -5791,32 +5790,28 @@  package body Sem_Ch3 is
 
       --  Check that Constraint_Error is raised for a scalar subtype indication
       --  when the lower or upper bound of a non-null range lies outside the
-      --  range of the type mark.
+      --  range of the type mark. Likewise for an array subtype, but check the
+      --  compatibility for each index.
 
       if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
-         if Is_Scalar_Type (Etype (Id))
-           and then Scalar_Range (Id) /=
-                    Scalar_Range
-                      (Etype (Subtype_Mark (Subtype_Indication (N))))
-         then
-            Apply_Range_Check
-              (Scalar_Range (Id),
-               Etype (Subtype_Mark (Subtype_Indication (N))));
-
-         --  In the array case, check compatibility for each index
+         declare
+            Indic_Typ    : constant Entity_Id :=
+                             Etype (Subtype_Mark (Subtype_Indication (N)));
+            Subt_Index   : Node_Id;
+            Target_Index : Node_Id;
 
-         elsif Is_Array_Type (Etype (Id)) and then Present (First_Index (Id))
-         then
-            --  This really should be a subprogram that finds the indications
-            --  to check???
+         begin
+            if Is_Scalar_Type (Etype (Id))
+              and then Scalar_Range (Id) /= Scalar_Range (Indic_Typ)
+            then
+               Apply_Range_Check (Scalar_Range (Id), Indic_Typ);
 
-            declare
-               Subt_Index   : Node_Id := First_Index (Id);
-               Target_Index : Node_Id :=
-                                First_Index (Etype
-                                  (Subtype_Mark (Subtype_Indication (N))));
+            elsif Is_Array_Type (Etype (Id))
+              and then Present (First_Index (Id))
+            then
+               Subt_Index   := First_Index (Id);
+               Target_Index := First_Index (Indic_Typ);
 
-            begin
                while Present (Subt_Index) loop
                   if ((Nkind (Subt_Index) = N_Identifier
                         and then Ekind (Entity (Subt_Index)) in Scalar_Kind)
@@ -5824,30 +5819,17 @@  package body Sem_Ch3 is
                     and then
                       Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range
                   then
-                     declare
-                        Target_Typ : constant Entity_Id :=
-                                       Etype (Target_Index);
-                     begin
-                        R_Checks :=
-                          Get_Range_Checks
-                            (Scalar_Range (Etype (Subt_Index)),
-                             Target_Typ,
-                             Etype (Subt_Index),
-                             Defining_Identifier (N));
-
-                        Insert_Range_Checks
-                          (R_Checks,
-                           N,
-                           Target_Typ,
-                           Sloc (Defining_Identifier (N)));
-                     end;
+                     Apply_Range_Check
+                       (Scalar_Range (Etype (Subt_Index)),
+                        Etype (Target_Index),
+                        Insert_Node => N);
                   end if;
 
                   Next_Index (Subt_Index);
                   Next_Index (Target_Index);
                end loop;
-            end;
-         end if;
+            end if;
+         end;
       end if;
 
       Set_Optimize_Alignment_Flags (Id);