diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 15 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/decl.c | 75 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 40 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/array9.adb | 20 |
5 files changed, 118 insertions, 36 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 121aac7..b0112a1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +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-25 Olivier Hainquqe <hainque@adacore.com> Eric Botcazou <ebotcazou@adacore.com> diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 1e54f38..12d57bc 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -1852,7 +1852,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) 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_entity, tree gnu_expr, int definition) 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_entity, tree gnu_expr, int definition) 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_entity, tree gnu_expr, int definition) = 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_entity, tree gnu_expr, int definition) /* 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_entity, tree gnu_expr, int definition) /* 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_entity, tree gnu_expr, int definition) /* 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); - - /* 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)) + gnu_low = size_binop (PLUS_EXPR, gnu_max, size_one_node); + + /* 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_entity, tree gnu_expr, int definition) && 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; } diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 7037a6e..d94d1f4 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -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_node, int number_name, /* 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_node, int number_name, 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, tree gnu_type, int aliased) 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, tree gnu_type, int aliased) 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, tree gnu_type, int aliased) 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, tree gnu_type, int aliased) 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, tree *gnu_result_type_p) && !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, tree *gnu_result_type_p) 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 *gnu_result_type_p, tree gnu_target) 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b33eb1f..2bfffbe 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2009-09-26 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/array9.adb: New test. + 2009-09-26 Michael Matz <matz@suse.de> PR tree-optimization/41454 diff --git a/gcc/testsuite/gnat.dg/array9.adb b/gcc/testsuite/gnat.dg/array9.adb new file mode 100644 index 0000000..4a13876 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array9.adb @@ -0,0 +1,20 @@ +-- { 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; |