* checks.ads:

	(Remove_Checks): New procedure

	* checks.adb:
	(Remove_Checks): New procedure

	* exp_util.adb:
	Use new Duplicate_Subexpr functions
	(Duplicate_Subexpr_No_Checks): New procedure
	(Duplicate_Subexpr_No_Checks_Orig): New procedure
	(Duplicate_Subexpr): Restore original form (checks duplicated)
	(Duplicate_Subexpr): Call Remove_Checks

	* exp_util.ads:
	(Duplicate_Subexpr_No_Checks): New procedure
	(Duplicate_Subexpr_No_Checks_Orig): New procedure
	Add 2002 to copyright notice

	* sem_util.adb: Use new Duplicate_Subexpr functions

	* sem_eval.adb:
	(Eval_Indexed_Component): This is the place to call
	Constant_Array_Ref and to replace the value. We simply merge
	the code of this function in here, since it is now no longer
	used elsewhere. This fixes the problem of the back end not
	realizing we were clever enough to see that this was
	constant.
	(Expr_Val): Remove call to Constant_Array_Ref
	(Expr_Rep_Val): Remove call to Constant_Array_Ref
	Minor reformatting
	(Constant_Array_Ref): Deal with string literals (patch
	suggested by Zack Weinberg on the gcc list)

	* exp_util.adb: Duplicate_Subexpr_No_Checks_Orig =>
	Duplicate_Subexpr_Move_Checks.

	* exp_util.ads: Duplicate_Subexpr_No_Checks_Orig =>
	Duplicate_Subexpr_Move_Checks.

	* sem_eval.adb: (Constant_Array_Ref): Verify that constant
	value of array exists before retrieving it (it may a private
	protected component in a function).


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

7 files changed, 302 insertions, 101 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9246f26e09d..5105950589c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,50 @@
+2001-03-28  Robert Dewar <dewar@gnat.com>
+
+	* checks.ads:
+	(Remove_Checks): New procedure
+
+	* checks.adb:
+	(Remove_Checks): New procedure
+
+	* exp_util.adb:
+	Use new Duplicate_Subexpr functions
+	(Duplicate_Subexpr_No_Checks): New procedure
+	(Duplicate_Subexpr_No_Checks_Orig): New procedure
+	(Duplicate_Subexpr): Restore original form (checks duplicated)
+	(Duplicate_Subexpr): Call Remove_Checks
+
+	* exp_util.ads: 
+	(Duplicate_Subexpr_No_Checks): New procedure
+	(Duplicate_Subexpr_No_Checks_Orig): New procedure
+	Add 2002 to copyright notice
+
+	* sem_util.adb: Use new Duplicate_Subexpr functions
+
+	* sem_eval.adb: 	
+	(Eval_Indexed_Component): This is the place to call
+	Constant_Array_Ref and to replace the value. We simply merge
+	the code of this function in here, since it is now no longer
+	used elsewhere. This fixes the problem of the back end not
+	realizing we were clever enough to see that this was
+	constant.
+	(Expr_Val): Remove call to Constant_Array_Ref
+	(Expr_Rep_Val): Remove call to Constant_Array_Ref
+	Minor reformatting
+	(Constant_Array_Ref): Deal with string literals (patch
+	suggested by Zack Weinberg on the gcc list)
+
+2001-03-28  Ed Schonberg <schonber@gnat.com>
+
+	* exp_util.adb: Duplicate_Subexpr_No_Checks_Orig => 
+	Duplicate_Subexpr_Move_Checks.
+
+	* exp_util.ads: Duplicate_Subexpr_No_Checks_Orig => 
+	Duplicate_Subexpr_Move_Checks.
+
+	* sem_eval.adb: (Constant_Array_Ref): Verify that constant 
+	value of array exists before retrieving it (it may a private 
+	protected component in a function).
+
 2002-03-28   Geert Bosch <bosch@gnat.com>
 
 	* prj-pp.adb : New file.
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 5442819566b..327f1cc751b 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2918,6 +2918,104 @@ package body Checks is
         or else Vax_Float (E);
    end Range_Checks_Suppressed;
 
+   -------------------
+   -- Remove_Checks --
+   -------------------
+
+   procedure Remove_Checks (Expr : Node_Id) is
+      Discard : Traverse_Result;
+
+      function Process (N : Node_Id) return Traverse_Result;
+      --  Process a single node during the traversal
+
+      function Traverse is new Traverse_Func (Process);
+      --  The traversal function itself
+
+      -------------
+      -- Process --
+      -------------
+
+      function Process (N : Node_Id) return Traverse_Result is
+      begin
+         if Nkind (N) not in N_Subexpr then
+            return Skip;
+         end if;
+
+         Set_Do_Range_Check (N, False);
+
+         case Nkind (N) is
+            when N_And_Then =>
+               Discard := Traverse (Left_Opnd (N));
+               return Skip;
+
+            when N_Attribute_Reference =>
+               Set_Do_Access_Check (N, False);
+               Set_Do_Overflow_Check (N, False);
+
+            when N_Explicit_Dereference =>
+               Set_Do_Access_Check (N, False);
+
+            when N_Function_Call =>
+               Set_Do_Tag_Check (N, False);
+
+            when N_Indexed_Component =>
+               Set_Do_Access_Check (N, False);
+
+            when N_Op =>
+               Set_Do_Overflow_Check (N, False);
+
+               case Nkind (N) is
+                  when N_Op_Divide =>
+                     Set_Do_Division_Check (N, False);
+
+                  when N_Op_And =>
+                     Set_Do_Length_Check (N, False);
+
+                  when N_Op_Mod =>
+                     Set_Do_Division_Check (N, False);
+
+                  when N_Op_Or =>
+                     Set_Do_Length_Check (N, False);
+
+                  when N_Op_Rem =>
+                     Set_Do_Division_Check (N, False);
+
+                  when N_Op_Xor =>
+                     Set_Do_Length_Check (N, False);
+
+                  when others =>
+                     null;
+               end case;
+
+            when N_Or_Else =>
+               Discard := Traverse (Left_Opnd (N));
+               return Skip;
+
+            when N_Selected_Component =>
+               Set_Do_Access_Check (N, False);
+               Set_Do_Discriminant_Check (N, False);
+
+            when N_Slice =>
+               Set_Do_Access_Check (N, False);
+
+            when N_Type_Conversion =>
+               Set_Do_Length_Check (N, False);
+               Set_Do_Overflow_Check (N, False);
+               Set_Do_Tag_Check (N, False);
+
+            when others =>
+               null;
+         end case;
+
+         return OK;
+      end Process;
+
+   --  Start of processing for Remove_Checks
+
+   begin
+      Discard := Traverse (Expr);
+   end Remove_Checks;
+
    ----------------------------
    -- Selected_Length_Checks --
    ----------------------------
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index df2c4624359..e35e889e0bf 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -496,6 +496,11 @@ package Checks is
    --  the sense of the 'Valid attribute returning True. Constraint_Error
    --  will be raised if the value is not valid.
 
+   procedure Remove_Checks (Expr : Node_Id);
+   --  Remove all checks from Expr except those that are only executed
+   --  conditionally (on the right side of And Then/Or Else. This call
+   --  removes only embedded checks (Do_Range_Check, Do_Overflow_Check).
+
 private
 
    type Check_Result is array (Positive range 1 .. 2) of Node_Id;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index e9985533669..1acd0df0c2b 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -969,6 +969,42 @@ package body Exp_Util is
       return New_Copy_Tree (Exp);
    end Duplicate_Subexpr;
 
+   ---------------------------------
+   -- Duplicate_Subexpr_No_Checks --
+   ---------------------------------
+
+   function Duplicate_Subexpr_No_Checks
+     (Exp      : Node_Id;
+      Name_Req : Boolean := False)
+      return     Node_Id
+   is
+      New_Exp : Node_Id;
+
+   begin
+      Remove_Side_Effects (Exp, Name_Req);
+      New_Exp := New_Copy_Tree (Exp);
+      Remove_Checks (New_Exp);
+      return New_Exp;
+   end Duplicate_Subexpr_No_Checks;
+
+   -----------------------------------
+   -- Duplicate_Subexpr_Move_Checks --
+   -----------------------------------
+
+   function Duplicate_Subexpr_Move_Checks
+     (Exp      : Node_Id;
+      Name_Req : Boolean := False)
+      return     Node_Id
+   is
+      New_Exp : Node_Id;
+
+   begin
+      Remove_Side_Effects (Exp, Name_Req);
+      New_Exp := New_Copy_Tree (Exp);
+      Remove_Checks (Exp);
+      return New_Exp;
+   end Duplicate_Subexpr_Move_Checks;
+
    --------------------
    -- Ensure_Defined --
    --------------------
@@ -2310,7 +2346,8 @@ package body Exp_Util is
         Make_Op_Subtract (Loc,
           Left_Opnd =>
             Make_Attribute_Reference (Loc,
-              Prefix         => OK_Convert_To (T, Duplicate_Subexpr (E)),
+              Prefix =>
+                OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
               Attribute_Name => Name_Size),
           Right_Opnd =>
             Make_Attribute_Reference (Loc,
@@ -2452,7 +2489,9 @@ package body Exp_Util is
          Utyp        := Underlying_Type (Unc_Typ);
          Full_Subtyp := Make_Defining_Identifier (Loc,
                           New_Internal_Name ('C'));
-         Full_Exp    := Unchecked_Convert_To (Utyp, Duplicate_Subexpr (E));
+         Full_Exp    :=
+           Unchecked_Convert_To
+             (Utyp, Duplicate_Subexpr_No_Checks (E));
          Set_Parent (Full_Exp, Parent (E));
 
          Priv_Subtyp :=
@@ -2490,13 +2529,14 @@ package body Exp_Util is
               Make_Range (Loc,
                 Low_Bound =>
                   Make_Attribute_Reference (Loc,
-                    Prefix => Duplicate_Subexpr (E),
+                    Prefix => Duplicate_Subexpr_No_Checks (E),
                     Attribute_Name => Name_First,
                     Expressions => New_List (
                       Make_Integer_Literal (Loc, J))),
+
                 High_Bound =>
                   Make_Attribute_Reference (Loc,
-                    Prefix         => Duplicate_Subexpr (E),
+                    Prefix         => Duplicate_Subexpr_No_Checks (E),
                     Attribute_Name => Name_Last,
                     Expressions    => New_List (
                       Make_Integer_Literal (Loc, J)))));
@@ -2530,7 +2570,7 @@ package body Exp_Util is
 
             Append_To (List_Constr,
               Make_Selected_Component (Loc,
-                Prefix        => Duplicate_Subexpr (E),
+                Prefix        => Duplicate_Subexpr_No_Checks (E),
                 Selector_Name => New_Reference_To (D, Loc)));
 
             Next_Discriminant (D);
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 3c215b0f2d4..c83b97ef1e0 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -7,7 +7,7 @@
 --                                 S p e c                                  --
 --                                                                          --
 --                                                                          --
---          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2002 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- --
@@ -243,6 +243,32 @@ package Exp_Util is
    --  copy after it is attached to the tree. The Name_Req flag is set to
    --  ensure that the result is suitable for use in a context requiring a
    --  name (e.g. the prefix of an attribute reference).
+   --
+   --  Note that if there are any run time checks in Exp, these same checks
+   --  will be duplicated in the returned duplicated expression. The two
+   --  following functions allow this behavior to be modified.
+
+   function Duplicate_Subexpr_No_Checks
+     (Exp      : Node_Id;
+      Name_Req : Boolean := False)
+      return     Node_Id;
+   --  Identical in effect to Duplicate_Subexpr, except that Remove_Checks
+   --  is called on the result, so that the duplicated expression does not
+   --  include checks. This is appropriate for use when Exp, the original
+   --  expression is unconditionally elaborated before the duplicated
+   --  expression, so that there is no need to repeat any checks.
+
+   function Duplicate_Subexpr_Move_Checks
+     (Exp      : Node_Id;
+      Name_Req : Boolean := False)
+      return     Node_Id;
+   --  Identical in effect to Duplicate_Subexpr, except that Remove_Checks
+   --  is called on Exp after the duplication is complete, so that the
+   --  original expression does not include checks. In this case the result
+   --  returned (the duplicated expression) will retain the original checks.
+   --  This is appropriate for use when the duplicated expression is sure
+   --  to be elaborated before the original expression Exp, so that there
+   --  is no need to repeat the checks.
 
    procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id);
    --  This procedure ensures that type referenced by Typ is defined. For the
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 0b910a63aac..ba031b13f4c 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -32,6 +32,7 @@ with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
 with Eval_Fat; use Eval_Fat;
+with Exp_Util; use Exp_Util;
 with Nmake;    use Nmake;
 with Nlists;   use Nlists;
 with Opt;      use Opt;
@@ -127,14 +128,6 @@ package body Sem_Eval is
    -- Local Subprograms --
    -----------------------
 
-   function Constant_Array_Ref (Op : Node_Id) return Node_Id;
-   --  The caller has checked that Op is an array reference (i.e. that its
-   --  node kind is N_Indexed_Component). If the array reference is constant
-   --  at compile time, and yields a constant value of a discrete type, then
-   --  the expression node for the constant value is returned. otherwise Empty
-   --  is returned. This is used by Compile_Time_Known_Value, as well as by
-   --  Expr_Value and Expr_Rep_Value.
-
    function From_Bits (B : Bits; T : Entity_Id) return Uint;
    --  Converts a bit string of length B'Length to a Uint value to be used
    --  for a target of type T, which is a modular type. This procedure
@@ -730,7 +723,6 @@ package body Sem_Eval is
    function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
       K      : constant Node_Kind := Nkind (Op);
       CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
-      Val    : Node_Id;
 
    begin
       --  Never known at compile time if bad type or raises constraint error
@@ -800,17 +792,6 @@ package body Sem_Eval is
 
          elsif K = N_Attribute_Reference then
             return Attribute_Name (Op) = Name_Null_Parameter;
-
-         --  A reference to an element of a constant array may be constant.
-
-         elsif K = N_Indexed_Component then
-            Val := Constant_Array_Ref (Op);
-
-            if Present (Val) then
-               CV_Ent.N := Op;
-               CV_Ent.V := Expr_Value (Val);
-               return True;
-            end if;
          end if;
       end if;
 
@@ -908,58 +889,6 @@ package body Sem_Eval is
       end if;
    end Compile_Time_Known_Value_Or_Aggr;
 
-   ------------------------
-   -- Constant_Array_Ref --
-   ------------------------
-
-   function Constant_Array_Ref (Op : Node_Id) return Node_Id is
-   begin
-      if List_Length (Expressions (Op)) = 1
-        and then Is_Entity_Name (Prefix (Op))
-        and then Ekind (Entity (Prefix (Op))) = E_Constant
-      then
-         declare
-            Arr : constant Node_Id := Constant_Value (Entity (Prefix (Op)));
-            Sub : constant Node_Id := First (Expressions (Op));
-            Aty : constant Node_Id := Etype (Arr);
-
-            Lin : Nat;
-            --  Linear one's origin subscript value for array reference
-
-            Lbd : Node_Id;
-            --  Lower bound of the first array index
-
-            Elm : Node_Id;
-            --  Value from constant array
-
-         begin
-            if Ekind (Aty) = E_String_Literal_Subtype then
-               Lbd := String_Literal_Low_Bound (Aty);
-            else
-               Lbd := Type_Low_Bound (Etype (First_Index (Aty)));
-            end if;
-
-            if Compile_Time_Known_Value (Sub)
-              and then Nkind (Arr) = N_Aggregate
-              and then Compile_Time_Known_Value (Lbd)
-              and then Is_Discrete_Type (Component_Type (Aty))
-            then
-               Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
-
-               if List_Length (Expressions (Arr)) >= Lin then
-                  Elm := Pick (Expressions (Arr), Lin);
-
-                  if Compile_Time_Known_Value (Elm) then
-                     return Elm;
-                  end if;
-               end if;
-            end if;
-         end;
-      end if;
-
-      return Empty;
-   end Constant_Array_Ref;
-
    -----------------
    -- Eval_Actual --
    -----------------
@@ -1140,7 +1069,6 @@ package body Sem_Eval is
       end if;
 
       Set_Is_Static_Expression (N, Stat);
-
    end Eval_Arithmetic_Op;
 
    ----------------------------
@@ -1344,8 +1272,9 @@ package body Sem_Eval is
    -- Eval_Indexed_Component --
    ----------------------------
 
-   --  Indexed components are never static, so the only required processing
-   --  is to perform the check for non-static context on the index values.
+   --  Indexed components are never static, so we need to perform the check
+   --  for non-static context on the index values. Then, we check if the
+   --  value can be obtained at compile time, even though it is non-static.
 
    procedure Eval_Indexed_Component (N : Node_Id) is
       Expr : Node_Id;
@@ -1357,6 +1286,74 @@ package body Sem_Eval is
          Next (Expr);
       end loop;
 
+      --  See if this is a constant array reference
+
+      if List_Length (Expressions (N)) = 1
+        and then Is_Entity_Name (Prefix (N))
+        and then Ekind (Entity (Prefix (N))) = E_Constant
+        and then Present (Constant_Value (Entity (Prefix (N))))
+      then
+         declare
+            Loc : constant Source_Ptr := Sloc (N);
+            Arr : constant Node_Id    := Constant_Value (Entity (Prefix (N)));
+            Sub : constant Node_Id    := First (Expressions (N));
+
+            Atyp : Entity_Id;
+            --  Type of array
+
+            Lin : Nat;
+            --  Linear one's origin subscript value for array reference
+
+            Lbd : Node_Id;
+            --  Lower bound of the first array index
+
+            Elm : Node_Id;
+            --  Value from constant array
+
+         begin
+            Atyp := Etype (Arr);
+
+            if Is_Access_Type (Atyp) then
+               Atyp := Designated_Type (Atyp);
+            end if;
+
+            --  If we have an array type (we should have but perhaps there
+            --  are error cases where this is not the case), then see if we
+            --  can do a constant evaluation of the array reference.
+
+            if Is_Array_Type (Atyp) then
+               if Ekind (Atyp) = E_String_Literal_Subtype then
+                  Lbd := String_Literal_Low_Bound (Atyp);
+               else
+                  Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
+               end if;
+
+               if Compile_Time_Known_Value (Sub)
+                 and then Nkind (Arr) = N_Aggregate
+                 and then Compile_Time_Known_Value (Lbd)
+                 and then Is_Discrete_Type (Component_Type (Atyp))
+               then
+                  Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
+
+                  if List_Length (Expressions (Arr)) >= Lin then
+                     Elm := Pick (Expressions (Arr), Lin);
+
+                     --  If the resulting expression is compile time known,
+                     --  then we can rewrite the indexed component with this
+                     --  value, being sure to mark the result as non-static.
+                     --  We also reset the Sloc, in case this generates an
+                     --  error later on (e.g. 136'Access).
+
+                     if Compile_Time_Known_Value (Elm) then
+                        Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
+                        Set_Is_Static_Expression (N, False);
+                        Set_Sloc (N, Loc);
+                     end if;
+                  end if;
+               end if;
+            end if;
+         end;
+      end if;
    end Eval_Indexed_Component;
 
    --------------------------
@@ -2465,7 +2462,6 @@ package body Sem_Eval is
    function Expr_Rep_Value (N : Node_Id) return Uint is
       Kind : constant Node_Kind := Nkind (N);
       Ent  : Entity_Id;
-      Vexp : Node_Id;
 
    begin
       if Is_Entity_Name (N) then
@@ -2506,14 +2502,8 @@ package body Sem_Eval is
       then
          return Uint_0;
 
-      --  Array reference case
-
-      elsif Kind = N_Indexed_Component then
-         Vexp := Constant_Array_Ref (N);
-         pragma Assert (Present (Vexp));
-         return Expr_Rep_Value (Vexp);
-
       --  Otherwise must be character literal
+
       else
          pragma Assert (Kind = N_Character_Literal);
          Ent := Entity (N);
@@ -2541,7 +2531,6 @@ package body Sem_Eval is
       CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
       Ent    : Entity_Id;
       Val    : Uint;
-      Vexp   : Node_Id;
 
    begin
       --  If already in cache, then we know it's compile time known and
@@ -2593,13 +2582,6 @@ package body Sem_Eval is
       then
          Val := Uint_0;
 
-      --  Array reference case
-
-      elsif Kind = N_Indexed_Component then
-         Vexp := Constant_Array_Ref (N);
-         pragma Assert (Present (Vexp));
-         Val := Expr_Value (Vexp);
-
       --  Otherwise must be character literal
 
       else
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 5be30aabf4c..5c8c4a400bf 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -187,14 +187,16 @@ package body Sem_Util is
 
             Lo :=
               Make_Attribute_Reference (Loc,
-                Prefix         => Duplicate_Subexpr (Obj, Name_Req => True),
+                Prefix         =>
+                  Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
                 Attribute_Name => Name_First,
                 Expressions    => New_List (
                   Make_Integer_Literal (Loc, J)));
 
             Hi :=
               Make_Attribute_Reference (Loc,
-                Prefix         => Duplicate_Subexpr (Obj, Name_Req => True),
+                Prefix         =>
+                  Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
                 Attribute_Name => Name_Last,
                 Expressions    => New_List (
                   Make_Integer_Literal (Loc, J)));
@@ -226,7 +228,8 @@ package body Sem_Util is
          while Present (Discr) loop
             Append_To (Constraints,
               Make_Selected_Component (Loc,
-                Prefix => Duplicate_Subexpr (Obj),
+                Prefix =>
+                  Duplicate_Subexpr_No_Checks (Obj),
                 Selector_Name => New_Occurrence_Of (Discr, Loc)));
             Next_Discriminant (Discr);
          end loop;
@@ -2056,7 +2059,7 @@ package body Sem_Util is
                           Make_Component_Association (Sloc (Typ),
                             New_List
                               (New_Occurrence_Of (D, Sloc (Typ))),
-                            Duplicate_Subexpr (Node (C)));
+                            Duplicate_Subexpr_No_Checks (Node (C)));
                         exit Find_Constraint;
                      end if;