diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9246f26e09d544937447061e619e3b2b8086366d..5105950589c86218e459a5146ee3b84251fc1087 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 5442819566bf6589217442d27ae393ab43aaa07e..327f1cc751bca6c6cac53701378712cc7b979e1c 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 df2c4624359d07d5d0d8eacc6ac16cc71de0c519..e35e889e0bf0dde77f3c40ba5b046ebd72d96e08 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 e998553366921e10950411d4264cdbbd368b65a2..1acd0df0c2b328b317b9e01dd5654367728b8383 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 3c215b0f2d4986fa304a5c9c940e6ba50365c174..c83b97ef1e01a5f33e13db374debfc0d3c285b33 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 0b910a63aaca3d940bf0c4b3420fe094a8adcef3..ba031b13f4c72d3119601b82fbe28a8e5805adea 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 5be30aabf4c6d11d81660a18d5ea2a321600c87f..5c8c4a400bf6f8e3823be35ebe00f737e4ccba2f 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;