procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* checks.ads:

Browse source 
(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).

From-SVN: r51513
This commit is contained in:
Matthew Gingell 2002-03-28 15:33:09 +00:00
parent 792c4e7440
commit 8cbb664efd
7 changed files with 302 additions and 101 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
gcc/ada/ChangeLog
View file

@ -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.

98
gcc/ada/checks.adb
View file

@ -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 --
----------------------------

5
gcc/ada/checks.ads
View file

@ -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;

50
gcc/ada/exp_util.adb
View file

@ -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);

28
gcc/ada/exp_util.ads
View file

@ -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

164
gcc/ada/sem_eval.adb
View file

@ -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

11
gcc/ada/sem_util.adb
View file

@ -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;