This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Patch: Constant_Array_Ref support for string literals.
- From: Matthew Gingell <gingell at gnat dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Thu, 28 Mar 2002 09:12:03 -0500
- Subject: [Ada] Patch: Constant_Array_Ref support for string literals.
This patch hasn't been reviewed and needs to be approved by an Ada
maintainer.
The following is Robert Dewer's work on Constant_Array_Ref support for
string literals, discussed recently under "[Ada] Bootstrapping mainline
GNAT fails."
Tested with bootstrap on i686-pc-linux-gnu.
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).
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.adb,v
retrieving revision 1.8
diff -c -r1.8 checks.adb
*** checks.adb 2002/03/14 10:59:05 1.8
--- checks.adb 2002/03/28 13:27:06
***************
*** 2918,2923 ****
--- 2918,3021 ----
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 --
----------------------------
Index: checks.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.ads,v
retrieving revision 1.3
diff -c -r1.3 checks.ads
*** checks.ads 2002/03/14 10:59:05 1.3
--- checks.ads 2002/03/28 13:27:06
***************
*** 496,501 ****
--- 496,506 ----
-- 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;
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.11
diff -c -r1.11 exp_util.adb
*** exp_util.adb 2002/03/14 10:59:15 1.11
--- exp_util.adb 2002/03/28 13:27:06
***************
*** 969,974 ****
--- 969,1010 ----
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,2316 ****
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
! Prefix => OK_Convert_To (T, Duplicate_Subexpr (E)),
Attribute_Name => Name_Size),
Right_Opnd =>
Make_Attribute_Reference (Loc,
--- 2346,2353 ----
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
! Prefix =>
! OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
Attribute_Name => Name_Size),
Right_Opnd =>
Make_Attribute_Reference (Loc,
***************
*** 2452,2458 ****
Utyp := Underlying_Type (Unc_Typ);
Full_Subtyp := Make_Defining_Identifier (Loc,
New_Internal_Name ('C'));
! Full_Exp := Unchecked_Convert_To (Utyp, Duplicate_Subexpr (E));
Set_Parent (Full_Exp, Parent (E));
Priv_Subtyp :=
--- 2489,2497 ----
Utyp := Underlying_Type (Unc_Typ);
Full_Subtyp := Make_Defining_Identifier (Loc,
New_Internal_Name ('C'));
! Full_Exp :=
! Unchecked_Convert_To
! (Utyp, Duplicate_Subexpr_No_Checks (E));
Set_Parent (Full_Exp, Parent (E));
Priv_Subtyp :=
***************
*** 2490,2502 ****
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
! Prefix => Duplicate_Subexpr (E),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J))),
High_Bound =>
Make_Attribute_Reference (Loc,
! Prefix => Duplicate_Subexpr (E),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J)))));
--- 2529,2542 ----
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
! 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_No_Checks (E),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J)))));
***************
*** 2530,2536 ****
Append_To (List_Constr,
Make_Selected_Component (Loc,
! Prefix => Duplicate_Subexpr (E),
Selector_Name => New_Reference_To (D, Loc)));
Next_Discriminant (D);
--- 2570,2576 ----
Append_To (List_Constr,
Make_Selected_Component (Loc,
! Prefix => Duplicate_Subexpr_No_Checks (E),
Selector_Name => New_Reference_To (D, Loc)));
Next_Discriminant (D);
Index: exp_util.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.ads,v
retrieving revision 1.5
diff -c -r1.5 exp_util.ads
*** exp_util.ads 2002/03/14 10:59:15 1.5
--- exp_util.ads 2002/03/28 13:27:06
***************
*** 7,13 ****
-- S p e c --
-- --
-- --
! -- Copyright (C) 1992-2001 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- --
--- 7,13 ----
-- S p e c --
-- --
-- --
! -- 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,248 ****
--- 243,274 ----
-- 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
Index: sem_eval.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_eval.adb,v
retrieving revision 1.6
diff -c -r1.6 sem_eval.adb
*** sem_eval.adb 2002/03/25 20:52:16 1.6
--- sem_eval.adb 2002/03/28 13:27:06
***************
*** 32,37 ****
--- 32,38 ----
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,140 ****
-- 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
--- 128,133 ----
***************
*** 730,736 ****
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
--- 723,728 ----
***************
*** 800,816 ****
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;
--- 792,797 ----
***************
*** 908,965 ****
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 --
-----------------
--- 889,894 ----
***************
*** 1140,1146 ****
end if;
Set_Is_Static_Expression (N, Stat);
-
end Eval_Arithmetic_Op;
----------------------------
--- 1069,1074 ----
***************
*** 1344,1351 ****
-- 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.
procedure Eval_Indexed_Component (N : Node_Id) is
Expr : Node_Id;
--- 1272,1280 ----
-- Eval_Indexed_Component --
----------------------------
! -- 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,1362 ****
--- 1286,1359 ----
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,2471 ****
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
--- 2462,2467 ----
***************
*** 2506,2519 ****
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);
--- 2502,2509 ----
then
return Uint_0;
-- Otherwise must be character literal
+
else
pragma Assert (Kind = N_Character_Literal);
Ent := Entity (N);
***************
*** 2541,2547 ****
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
--- 2531,2536 ----
***************
*** 2592,2604 ****
and then Attribute_Name (N) = Name_Null_Parameter
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
--- 2581,2586 ----
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.9
diff -c -r1.9 sem_util.adb
*** sem_util.adb 2002/03/14 11:00:14 1.9
--- sem_util.adb 2002/03/28 13:27:07
***************
*** 187,200 ****
Lo :=
Make_Attribute_Reference (Loc,
! Prefix => Duplicate_Subexpr (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),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J)));
--- 187,202 ----
Lo :=
Make_Attribute_Reference (Loc,
! 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_No_Checks (Obj, Name_Req => True),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J)));
***************
*** 226,232 ****
while Present (Discr) loop
Append_To (Constraints,
Make_Selected_Component (Loc,
! Prefix => Duplicate_Subexpr (Obj),
Selector_Name => New_Occurrence_Of (Discr, Loc)));
Next_Discriminant (Discr);
end loop;
--- 228,235 ----
while Present (Discr) loop
Append_To (Constraints,
Make_Selected_Component (Loc,
! Prefix =>
! Duplicate_Subexpr_No_Checks (Obj),
Selector_Name => New_Occurrence_Of (Discr, Loc)));
Next_Discriminant (Discr);
end loop;
***************
*** 2056,2062 ****
Make_Component_Association (Sloc (Typ),
New_List
(New_Occurrence_Of (D, Sloc (Typ))),
! Duplicate_Subexpr (Node (C)));
exit Find_Constraint;
end if;
--- 2059,2065 ----
Make_Component_Association (Sloc (Typ),
New_List
(New_Occurrence_Of (D, Sloc (Typ))),
! Duplicate_Subexpr_No_Checks (Node (C)));
exit Find_Constraint;
end if;