decl.c (gnat_to_gnu_entity): Filter out negative size for the array dimensions…

decl.c (gnat_to_gnu_entity): Filter out negative size for the array dimensions like in the constrained case.

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

From-SVN: r152201

gcc/ada/ChangeLog

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

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

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

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gnat.dg/array9.adb

+-- { 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;