This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Improve folding of aggregates in gigi
- From: Eric Botcazou <ebotcazou at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Sun, 11 Apr 2010 13:49:13 +0200
- Subject: [Ada] Improve folding of aggregates in gigi
This comes from ACATS ca11c03: in some cases gigi doesn't fold construct
involving aggregates, although it could:
Tarsier : FA11C00_2.Primate := (Common_Name => "East-Indian Tarsier ",
Weight => 7,
Hair_Color => Brown,
Habitat => FA11C00_2.Arboreal);
TC_Result_String :=
Format_Primate_Data
(Name => FA11C00_2.Image (Tarsier),
Hair => Hair_Color_Type'Image(Tarsier.Hair_Color));
Tarsier.Hair_Color isn't folded because it is subject to the 'Image attribute.
Tested on i586-suse-linux, applied on the mainline.
2010-04-11 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (lvalue_required_for_attribute_p): New static
function.
(lvalue_required_p) <N_Attribute_Reference>: Call it.
(gnat_to_gnu) <N_Selected_Component>: Prevent build_component_ref from
folding the result only if lvalue_required_for_attribute_p is true.
* gcc-interface/utils.c (maybe_unconstrained_array): Pass correctly
typed constant to build_component_ref.
(unchecked_convert): Likewise.
* gcc-interface/utils2.c (maybe_wrap_malloc): Likewise.
(build_allocator): Likewise.
2010-04-11 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/pack9.adb: Remove -cargs option.
* gnat.dg/aggr12.ad[sb]: New test.
--
Eric Botcazou
Index: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c (revision 158159)
+++ gcc-interface/utils.c (working copy)
@@ -4274,12 +4274,13 @@ maybe_unconstrained_array (tree exp)
build_component_ref (new_exp, NULL_TREE,
TREE_CHAIN
(TYPE_FIELDS (TREE_TYPE (new_exp))),
- 0);
+ false);
}
else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
return
build_component_ref (exp, NULL_TREE,
- TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0);
+ TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))),
+ false);
break;
default:
@@ -4416,7 +4417,7 @@ unchecked_convert (tree type, tree expr,
layout_type (rec_type);
expr = unchecked_convert (rec_type, expr, notrunc_p);
- expr = build_component_ref (expr, NULL_TREE, field, 0);
+ expr = build_component_ref (expr, NULL_TREE, field, false);
}
/* Similarly if we are converting from an integral type whose precision
Index: gcc-interface/utils2.c
===================================================================
--- gcc-interface/utils2.c (revision 158201)
+++ gcc-interface/utils2.c (working copy)
@@ -1812,7 +1812,7 @@ maybe_wrap_malloc (tree data_size, tree
tree aligning_field
= build_component_ref (aligning_record, NULL_TREE,
- TYPE_FIELDS (aligning_type), 0);
+ TYPE_FIELDS (aligning_type), false);
tree aligning_field_addr
= build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field);
@@ -2003,7 +2003,7 @@ build_allocator (tree type, tree init, t
build_component_ref
(build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
- NULL_TREE, TYPE_FIELDS (storage_type), 0),
+ NULL_TREE, TYPE_FIELDS (storage_type), false),
build_template (template_type, type, NULL_TREE)),
convert (result_type, convert (storage_ptr_type, storage)));
}
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 158200)
+++ gcc-interface/trans.c (working copy)
@@ -655,6 +655,51 @@ gigi (Node_Id gnat_root, int max_gnat_no
error_gnat_node = Empty;
}
+/* Return a positive value if an lvalue is required for GNAT_NODE, which is
+ an N_Attribute_Reference. */
+
+static int
+lvalue_required_for_attribute_p (Node_Id gnat_node)
+{
+ switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
+ {
+ case Attr_Pos:
+ case Attr_Val:
+ case Attr_Pred:
+ case Attr_Succ:
+ case Attr_First:
+ case Attr_Last:
+ case Attr_Range_Length:
+ case Attr_Length:
+ case Attr_Object_Size:
+ case Attr_Value_Size:
+ case Attr_Component_Size:
+ case Attr_Max_Size_In_Storage_Elements:
+ case Attr_Min:
+ case Attr_Max:
+ case Attr_Null_Parameter:
+ case Attr_Passed_By_Reference:
+ case Attr_Mechanism_Code:
+ return 0;
+
+ case Attr_Address:
+ case Attr_Access:
+ case Attr_Unchecked_Access:
+ case Attr_Unrestricted_Access:
+ case Attr_Code_Address:
+ case Attr_Pool_Address:
+ case Attr_Size:
+ case Attr_Alignment:
+ case Attr_Bit_Position:
+ case Attr_Position:
+ case Attr_First_Bit:
+ case Attr_Last_Bit:
+ case Attr_Bit:
+ default:
+ return 1;
+ }
+}
+
/* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
is the type that will be used for GNAT_NODE in the translated GNU tree.
CONSTANT indicates whether the underlying object represented by GNAT_NODE
@@ -678,18 +723,7 @@ lvalue_required_p (Node_Id gnat_node, tr
return 1;
case N_Attribute_Reference:
- {
- unsigned char id = Get_Attribute_Id (Attribute_Name (gnat_parent));
- return id == Attr_Address
- || id == Attr_Access
- || id == Attr_Unchecked_Access
- || id == Attr_Unrestricted_Access
- || id == Attr_Bit_Position
- || id == Attr_Position
- || id == Attr_First_Bit
- || id == Attr_Last_Bit
- || id == Attr_Bit;
- }
+ return lvalue_required_for_attribute_p (gnat_parent);
case N_Parameter_Association:
case N_Function_Call:
@@ -3991,7 +4025,9 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result
= build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
(Nkind (Parent (gnat_node))
- == N_Attribute_Reference));
+ == N_Attribute_Reference)
+ && lvalue_required_for_attribute_p
+ (Parent (gnat_node)));
}
gcc_assert (gnu_result);
-- { dg-do compile }
-- { dg-options "-fdump-tree-original" }
package body Aggr12 is
procedure Print (Data : String) is
begin
null;
end;
procedure Test is
begin
Print (Hair_Color_Type'Image (A.I1));
Print (Hair_Color_Type'Image (A.I2));
end;
end Aggr12;
-- { dg-final { scan-tree-dump-not "{.i1=0, .i2=2}" "original" } }
-- { dg-final { cleanup-tree-dump "original" } }
package Aggr12 is
type Hair_Color_Type is (Black, Brown, Blonde, Grey, White, Red);
type Rec is record
I1, I2 : Hair_Color_Type;
end record;
A : constant Rec := (Black, Blonde);
procedure Print (Data : String);
procedure Test;
end Aggr12;