[Ada] Address some ??? comments in checks.adb

gcc/ada/

	* checks.adb (Append_Range_Checks, Apply_Selected_Length_Checks,
	Determine_Range, Insert_Range_Checks,
	Install_Null_Excluding_Check, Selected_Length_Checks,
	Selected_Range_Checks): Address ??? comments and code cleanups.

1 files changed, 80 insertions, 121 deletions

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index d20ede9..a4ad4e6 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -500,9 +500,9 @@ package body Checks is
                     not Range_Checks_Suppressed (Suppress_Typ);
 
    begin
-      --  For now we just return if Checks_On is false, however this should be
+      --  For now we just return if Checks_On is false, however this could be
       --  enhanced to check for an always True value in the condition and to
-      --  generate a compilation warning???
+      --  generate a compilation warning.
 
       if not Checks_On then
          return;
@@ -3459,9 +3459,6 @@ package body Checks is
             end if;
          end if;
 
-         --  If the item is a conditional raise of constraint error, then have
-         --  a look at what check is being performed and ???
-
          if Nkind (R_Cno) = N_Raise_Constraint_Error
            and then Present (Condition (R_Cno))
          then
@@ -5395,8 +5392,7 @@ package body Checks is
                      OK1 := True;
                   end;
 
-               --  No special handling for other attributes
-               --  Probably more opportunities exist here???
+               --  No special handling for other attributes for now
 
                when others =>
                   OK1 := False;
@@ -7986,7 +7982,7 @@ package body Checks is
    begin
       --  For now we just return if Checks_On is false, however this should be
       --  enhanced to check for an always True value in the condition and to
-      --  generate a compilation warning???
+      --  generate a compilation warning.
 
       if not Expander_Active or not Checks_On then
          return;
@@ -8515,22 +8511,6 @@ package body Checks is
          return;
       end if;
 
-      --  No check needed for the Get_Current_Excep.all.all idiom generated by
-      --  the expander within exception handlers, since we know that the value
-      --  can never be null.
-
-      --  Is this really the right way to do this? Normally we generate such
-      --  code in the expander with checks off, and that's how we suppress this
-      --  kind of junk check ???
-
-      if Nkind (N) = N_Function_Call
-        and then Nkind (Name (N)) = N_Explicit_Dereference
-        and then Nkind (Prefix (Name (N))) = N_Identifier
-        and then Is_RTE (Entity (Prefix (Name (N))), RE_Get_Current_Excep)
-      then
-         return;
-      end if;
-
       --  In GNATprove mode, we do not apply the check
 
       if GNATprove_Mode then
@@ -9821,8 +9801,10 @@ package body Checks is
       --  Adds the action given to Ret_Result if N is non-Empty
 
       function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
+      --  Return E'Length (Indx)
+
       function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
-      --  Comments required ???
+      --  Return N'Length (Indx)
 
       function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
       --  True for equal literals and for nodes that denote the same constant
@@ -9858,8 +9840,10 @@ package body Checks is
       begin
          if Present (N) then
 
-            --  For now, ignore attempt to place more than two checks ???
-            --  This is really worrisome, are we really discarding checks ???
+            --  We do not support inserting more than 2 checks on the same
+            --  node. If this happens it means we have already added an
+            --  unconditional raise, so we can skip the other checks safely
+            --  since N will always raise an exception.
 
             if Num_Checks = 2 then
                return;
@@ -10429,7 +10413,10 @@ package body Checks is
       begin
          if Present (N) then
 
-            --  For now, ignore attempt to place more than 2 checks ???
+            --  We do not support inserting more than 2 checks on the same
+            --  node. If this happens it means we have already added an
+            --  unconditional raise, so we can skip the other checks safely
+            --  since N will always raise an exception.
 
             if Num_Checks = 2 then
                return;
@@ -10659,6 +10646,13 @@ package body Checks is
                    Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
       end Range_N_Cond;
 
+      function "<" (Left, Right : Node_Id) return Boolean
+      is (if Is_Floating_Point_Type (S_Typ)
+          then Expr_Value_R (Left) < Expr_Value_R (Right)
+          else Expr_Value   (Left) < Expr_Value   (Right));
+      --  Convenience comparison function of integer or floating point
+      --  values.
+
    --  Start of processing for Selected_Range_Checks
 
    begin
@@ -10729,14 +10723,14 @@ package body Checks is
             Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB);
             Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB);
 
-            LB         : Node_Id := Low_Bound (Expr);
-            HB         : Node_Id := High_Bound (Expr);
-            Known_LB   : Boolean := False;
-            Known_HB   : Boolean := False;
+            LB          : Node_Id := Low_Bound (Expr);
+            HB          : Node_Id := High_Bound (Expr);
+            Known_LB    : Boolean := False;
+            Known_HB    : Boolean := False;
+            Check_Added : Boolean := False;
 
-            Null_Range     : Boolean;
-            Out_Of_Range_L : Boolean;
-            Out_Of_Range_H : Boolean;
+            Out_Of_Range_L : Boolean := False;
+            Out_Of_Range_H : Boolean := False;
 
          begin
             --  Compute what is known at compile time
@@ -10769,61 +10763,46 @@ package body Checks is
                end if;
             end if;
 
-            --  Check for case where everything is static and we can do the
-            --  check at compile time. This is skipped if we have an access
-            --  type, since the access value may be null.
-
-            --  ??? This code can be improved since you only need to know that
-            --  the two respective bounds (LB & T_LB or HB & T_HB) are known at
-            --  compile time to emit pertinent messages.
-
-            if Known_T_LB and Known_T_HB and Known_LB and Known_HB
-              and not Do_Access
-            then
-               --  Floating-point case
-
-               if Is_Floating_Point_Type (S_Typ) then
-                  Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
-                  Out_Of_Range_L :=
-                    (Expr_Value_R (LB) < Expr_Value_R (T_LB))
-                      or else
-                    (Expr_Value_R (LB) > Expr_Value_R (T_HB));
-
-                  Out_Of_Range_H :=
-                    (Expr_Value_R (HB) > Expr_Value_R (T_HB))
-                      or else
-                    (Expr_Value_R (HB) < Expr_Value_R (T_LB));
-
-               --  Fixed or discrete type case
+            --  Check for the simple cases where we can do the check at
+            --  compile time. This is skipped if we have an access type, since
+            --  the access value may be null.
 
-               else
-                  Null_Range := Expr_Value (HB) < Expr_Value (LB);
-                  Out_Of_Range_L :=
-                    (Expr_Value (LB) < Expr_Value (T_LB))
-                      or else
-                    (Expr_Value (LB) > Expr_Value (T_HB));
+            if not Do_Access and then Not_Null_Range (LB, HB) then
+               if Known_LB then
+                  if Known_T_LB then
+                     Out_Of_Range_L := LB < T_LB;
+                  end if;
 
-                  Out_Of_Range_H :=
-                    (Expr_Value (HB) > Expr_Value (T_HB))
-                      or else
-                    (Expr_Value (HB) < Expr_Value (T_LB));
-               end if;
+                  if Known_T_HB and not Out_Of_Range_L then
+                     Out_Of_Range_L := T_HB < LB;
+                  end if;
 
-               if not Null_Range then
                   if Out_Of_Range_L then
                      if No (Warn_Node) then
                         Add_Check
                           (Compile_Time_Constraint_Error
                              (Low_Bound (Expr),
                               "static value out of range of}??", T_Typ));
+                        Check_Added := True;
 
                      else
                         Add_Check
                           (Compile_Time_Constraint_Error
                             (Wnode,
                              "static range out of bounds of}??", T_Typ));
+                        Check_Added := True;
                      end if;
                   end if;
+               end if;
+
+               if Known_HB then
+                  if Known_T_HB then
+                     Out_Of_Range_H := T_HB < HB;
+                  end if;
+
+                  if Known_T_LB and not Out_Of_Range_H then
+                     Out_Of_Range_H := HB < T_LB;
+                  end if;
 
                   if Out_Of_Range_H then
                      if No (Warn_Node) then
@@ -10831,17 +10810,29 @@ package body Checks is
                           (Compile_Time_Constraint_Error
                              (High_Bound (Expr),
                               "static value out of range of}??", T_Typ));
+                        Check_Added := True;
 
                      else
                         Add_Check
                           (Compile_Time_Constraint_Error
                              (Wnode,
                               "static range out of bounds of}??", T_Typ));
+                        Check_Added := True;
                      end if;
                   end if;
                end if;
+            end if;
 
-            else
+            --  Check for the case where not everything is static
+
+            if not Check_Added
+              and then
+                (Do_Access
+                  or else not Known_T_LB
+                  or else not Known_LB
+                  or else not Known_T_HB
+                  or else not Known_HB)
+            then
                declare
                   LB : Node_Id := Low_Bound (Expr);
                   HB : Node_Id := High_Bound (Expr);
@@ -10908,8 +10899,8 @@ package body Checks is
       elsif Is_Scalar_Type (S_Typ) then
 
          --  This somewhat duplicates what Apply_Scalar_Range_Check does,
-         --  except the above simply sets a flag in the node and lets
-         --  gigi generate the check base on the Etype of the expression.
+         --  except the above simply sets a flag in the node and lets the
+         --  check be generated based on the Etype of the expression.
          --  Sometimes, however we want to do a dynamic check against an
          --  arbitrary target type, so we do that here.
 
@@ -10923,56 +10914,24 @@ package body Checks is
          --  expression. As usual, skip this for access types
 
          elsif Compile_Time_Known_Value (Expr) and then not Do_Access then
-            declare
-               LB : constant Node_Id := Type_Low_Bound (T_Typ);
-               UB : constant Node_Id := Type_High_Bound (T_Typ);
-
-               Out_Of_Range  : Boolean;
-               Static_Bounds : constant Boolean :=
-                 Compile_Time_Known_Value (LB)
-                 and Compile_Time_Known_Value (UB);
-
-            begin
-               --  Following range tests should use Sem_Eval routine ???
-
-               if Static_Bounds then
-                  if Is_Floating_Point_Type (S_Typ) then
-                     Out_Of_Range :=
-                       (Expr_Value_R (Expr) < Expr_Value_R (LB))
-                         or else
-                       (Expr_Value_R (Expr) > Expr_Value_R (UB));
-
-                  --  Fixed or discrete type
-
-                  else
-                     Out_Of_Range :=
-                       Expr_Value (Expr) < Expr_Value (LB)
-                         or else
-                       Expr_Value (Expr) > Expr_Value (UB);
-                  end if;
-
-                  --  Bounds of the type are static and the literal is out of
-                  --  range so output a warning message.
+            if Is_Out_Of_Range (Expr, T_Typ) then
 
-                  if Out_Of_Range then
-                     if No (Warn_Node) then
-                        Add_Check
-                          (Compile_Time_Constraint_Error
-                             (Expr,
-                              "static value out of range of}??", T_Typ));
+               --  Bounds of the type are static and the literal is out of
+               --  range so output a warning message.
 
-                     else
-                        Add_Check
-                          (Compile_Time_Constraint_Error
-                             (Wnode,
-                              "static value out of range of}??", T_Typ));
-                     end if;
-                  end if;
+               if No (Warn_Node) then
+                  Add_Check
+                    (Compile_Time_Constraint_Error
+                       (Expr, "static value out of range of}??", T_Typ));
 
                else
-                  Cond := Discrete_Expr_Cond (Expr, T_Typ);
+                  Add_Check
+                    (Compile_Time_Constraint_Error
+                       (Wnode, "static value out of range of}??", T_Typ));
                end if;
-            end;
+            else
+               Cond := Discrete_Expr_Cond (Expr, T_Typ);
+            end if;
 
          --  Here for the case of a non-static expression, we need a runtime
          --  check unless the source type range is guaranteed to be in the