This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Improve handling of arrays
- From: Eric Botcazou <ebotcazou at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Sat, 26 Sep 2009 13:28:13 +0200
- Subject: [Ada] Improve handling of arrays
This patch improves the handling of arrays in gigi, both for the unconstrained
flavor by filter out negative size for the dimensions like in the constrained
case and for the constrained one by not creating an artificially non-constant
high bound if the low bound is non-constant.
It also enhances the lvalue_required_p predicate to make it more general.
Tested on i586-suse-linux, applied on the mainline.
2009-09-26 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Type>: Filter out
negative size for the array dimensions like in the constrained case.
<E_Array_Subtype>: Do not create an artificially non-constant high
bound if the low bound is non-constant. Minor tweaks.
* gcc-interface/trans.c (lvalue_required_p): Add CONSTANT parameter
and turn ALIASED into a boolean parameter. Adjust calls to self.
<N_Attribute_Reference>: Return 1 for more attributes.
<N_Object_Renaming_Declaration>: Return 1 for non-constant objects.
<N_Assignment_Statement>: Return 1 for the LHS.
(Identifier_to_gnu): Adjust calls to lvalue_required_p.
(call_to_gnu): Be prepared for wrapped boolean rvalues.
2009-09-26 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/array9.adb: New test.
--
Eric Botcazou
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 152199)
+++ gcc-interface/decl.c (working copy)
@@ -1852,7 +1852,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
char field_name[16];
tree gnu_index_base_type
= get_unpadded_type (Base_Type (Etype (gnat_index)));
- tree gnu_low_field, gnu_high_field, gnu_low, gnu_high;
+ tree gnu_low_field, gnu_high_field, gnu_low, gnu_high, gnu_max;
/* Make the FIELD_DECLs for the low and high bounds of this
type and then make extractions of these fields from the
@@ -1885,11 +1885,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
NULL_TREE);
TREE_READONLY (gnu_low) = TREE_READONLY (gnu_high) = 1;
+ /* Compute the size of this dimension. */
+ gnu_max
+ = build3 (COND_EXPR, gnu_index_base_type,
+ build2 (GE_EXPR, integer_type_node, gnu_high, gnu_low),
+ gnu_high,
+ build2 (MINUS_EXPR, gnu_index_base_type,
+ gnu_low, fold_convert (gnu_index_base_type,
+ integer_one_node)));
+
/* Make a range type with the new range in the Ada base type.
- Then make an index type with the new range in sizetype. */
+ Then make an index type with the size range in sizetype. */
gnu_index_types[index]
= create_index_type (convert (sizetype, gnu_low),
- convert (sizetype, gnu_high),
+ convert (sizetype, gnu_max),
create_range_type (gnu_index_base_type,
gnu_low, gnu_high),
gnat_entity);
@@ -2130,12 +2139,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
gnat_base_index = Next_Index (gnat_base_index))
{
tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
- tree prec = TYPE_RM_SIZE (gnu_index_type);
- const bool wider_p
- = (compare_tree_int (prec, TYPE_PRECISION (sizetype)) > 0
- || (compare_tree_int (prec, TYPE_PRECISION (sizetype)) == 0
- && TYPE_UNSIGNED (gnu_index_type)
- != TYPE_UNSIGNED (sizetype)));
+ const int prec_comp
+ = compare_tree_int (TYPE_RM_SIZE (gnu_index_type),
+ TYPE_PRECISION (sizetype));
+ const bool subrange_p = (prec_comp < 0)
+ || (prec_comp == 0
+ && TYPE_UNSIGNED (gnu_index_type)
+ == TYPE_UNSIGNED (sizetype));
+ const bool wider_p = (prec_comp > 0);
tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
tree gnu_min = convert (sizetype, gnu_orig_min);
@@ -2144,7 +2155,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
= get_unpadded_type (Etype (gnat_base_index));
tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
- tree gnu_high;
+ tree gnu_high, gnu_low;
/* See if the base array type is already flat. If it is, we
are probably compiling an ACATS test but it will cause the
@@ -2160,7 +2171,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
/* Similarly, if one of the values overflows in sizetype and the
range is null, use 1..0 for the sizetype bounds. */
- else if (wider_p
+ else if (!subrange_p
&& TREE_CODE (gnu_min) == INTEGER_CST
&& TREE_CODE (gnu_max) == INTEGER_CST
&& (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
@@ -2174,7 +2185,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
/* If the minimum and maximum values both overflow in sizetype,
but the difference in the original type does not overflow in
sizetype, ignore the overflow indication. */
- else if (wider_p
+ else if (!subrange_p
&& TREE_CODE (gnu_min) == INTEGER_CST
&& TREE_CODE (gnu_max) == INTEGER_CST
&& TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
@@ -2200,25 +2211,41 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
/* Otherwise, if we can prove that the low bound minus one and
the high bound cannot overflow, we can just use the expression
- MAX (hb, lb - 1). Otherwise, we have to use the most general
- expression (hb >= lb) ? hb : lb - 1. Note that the comparison
- must be done in the original index type, to avoid any overflow
- during the conversion. */
+ MAX (hb, lb - 1). Similarly, if we can prove that the high
+ bound plus one and the low bound cannot overflow, we can use
+ the high bound as-is and MIN (hb + 1, lb) for the low bound.
+ Otherwise, we have to fall back to the most general expression
+ (hb >= lb) ? hb : lb - 1. Note that the comparison must be
+ done in the original index type, to avoid any overflow during
+ the conversion. */
else
{
gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
+ gnu_low = size_binop (PLUS_EXPR, gnu_max, size_one_node);
- /* If gnu_high is a constant that has overflowed, the bound
- is the smallest integer so cannot be the maximum. */
- if (TREE_CODE (gnu_high) == INTEGER_CST
- && TREE_OVERFLOW (gnu_high))
+ /* If gnu_high is a constant that has overflowed, the low
+ bound is the smallest integer so cannot be the maximum.
+ If gnu_low is a constant that has overflowed, the high
+ bound is the highest integer so cannot be the minimum. */
+ if ((TREE_CODE (gnu_high) == INTEGER_CST
+ && TREE_OVERFLOW (gnu_high))
+ || (TREE_CODE (gnu_low) == INTEGER_CST
+ && TREE_OVERFLOW (gnu_low)))
gnu_high = gnu_max;
- /* If the index type is not wider and gnu_high is a constant
+ /* If the index type is a subrange and gnu_high a constant
that hasn't overflowed, we can use the maximum. */
- else if (!wider_p && TREE_CODE (gnu_high) == INTEGER_CST)
+ else if (subrange_p && TREE_CODE (gnu_high) == INTEGER_CST)
gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
+ /* If the index type is a subrange and gnu_low a constant
+ that hasn't overflowed, we can use the minimum. */
+ else if (subrange_p && TREE_CODE (gnu_low) == INTEGER_CST)
+ {
+ gnu_high = gnu_max;
+ gnu_min = size_binop (MIN_EXPR, gnu_min, gnu_low);
+ }
+
else
gnu_high
= build_cond_expr (sizetype,
@@ -2298,7 +2325,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
&& TREE_CODE (TREE_TYPE (gnu_index_type))
!= INTEGER_TYPE)
|| TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
- || compare_tree_int (prec, TYPE_PRECISION (sizetype)) > 0)
+ || wider_p)
need_index_type_struct = true;
}
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 152199)
+++ gcc-interface/trans.c (working copy)
@@ -217,7 +217,7 @@ static tree maybe_implicit_deref (tree);
static tree gnat_stabilize_reference (tree, bool);
static tree gnat_stabilize_reference_1 (tree, bool);
static void set_expr_location_from_node (tree, Node_Id);
-static int lvalue_required_p (Node_Id, tree, int);
+static int lvalue_required_p (Node_Id, tree, bool, bool);
/* Hooks for debug info back-ends, only supported and used in a restricted set
of configurations. */
@@ -659,8 +659,10 @@ gigi (Node_Id gnat_root, int max_gnat_no
/* 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. ALIASED indicates whether the underlying
- object represented by GNAT_NODE is aliased in the Ada sense.
+ translated GNU tree. CONSTANT indicates whether the underlying
+ object represented by GNAT_NODE is constant in the Ada sense,
+ ALIASED whether it is aliased (but the latter doesn't affect
+ the outcome if CONSTANT is not true).
The function climbs up the GNAT tree starting from the node and
returns 1 upon encountering a node that effectively requires an
@@ -668,7 +670,8 @@ gigi (Node_Id gnat_root, int max_gnat_no
usage in non purely binary logic contexts. */
static int
-lvalue_required_p (Node_Id gnat_node, tree gnu_type, int aliased)
+lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
+ bool aliased)
{
Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
@@ -683,7 +686,12 @@ lvalue_required_p (Node_Id gnat_node, tr
return id == Attr_Address
|| id == Attr_Access
|| id == Attr_Unchecked_Access
- || id == Attr_Unrestricted_Access;
+ || id == Attr_Unrestricted_Access
+ || id == Attr_Bit_Position
+ || id == Attr_Position
+ || id == Attr_First_Bit
+ || id == Attr_Last_Bit
+ || id == Attr_Bit;
}
case N_Parameter_Association:
@@ -714,11 +722,11 @@ lvalue_required_p (Node_Id gnat_node, tr
return 0;
aliased |= Has_Aliased_Components (Etype (gnat_node));
- return lvalue_required_p (gnat_parent, gnu_type, aliased);
+ return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
case N_Selected_Component:
aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
- return lvalue_required_p (gnat_parent, gnu_type, aliased);
+ return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
case N_Object_Renaming_Declaration:
/* We need to make a real renaming only if the constant object is
@@ -726,7 +734,8 @@ lvalue_required_p (Node_Id gnat_node, tr
optimize and return the rvalue. We make an exception if the object
is an identifier since in this case the rvalue can be propagated
attached to the CONST_DECL. */
- return (aliased != 0
+ return (!constant
+ || aliased
/* This should match the constant case of the renaming code. */
|| Is_Composite_Type
(Underlying_Type (Etype (Name (gnat_parent))))
@@ -741,8 +750,9 @@ lvalue_required_p (Node_Id gnat_node, tr
case N_Assignment_Statement:
/* We cannot use a constructor if the LHS is an atomic object because
the actual assignment might end up being done component-wise. */
- return Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
- && Is_Atomic (Entity (Name (gnat_parent)));
+ return (Name (gnat_parent) == gnat_node
+ || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
+ && Is_Atomic (Entity (Name (gnat_parent)))));
default:
return 0;
@@ -851,7 +861,7 @@ Identifier_to_gnu (Node_Id gnat_node, tr
&& !Is_Imported (gnat_temp)
&& Present (Address_Clause (gnat_temp)))
{
- require_lvalue = lvalue_required_p (gnat_node, gnu_result_type,
+ require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
Is_Aliased (gnat_temp));
use_constant_initializer = !require_lvalue;
}
@@ -957,7 +967,7 @@ Identifier_to_gnu (Node_Id gnat_node, tr
the CST value if an lvalue is not required. Evaluate this
now if we have not already done so. */
if (object && require_lvalue < 0)
- require_lvalue = lvalue_required_p (gnat_node, gnu_result_type,
+ require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
Is_Aliased (gnat_temp));
if (!object || !require_lvalue)
@@ -2931,6 +2941,12 @@ call_to_gnu (Node_Id gnat_node, tree *gn
gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
}
+ /* Undo wrapping of boolean rvalues. */
+ if (TREE_CODE (gnu_actual) == NE_EXPR
+ && TREE_CODE (get_base_type (TREE_TYPE (gnu_actual)))
+ == BOOLEAN_TYPE
+ && integer_zerop (TREE_OPERAND (gnu_actual, 1)))
+ gnu_actual = TREE_OPERAND (gnu_actual, 0);
gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_actual, gnu_result);
set_expr_location_from_node (gnu_result, gnat_node);
-- { dg-do run }
procedure Array9 is
V1 : String(1..10) := "1234567890";
V2 : String(1..-1) := "";
procedure Compare (S : String) is
begin
if S'Size /= 8*S'Length then
raise Program_Error;
end if;
end;
begin
Compare ("");
Compare ("1234");
Compare (V1);
Compare (V2);
end;