2007-04-20 Javier Miranda <miranda@adacore.com>

	    Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* checks.ads, checks.adb (Apply_Address_Clause_Check): Handle case in
	which the address-clause is applied to in-mode actuals (allowed by
	13.1(22)).
	(Apply_Discriminant_Check): Do not generate a check if the type is
	constrained by a current instance.
	(Activate_Division_Check): New procedure
	(Activate_Overflow_Check): New procedure
	(Activate_Range_Check): New procedure
	Call these new Activate procedures instead of setting flags directly
	(Apply_Array_Size_Check): Removed, no longer needed.
	Code clean up: remove obsolete code related to GCC 2.
	(Get_E_Length): Protect against bomb in case scope is standard
	(Selected_Range_Checks): If the node to be checked is a conversion to
	an unconstrained array type, and the expression is a slice, use the
	bounds of the slice to construct the required constraint checks.
	Improve NOT NULL error messages
	(Apply_Constraint_Check): If the context is a null-excluding access
	type, diagnose properly the literal null.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125388 138bc75d-0d04-0410-961f-82ee72b054a4

2 files changed, 149 insertions, 311 deletions

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 53c534d9ad2..ca0549501c8 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -29,12 +29,14 @@ with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Exp_Ch2;  use Exp_Ch2;
+with Exp_Ch11; use Exp_Ch11;
 with Exp_Pakd; use Exp_Pakd;
 with Exp_Util; use Exp_Util;
 with Elists;   use Elists;
 with Eval_Fat; use Eval_Fat;
 with Freeze;   use Freeze;
 with Lib;      use Lib;
+with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
@@ -336,6 +338,36 @@ package body Checks is
       end if;
    end Accessibility_Checks_Suppressed;
 
+   -----------------------------
+   -- Activate_Division_Check --
+   -----------------------------
+
+   procedure Activate_Division_Check (N : Node_Id) is
+   begin
+      Set_Do_Division_Check (N, True);
+      Possible_Local_Raise (N, Standard_Constraint_Error);
+   end Activate_Division_Check;
+
+   -----------------------------
+   -- Activate_Overflow_Check --
+   -----------------------------
+
+   procedure Activate_Overflow_Check (N : Node_Id) is
+   begin
+      Set_Do_Overflow_Check (N, True);
+      Possible_Local_Raise (N, Standard_Constraint_Error);
+   end Activate_Overflow_Check;
+
+   --------------------------
+   -- Activate_Range_Check --
+   --------------------------
+
+   procedure Activate_Range_Check (N : Node_Id) is
+   begin
+      Set_Do_Range_Check (N, True);
+      Possible_Local_Raise (N, Standard_Constraint_Error);
+   end Activate_Range_Check;
+
    ---------------------------------
    -- Alignment_Checks_Suppressed --
    ---------------------------------
@@ -674,12 +706,17 @@ package body Checks is
       else
          --  If the original expression is a non-static constant, use the
          --  name of the constant itself rather than duplicating its
-         --  defining expression, which was extracted above..
+         --  defining expression, which was extracted above.
 
-         if Is_Entity_Name (Expression (AC))
-           and then Ekind (Entity (Expression (AC))) = E_Constant
-           and then
-             Nkind (Parent (Entity (Expression (AC)))) = N_Object_Declaration
+         --  Note: Expr is empty if the address-clause is applied to in-mode
+         --  actuals (allowed by 13.1(22)).
+
+         if not Present (Expr)
+           or else
+             (Is_Entity_Name (Expression (AC))
+               and then Ekind (Entity (Expression (AC))) = E_Constant
+               and then Nkind (Parent (Entity (Expression (AC))))
+                                 = N_Object_Declaration)
          then
             Expr := New_Copy_Tree (Expression (AC));
          else
@@ -738,8 +775,11 @@ package body Checks is
    begin
       --  Skip this if overflow checks are done in back end, or the overflow
       --  flag is not set anyway, or we are not doing code expansion.
+      --  Special case CLI target, where arithmetic overflow checks can be
+      --  performed for integer and long_integer
 
       if Backend_Overflow_Checks_On_Target
+        or else (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size)
         or else not Do_Overflow_Check (N)
         or else not Expander_Active
       then
@@ -859,266 +899,6 @@ package body Checks is
    end Apply_Arithmetic_Overflow_Check;
 
    ----------------------------
-   -- Apply_Array_Size_Check --
-   ----------------------------
-
-   --  The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits is
-   --  computed in 32 bits without an overflow check. That's a real problem for
-   --  Ada. So what we do in GNAT 3 is to approximate the size of an array by
-   --  manually multiplying the element size by the number of elements, and
-   --  comparing that against the allowed limits.
-
-   --  In GNAT 5, the size in byte is still computed in 32 bits without an
-   --  overflow check in the dynamic case, but the size in bits is computed in
-   --  64 bits. We assume that's good enough, and we do not bother to generate
-   --  any front end test.
-
-   procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
-      Loc  : constant Source_Ptr := Sloc (N);
-      Ctyp : constant Entity_Id  := Component_Type (Typ);
-      Ent  : constant Entity_Id  := Defining_Identifier (N);
-      Decl : Node_Id;
-      Lo   : Node_Id;
-      Hi   : Node_Id;
-      Lob  : Uint;
-      Hib  : Uint;
-      Siz  : Uint;
-      Xtyp : Entity_Id;
-      Indx : Node_Id;
-      Sizx : Node_Id;
-      Code : Node_Id;
-
-      Static : Boolean := True;
-      --  Set false if any index subtye bound is non-static
-
-      Umark : constant Uintp.Save_Mark := Uintp.Mark;
-      --  We can throw away all the Uint computations here, since they are done
-      --  only to generate boolean test results.
-
-      Check_Siz : Uint;
-      --  Size to check against
-
-      function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
-      --  Determines if Decl is an address clause or Import/Interface pragma
-      --  that references the defining identifier of the current declaration.
-
-      --------------------------
-      -- Is_Address_Or_Import --
-      --------------------------
-
-      function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
-      begin
-         if Nkind (Decl) = N_At_Clause then
-            return Chars (Identifier (Decl)) = Chars (Ent);
-
-         elsif Nkind (Decl) = N_Attribute_Definition_Clause then
-            return
-              Chars (Decl) = Name_Address
-                and then
-              Nkind (Name (Decl)) = N_Identifier
-                and then
-              Chars (Name (Decl)) = Chars (Ent);
-
-         elsif Nkind (Decl) = N_Pragma then
-            if (Chars (Decl) = Name_Import
-                 or else
-                Chars (Decl) = Name_Interface)
-              and then Present (Pragma_Argument_Associations (Decl))
-            then
-               declare
-                  F : constant Node_Id :=
-                        First (Pragma_Argument_Associations (Decl));
-               begin
-                  return
-                    Present (F)
-                      and then
-                    Present (Next (F))
-                      and then
-                    Nkind (Expression (Next (F))) = N_Identifier
-                      and then
-                    Chars (Expression (Next (F))) = Chars (Ent);
-               end;
-
-            else
-               return False;
-            end if;
-
-         else
-            return False;
-         end if;
-      end Is_Address_Or_Import;
-
-   --  Start of processing for Apply_Array_Size_Check
-
-   begin
-      --  Do size check on local arrays. We only need this in the GCC 2 case,
-      --  since in GCC 3, we expect the back end to properly handle things.
-      --  This routine can be removed when we baseline GNAT 3.
-
-      --  Shouldn't we remove GCC 2 crud at this stage ???
-
-      if Opt.GCC_Version >= 3 then
-         return;
-      end if;
-
-      --  No need for a check if not expanding
-
-      if not Expander_Active then
-         return;
-      end if;
-
-      --  No need for a check if checks are suppressed
-
-      if Storage_Checks_Suppressed (Typ) then
-         return;
-      end if;
-
-      --  It is pointless to insert this check inside an init proc, because
-      --  that's too late, we have already built the object to be the right
-      --  size, and if it's too large, too bad!
-
-      if Inside_Init_Proc then
-         return;
-      end if;
-
-      --  Look head for pragma interface/import or address clause applying to
-      --  this entity. If found, we suppress the check entirely. For now we
-      --  only look ahead 20 declarations to stop this becoming too slow Note
-      --  that eventually this whole routine gets moved to gigi.
-
-      Decl := N;
-      for Ctr in 1 .. 20 loop
-         Next (Decl);
-         exit when No (Decl);
-
-         if Is_Address_Or_Import (Decl) then
-            return;
-         end if;
-      end loop;
-
-      --  First step is to calculate the maximum number of elements. For this
-      --  calculation, we use the actual size of the subtype if it is static,
-      --  and if a bound of a subtype is non-static, we go to the bound of the
-      --  base type.
-
-      Siz := Uint_1;
-      Indx := First_Index (Typ);
-      while Present (Indx) loop
-         Xtyp := Etype (Indx);
-         Lo := Type_Low_Bound (Xtyp);
-         Hi := Type_High_Bound (Xtyp);
-
-         --  If any bound raises constraint error, we will never get this far,
-         --  so there is no need to generate any kind of check.
-
-         if Raises_Constraint_Error (Lo)
-           or else
-             Raises_Constraint_Error (Hi)
-         then
-            Uintp.Release (Umark);
-            return;
-         end if;
-
-         --  Otherwise get bounds values
-
-         if Is_Static_Expression (Lo) then
-            Lob := Expr_Value (Lo);
-         else
-            Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
-            Static := False;
-         end if;
-
-         if Is_Static_Expression (Hi) then
-            Hib := Expr_Value (Hi);
-         else
-            Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
-            Static := False;
-         end if;
-
-         Siz := Siz *  UI_Max (Hib - Lob + 1, Uint_0);
-         Next_Index (Indx);
-      end loop;
-
-      --  Compute the limit against which we want to check. For subprograms,
-      --  where the array will go on the stack, we use 8*2**24, which (in
-      --  bits) is the size of a 16 megabyte array.
-
-      if Is_Subprogram (Scope (Ent)) then
-         Check_Siz := Uint_2 ** 27;
-      else
-         Check_Siz := Uint_2 ** 31;
-      end if;
-
-      --  If we have all static bounds and Siz is too large, then we know we
-      --  have a storage error right now, so generate message
-
-      if Static and then Siz >= Check_Siz then
-         Insert_Action (N,
-           Make_Raise_Storage_Error (Loc,
-             Reason => SE_Object_Too_Large));
-         Error_Msg_N ("?Storage_Error will be raised at run-time", N);
-         Uintp.Release (Umark);
-         return;
-      end if;
-
-      --  Case of component size known at compile time. If the array size is
-      --  definitely in range, then we do not need a check.
-
-      if Known_Esize (Ctyp)
-        and then Siz * Esize (Ctyp) < Check_Siz
-      then
-         Uintp.Release (Umark);
-         return;
-      end if;
-
-      --  Here if a dynamic check is required
-
-      --  What we do is to build an expression for the size of the array, which
-      --  is computed as the 'Size of the array component, times the size of
-      --  each dimension.
-
-      Uintp.Release (Umark);
-
-      Sizx :=
-        Make_Attribute_Reference (Loc,
-          Prefix =>         New_Occurrence_Of (Ctyp, Loc),
-          Attribute_Name => Name_Size);
-
-      Indx := First_Index (Typ);
-      for J in 1 .. Number_Dimensions (Typ) loop
-         if Sloc (Etype (Indx)) = Sloc (N) then
-            Ensure_Defined (Etype (Indx), N);
-         end if;
-
-         Sizx :=
-           Make_Op_Multiply (Loc,
-             Left_Opnd  => Sizx,
-             Right_Opnd =>
-               Make_Attribute_Reference (Loc,
-                 Prefix         => New_Occurrence_Of (Typ, Loc),
-                 Attribute_Name => Name_Length,
-                 Expressions    => New_List (
-                   Make_Integer_Literal (Loc, J))));
-         Next_Index (Indx);
-      end loop;
-
-      --  Emit the check
-
-      Code :=
-        Make_Raise_Storage_Error (Loc,
-          Condition =>
-            Make_Op_Ge (Loc,
-              Left_Opnd  => Sizx,
-              Right_Opnd =>
-                Make_Integer_Literal (Loc,
-                  Intval    => Check_Siz)),
-          Reason => SE_Object_Too_Large);
-
-      Set_Size_Check_Code (Defining_Identifier (N), Code);
-      Insert_Action (N, Code, Suppress => All_Checks);
-   end Apply_Array_Size_Check;
-
-   ----------------------------
    -- Apply_Constraint_Check --
    ----------------------------
 
@@ -1174,7 +954,9 @@ package body Checks is
          --  No checks necessary if expression statically null
 
          if Nkind (N) = N_Null then
-            null;
+            if Can_Never_Be_Null (Typ) then
+               Install_Null_Excluding_Check (N);
+            end if;
 
          --  No sliding possible on access to arrays
 
@@ -1191,8 +973,14 @@ package body Checks is
             Apply_Discriminant_Check (N, Typ);
          end if;
 
+         --  Apply the the 2005 Null_Excluding check. Note that we do not apply
+         --  this check if the constraint node is illegal, as shown by having
+         --  an error posted. This additional guard prevents cascaded errors
+         --  and compiler aborts on illegal programs involving Ada 2005 checks.
+
          if Can_Never_Be_Null (Typ)
            and then not Can_Never_Be_Null (Etype (N))
+           and then not Error_Posted (N)
          then
             Install_Null_Excluding_Check (N);
          end if;
@@ -1439,6 +1227,18 @@ package body Checks is
                ItemS := Node (DconS);
                ItemT := Node (DconT);
 
+               --  For a discriminated component type constrained by the
+               --  current instance of an enclosing type, there is no
+               --  applicable discriminant check.
+
+               if Nkind (ItemT) = N_Attribute_Reference
+                 and then Is_Access_Type (Etype (ItemT))
+                 and then Is_Entity_Name (Prefix (ItemT))
+                 and then Is_Type (Entity (Prefix (ItemT)))
+               then
+                  return;
+               end if;
+
                exit when
                  not Is_OK_Static_Expression (ItemS)
                    or else
@@ -2166,15 +1966,14 @@ package body Checks is
             --  We do this by replacing the if statement by a null statement
 
             elsif Do_Static or else not Checks_On then
+               Remove_Warning_Messages (R_Cno);
                Rewrite (R_Cno, Make_Null_Statement (Loc));
             end if;
 
          else
             Install_Static_Check (R_Cno, Loc);
          end if;
-
       end loop;
-
    end Apply_Selected_Length_Checks;
 
    ---------------------------------
@@ -2258,6 +2057,7 @@ package body Checks is
             --  We do this by replacing the if statement by a null statement
 
             elsif Do_Static or else not Checks_On then
+               Remove_Warning_Messages (R_Cno);
                Rewrite (R_Cno, Make_Null_Statement (Loc));
             end if;
 
@@ -2351,7 +2151,7 @@ package body Checks is
               and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
               and then not Float_To_Int
             then
-               Set_Do_Overflow_Check (N);
+               Activate_Overflow_Check (N);
             end if;
 
             if not Range_Checks_Suppressed (Target_Type)
@@ -2838,8 +2638,7 @@ package body Checks is
 
          if not Is_Access_Type (Typ) then
             Error_Msg_N
-              ("null-exclusion must be applied to an access type",
-               Error_Node);
+              ("`NOT NULL` allowed only for an access type", Error_Node);
 
          --  Enforce legality rule RM 3.10(14/1): A null exclusion can only
          --  be applied to a [sub]type that does not exclude null already.
@@ -2851,9 +2650,9 @@ package body Checks is
 
            and then not Is_Itype (Typ)
          then
-            Error_Msg_N
-              ("null-exclusion cannot be applied to a null excluding type",
-               Error_Node);
+            Error_Msg_NE
+              ("`NOT NULL` not allowed (& already excludes null)",
+               Error_Node, Typ);
          end if;
       end if;
 
@@ -3498,7 +3297,7 @@ package body Checks is
          w ("Enable_Overflow_Check for node ", Int (N));
          Write_Str ("  Source location = ");
          wl (Sloc (N));
-         pg (N);
+         pg (Union_Id (N));
       end if;
 
       --  Nothing to do if the range of the result is known OK. We skip this
@@ -3549,7 +3348,7 @@ package body Checks is
         or else not Is_Discrete_Type (Etype (N))
         or else Num_Saved_Checks = Saved_Checks'Last
       then
-         Set_Do_Overflow_Check (N, True);
+         Activate_Overflow_Check (N);
 
          if Debug_Flag_CC then
             w ("Optimization off");
@@ -3584,7 +3383,7 @@ package body Checks is
       --  If check is not of form to optimize, then set flag and we are done
 
       if not OK then
-         Set_Do_Overflow_Check (N, True);
+         Activate_Overflow_Check (N);
          return;
       end if;
 
@@ -3600,7 +3399,7 @@ package body Checks is
 
       --  Here we will make a new entry for the new check
 
-      Set_Do_Overflow_Check (N, True);
+      Activate_Overflow_Check (N);
       Num_Saved_Checks := Num_Saved_Checks + 1;
       Saved_Checks (Num_Saved_Checks) :=
         (Killed      => False,
@@ -3625,7 +3424,7 @@ package body Checks is
 
    exception
       when others =>
-         Set_Do_Overflow_Check (N, True);
+         Activate_Overflow_Check (N);
 
          if Debug_Flag_CC then
             w ("  exception occurred, overflow flag set");
@@ -3697,7 +3496,7 @@ package body Checks is
          w ("Enable_Range_Check for node ", Int (N));
          Write_Str ("  Source location = ");
          wl (Sloc (N));
-         pg (N);
+         pg (Union_Id (N));
       end if;
 
       --  If not in optimizing mode, set flag and we are done. We are also done
@@ -3712,7 +3511,7 @@ package body Checks is
         or else not Is_Discrete_Type (Etype (N))
         or else Num_Saved_Checks = Saved_Checks'Last
       then
-         Set_Do_Range_Check (N, True);
+         Activate_Range_Check (N);
 
          if Debug_Flag_CC then
             w ("Optimization off");
@@ -3752,7 +3551,7 @@ package body Checks is
                --  may be redundant.
 
                if not Is_Constrained (Atyp) then
-                  Set_Do_Range_Check (N, True);
+                  Activate_Range_Check (N);
                   return;
                end if;
 
@@ -3762,7 +3561,7 @@ package body Checks is
             elsif Nkind (Prefix (P)) = N_Explicit_Dereference
               and then not Is_Constrained (Atyp)
             then
-               Set_Do_Range_Check (N, True);
+               Activate_Range_Check (N);
                return;
             end if;
 
@@ -3786,7 +3585,7 @@ package body Checks is
             w ("  target type not found, flag set");
          end if;
 
-         Set_Do_Range_Check (N, True);
+         Activate_Range_Check (N);
          return;
       end if;
 
@@ -3821,7 +3620,7 @@ package body Checks is
             w ("  expression not of optimizable type, flag set");
          end if;
 
-         Set_Do_Range_Check (N, True);
+         Activate_Range_Check (N);
          return;
       end if;
 
@@ -3837,7 +3636,7 @@ package body Checks is
 
       --  Here we will make a new entry for the new check
 
-      Set_Do_Range_Check (N, True);
+      Activate_Range_Check (N);
       Num_Saved_Checks := Num_Saved_Checks + 1;
       Saved_Checks (Num_Saved_Checks) :=
         (Killed      => False,
@@ -3853,7 +3652,7 @@ package body Checks is
          pid (Ofs);
          w ("  Check_Type = R");
          w ("  Target_Type = ", Int (Ttyp));
-         pg (Ttyp);
+         pg (Union_Id (Ttyp));
       end if;
 
    --  If we get an exception, then something went wrong, probably because of
@@ -3863,7 +3662,7 @@ package body Checks is
 
    exception
       when others =>
-         Set_Do_Range_Check (N, True);
+         Activate_Range_Check (N);
 
          if Debug_Flag_CC then
             w ("  exception occurred, range flag set");
@@ -5077,6 +4876,9 @@ package body Checks is
          --  operand is within its declared range (an assumption that validity
          --  checking is all about NOT assuming!)
 
+         --  Note: no need to worry about Possible_Local_Raise here, it will
+         --  already have been called if original node has Do_Range_Check set.
+
          Set_Do_Range_Check (Exp, DRC);
       end;
    end Insert_Valid_Check;
@@ -5508,7 +5310,7 @@ package body Checks is
       ------------------
 
       function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
-         Pt : constant Entity_Id := Scope (Scope (E));
+         SE : constant Entity_Id := Scope (E);
          N  : Node_Id;
          E1 : Entity_Id := E;
 
@@ -5529,12 +5331,12 @@ package body Checks is
               Make_Integer_Literal (Loc,
                 Intval => String_Literal_Length (E1));
 
-         elsif Ekind (Pt) = E_Protected_Type
-           and then Has_Discriminants (Pt)
-           and then Has_Completion (Pt)
+         elsif SE /= Standard_Standard
+           and then Ekind (Scope (SE)) = E_Protected_Type
+           and then Has_Discriminants (Scope (SE))
+           and then Has_Completion (Scope (SE))
            and then not Inside_Init_Proc
          then
-
             --  If the type whose length is needed is a private component
             --  constrained by a discriminant, we must expand the 'Length
             --  attribute into an explicit computation, using the discriminal
@@ -6756,37 +6558,52 @@ package body Checks is
                declare
                   Opnd_Index : Node_Id;
                   Targ_Index : Node_Id;
+                  Opnd_Range : Node_Id;
 
                begin
                   Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
                   Targ_Index := First_Index (T_Typ);
-                  while Opnd_Index /= Empty loop
-                     if Nkind (Opnd_Index) = N_Range then
+
+                  while Present (Opnd_Index) loop
+
+                     --  If the index is a range, use its bounds. If it is an
+                     --  entity (as will be the case if it is a named subtype
+                     --  or an itype created for a slice) retrieve its range.
+
+                     if Is_Entity_Name (Opnd_Index)
+                       and then Is_Type (Entity (Opnd_Index))
+                     then
+                        Opnd_Range := Scalar_Range (Entity (Opnd_Index));
+                     else
+                        Opnd_Range := Opnd_Index;
+                     end if;
+
+                     if Nkind (Opnd_Range) = N_Range then
                         if Is_In_Range
-                             (Low_Bound (Opnd_Index), Etype (Targ_Index))
+                             (Low_Bound (Opnd_Range), Etype (Targ_Index))
                           and then
                             Is_In_Range
-                             (High_Bound (Opnd_Index), Etype (Targ_Index))
+                             (High_Bound (Opnd_Range), Etype (Targ_Index))
                         then
                            null;
 
                         --  If null range, no check needed
 
                         elsif
-                          Compile_Time_Known_Value (High_Bound (Opnd_Index))
+                          Compile_Time_Known_Value (High_Bound (Opnd_Range))
                             and then
-                          Compile_Time_Known_Value (Low_Bound (Opnd_Index))
+                          Compile_Time_Known_Value (Low_Bound (Opnd_Range))
                             and then
-                              Expr_Value (High_Bound (Opnd_Index)) <
-                                  Expr_Value (Low_Bound (Opnd_Index))
+                              Expr_Value (High_Bound (Opnd_Range)) <
+                                  Expr_Value (Low_Bound (Opnd_Range))
                         then
                            null;
 
                         elsif Is_Out_Of_Range
-                                (Low_Bound (Opnd_Index), Etype (Targ_Index))
+                                (Low_Bound (Opnd_Range), Etype (Targ_Index))
                           or else
                               Is_Out_Of_Range
-                                (High_Bound (Opnd_Index), Etype (Targ_Index))
+                                (High_Bound (Opnd_Range), Etype (Targ_Index))
                         then
                            Add_Check
                              (Compile_Time_Constraint_Error
@@ -6796,7 +6613,7 @@ package body Checks is
                            Evolve_Or_Else
                              (Cond,
                               Discrete_Range_Cond
-                                (Opnd_Index, Etype (Targ_Index)));
+                                (Opnd_Range, Etype (Targ_Index)));
                         end if;
                      end if;
 
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index 84012a16a60..d981c3b5e9c 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -65,6 +65,32 @@ package Checks is
    --  reason we insist on specifying Empty is to force the caller to think
    --  about whether there is any relevant entity that should be checked.
 
+   -------------------------------------------
+   -- Procedures to Activate Checking Flags --
+   -------------------------------------------
+
+   procedure Activate_Division_Check (N : Node_Id);
+   pragma Inline (Activate_Division_Check);
+   --  Sets Do_Division_Check flag in node N, and handles possible local raise.
+   --  Always call this routine rather than calling Set_Do_Division_Check to
+   --  set an explicit value of True, to ensure handling the local raise case.
+
+   procedure Activate_Overflow_Check (N : Node_Id);
+   pragma Inline (Activate_Overflow_Check);
+   --  Sets Do_Overflow_Check flag in node N, and handles possible local raise.
+   --  Always call this routine rather than calling Set_Do_Overflow_Check to
+   --  set an explicit value of True, to ensure handling the local raise case.
+
+   procedure Activate_Range_Check (N : Node_Id);
+   pragma Inline (Activate_Range_Check);
+   --  Sets Do_Range_Check flag in node N, and handles possible local raise
+   --  Always call this routine rather than calling Set_Do_Range_Check to
+   --  set an explicit value of True, to ensure handling the local raise case.
+
+   --------------------------------
+   -- Procedures to Apply Checks --
+   --------------------------------
+
    --  General note on following checks. These checks are always active if
    --  Expander_Active and not Inside_A_Generic. They are inactive and have
    --  no effect Inside_A_Generic. In the case where not Expander_Active
@@ -90,11 +116,6 @@ package Checks is
    --  a clear overlay situation that the size of the overlaying object is not
    --  larger than the overlaid object.
 
-   procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id);
-   --  N is the node for an object declaration that declares an object of
-   --  array type Typ. This routine generates, if necessary, a check that
-   --  the size of the array is not too large, raising Storage_Error if so.
-
    procedure Apply_Arithmetic_Overflow_Check (N : Node_Id);
    --  Given a binary arithmetic operator (+ - *) expand a software integer
    --  overflow check using range checks on a larger checking type or a call