gigi.h (build_simple_component_ref): Declare.

	* gcc-interface/gigi.h (build_simple_component_ref): Declare.
	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Deal with
	address clause on aliased object with unconstrained nominal subtype.
	Mark the aligning variable as artificial, do not convert the address
	expression immediately but mark it as constant instead.
	* gcc-interface/utils.c (convert): If the target type contains a
	template, be prepared for an empty array.
	(maybe_unconstrained_array): Likewise.
	* gcc-interface/utils2.c (known_alignment) <POINTER_PLUS_EXPR>: Deal
	with the pattern built for aligning types.
	<INTEGER_CST>: Do not cap the value at BIGGEST_ALIGNMENT.
	(build_simple_component_ref): Make public.
	If the base object is a constructor that contains a template, fold the
	result field by field.

From-SVN: r223912

gcc/ada/ChangeLog

+2015-06-01  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gcc-interface/gigi.h (build_simple_component_ref): Declare.
+	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Deal with
+	address clause on aliased object with unconstrained nominal subtype.
+	Mark the aligning variable as artificial, do not convert the address
+	expression immediately but mark it as constant instead.
+	* gcc-interface/utils.c (convert): If the target type contains a
+	template, be prepared for an empty array.
+	(maybe_unconstrained_array): Likewise.
+	* gcc-interface/utils2.c (known_alignment) <POINTER_PLUS_EXPR>: Deal
+	with the pattern built for aligning types.
+	<INTEGER_CST>: Do not cap the value at BIGGEST_ALIGNMENT.
+	(build_simple_component_ref): Make public.
+	If the base object is a constructor that contains a template, fold the
+	result field by field.
+
 2015-05-31  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* s-oscons-tmplt.c: Add explicit tests for Android alongside Linux.

gcc/ada/gcc-interface/decl.c

@@ -882,8 +882,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    check_ok_for_atomic_type (gnu_inner, gnat_entity, true);
 	  }
 
-	/* If this is an aliased object with an unconstrained nominal subtype,
-	   make a type that includes the template.  */
+	/* If this is an aliased object with an unconstrained array nominal
+	   subtype, make a type that includes the template.  We will either
+	   allocate or create a variable of that type, see below.  */
 	if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
 	    && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
 	    && !type_annotate_only)
@@ -1149,7 +1150,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	   effects in this case.  */
 	if (definition && Present (Address_Clause (gnat_entity)))
 	  {
-	    Node_Id gnat_expr = Expression (Address_Clause (gnat_entity));
+	    const Node_Id gnat_clause = Address_Clause (gnat_entity);
+	    Node_Id gnat_expr = Expression (gnat_clause);
 	    tree gnu_address
 	      = present_gnu_tree (gnat_entity)
 		? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
@@ -1167,6 +1169,40 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		|| compile_time_known_address_p (gnat_expr);
 	    gnu_size = NULL_TREE;
 
+	    /* If this is an aliased object with an unconstrained array nominal
+	       subtype, then it can overlay only another aliased object with an
+	       unconstrained array nominal subtype and compatible template.  */
+	    if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
+		&& Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
+		&& !type_annotate_only)
+	      {
+		tree rec_type = TREE_TYPE (gnu_type);
+		tree off = byte_position (DECL_CHAIN (TYPE_FIELDS (rec_type)));
+
+		/* This is the pattern built for a regular object.  */
+		if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
+		    && TREE_OPERAND (gnu_address, 1) == off)
+		  gnu_address = TREE_OPERAND (gnu_address, 0);
+		/* This is the pattern built for an overaligned object.  */
+		else if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
+			 && TREE_CODE (TREE_OPERAND (gnu_address, 1))
+			    == PLUS_EXPR
+			 && TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 1)
+			    == off)
+		  gnu_address
+		    = build2 (POINTER_PLUS_EXPR, gnu_type,
+			      TREE_OPERAND (gnu_address, 0),
+			      TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 0));
+		else
+		  {
+		    post_error_ne ("aliased object& with unconstrained array "
+				   "nominal subtype", gnat_clause,
+				   gnat_entity);
+		    post_error ("\\can overlay only aliased object with "
+				"compatible subtype", gnat_clause);
+		  }
+	      }
+
 	    /* If this is a deferred constant, the initializer is attached to
 	       the full view.  */
 	    if (kind == E_Constant && Present (Full_View (gnat_entity)))
@@ -1183,11 +1219,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    else
 	      gnu_expr
 		= build2 (COMPOUND_EXPR, gnu_type,
-			  build_binary_op
-			  (MODIFY_EXPR, NULL_TREE,
-			   build_unary_op (INDIRECT_REF, NULL_TREE,
-					   gnu_address),
-			   gnu_expr),
+			  build_binary_op (INIT_EXPR, NULL_TREE,
+					   build_unary_op (INDIRECT_REF,
+							   NULL_TREE,
+							   gnu_address),
+					   gnu_expr),
 			  gnu_address);
 	  }
 
@@ -1302,8 +1338,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	/* If this object would go into the stack and has an alignment larger
 	   than the largest stack alignment the back-end can honor, resort to
 	   a variable of "aligning type".  */
-	if (!global_bindings_p () && !static_p && definition
-	    && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
+	if (definition
+	    && !global_bindings_p ()
+	    && !static_p
+	    && !imported_p
+	    && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
 	  {
 	    /* Create the new variable.  No need for extra room before the
 	       aligned field as this is in automatic storage.  */
@@ -1315,11 +1354,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	      = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
 				 NULL_TREE, gnu_new_type, NULL_TREE, false,
 				 false, false, false, NULL, gnat_entity);
+	    DECL_ARTIFICIAL (gnu_new_var) = 1;
 
 	    /* Initialize the aligned field if we have an initializer.  */
 	    if (gnu_expr)
 	      add_stmt_with_node
-		(build_binary_op (MODIFY_EXPR, NULL_TREE,
+		(build_binary_op (INIT_EXPR, NULL_TREE,
 				  build_component_ref
 				  (gnu_new_var, NULL_TREE,
 				   TYPE_FIELDS (gnu_new_type), false),
@@ -1330,28 +1370,26 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    gnu_type = build_reference_type (gnu_type);
 	    gnu_expr
 	      = build_unary_op
-		(ADDR_EXPR, gnu_type,
+		(ADDR_EXPR, NULL_TREE,
 		 build_component_ref (gnu_new_var, NULL_TREE,
 				      TYPE_FIELDS (gnu_new_type), false));
+	    TREE_CONSTANT (gnu_expr) = 1;
 
 	    used_by_ref = true;
 	    const_flag = true;
 	    gnu_size = NULL_TREE;
 	  }
 
-	/* If this is an aliased object with an unconstrained nominal subtype,
-	   we make its type a thin reference, i.e. the reference counterpart
-	   of a thin pointer, so that it points to the array part.  This is
-	   aimed at making it easier for the debugger to decode the object.
-	   Note that we have to do that this late because of the couple of
-	   allocation adjustments that might be made just above.  */
+	/* If this is an aliased object with an unconstrained array nominal
+	   subtype, we make its type a thin reference, i.e. the reference
+	   counterpart of a thin pointer, so it points to the array part.
+	   This is aimed to make it easier for the debugger to decode the
+	   object.  Note that we have to do it this late because of the
+	   couple of allocation adjustments that might be made above.  */
 	if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
 	    && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
 	    && !type_annotate_only)
 	  {
-	    tree gnu_array
-	      = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
-
 	    /* In case the object with the template has already been allocated
 	       just above, we have nothing to do here.  */
 	    if (!TYPE_IS_THIN_POINTER_P (gnu_type))
@@ -1362,8 +1400,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 				      const_flag, Is_Public (gnat_entity),
 				      imported_p || !definition, static_p,
 				      NULL, gnat_entity);
-		gnu_expr
-		  = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
+		gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
 		TREE_CONSTANT (gnu_expr) = 1;
 
 		used_by_ref = true;
@@ -1372,6 +1409,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		gnu_size = NULL_TREE;
 	      }
 
+	    tree gnu_array
+	      = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
 	    gnu_type
 	      = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
 	  }

gcc/ada/gcc-interface/gigi.h

@@ -914,6 +914,11 @@ extern tree gnat_build_constructor (tree type, vec<constructor_elt, va_gc> *v);
 /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
    an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
    for the field, or both.  Don't fold the result if NO_FOLD_P.  */
+extern tree build_simple_component_ref (tree record_variable, tree component,
+					tree field, bool no_fold_p);
+
+/* Likewise, but generate a Constraint_Error if the reference could not be
+   found.  */
 extern tree build_component_ref (tree record_variable, tree component,
                                  tree field, bool no_fold_p);
 

gcc/ada/gcc-interface/utils.c

@@ -4092,8 +4092,9 @@ convert (tree type, tree expr)
       CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
 			      build_template (TREE_TYPE (TYPE_FIELDS (type)),
 					      obj_type, NULL_TREE));
-      CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
-			      convert (obj_type, expr));
+      if (expr)
+	CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
+				convert (obj_type, expr));
       return gnat_build_constructor (type, v);
     }
 
@@ -4699,14 +4700,13 @@ maybe_unconstrained_array (tree exp)
 
       if (TYPE_CONTAINS_TEMPLATE_P (type))
 	{
-	  exp = build_component_ref (exp, NULL_TREE,
-				     DECL_CHAIN (TYPE_FIELDS (type)),
-				     false);
-	  type = TREE_TYPE (exp);
+	  exp = build_simple_component_ref (exp, NULL_TREE,
+					    DECL_CHAIN (TYPE_FIELDS (type)),
+					    false);
 
 	  /* If the array type is padded, convert to the unpadded type.  */
-	  if (TYPE_IS_PADDING_P (type))
-	    exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
+	  if (exp && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
+	    exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
 	}
       break;
 

gcc/ada/gcc-interface/utils2.c

@@ -78,9 +78,9 @@ get_base_type (tree type)
   return type;
 }
 
-/* EXP is a GCC tree representing an address.  See if we can find how
-   strictly the object at that address is aligned.   Return that alignment
-   in bits.  If we don't know anything about the alignment, return 0.  */
+/* EXP is a GCC tree representing an address.  See if we can find how strictly
+   the object at this address is aligned and, if so, return the alignment of
+   the object in bits.  Otherwise return 0.  */
 
 unsigned int
 known_alignment (tree exp)
@@ -99,13 +99,13 @@ known_alignment (tree exp)
       break;
 
     case COMPOUND_EXPR:
-      /* The value of a COMPOUND_EXPR is that of it's second operand.  */
+      /* The value of a COMPOUND_EXPR is that of its second operand.  */
       this_alignment = known_alignment (TREE_OPERAND (exp, 1));
       break;
 
     case PLUS_EXPR:
     case MINUS_EXPR:
-      /* If two address are added, the alignment of the result is the
+      /* If two addresses are added, the alignment of the result is the
 	 minimum of the two alignments.  */
       lhs = known_alignment (TREE_OPERAND (exp, 0));
       rhs = known_alignment (TREE_OPERAND (exp, 1));
@@ -113,10 +113,20 @@ known_alignment (tree exp)
       break;
 
     case POINTER_PLUS_EXPR:
-      lhs = known_alignment (TREE_OPERAND (exp, 0));
-      rhs = known_alignment (TREE_OPERAND (exp, 1));
+      /* If this is the pattern built for aligning types, decode it.  */
+      if (TREE_CODE (TREE_OPERAND (exp, 1)) == BIT_AND_EXPR
+	  && TREE_CODE (TREE_OPERAND (TREE_OPERAND (exp, 1), 0)) == NEGATE_EXPR)
+	{
+	  tree op = TREE_OPERAND (TREE_OPERAND (exp, 1), 1);
+	  return
+	    known_alignment (fold_build1 (BIT_NOT_EXPR, TREE_TYPE (op), op));
+	}
+
       /* If we don't know the alignment of the offset, we assume that
 	 of the base.  */
+      lhs = known_alignment (TREE_OPERAND (exp, 0));
+      rhs = known_alignment (TREE_OPERAND (exp, 1));
+
       if (rhs == 0)
 	this_alignment = lhs;
       else
@@ -124,7 +134,7 @@ known_alignment (tree exp)
       break;
 
     case COND_EXPR:
-      /* If there is a choice between two values, use the smallest one.  */
+      /* If there is a choice between two values, use the smaller one.  */
       lhs = known_alignment (TREE_OPERAND (exp, 1));
       rhs = known_alignment (TREE_OPERAND (exp, 2));
       this_alignment = MIN (lhs, rhs);
@@ -135,7 +145,7 @@ known_alignment (tree exp)
 	unsigned HOST_WIDE_INT c = TREE_INT_CST_LOW (exp);
 	/* The first part of this represents the lowest bit in the constant,
 	   but it is originally in bytes, not bits.  */
-	this_alignment = MIN (BITS_PER_UNIT * (c & -c), BIGGEST_ALIGNMENT);
+	this_alignment = (c & -c) * BITS_PER_UNIT;
       }
       break;
 
@@ -172,7 +182,7 @@ known_alignment (tree exp)
 	  return known_alignment (t);
       }
 
-      /* Fall through... */
+      /* ... fall through ... */
 
     default:
       /* For other pointer expressions, we assume that the pointed-to object
@@ -1990,7 +2000,7 @@ gnat_build_constructor (tree type, vec<constructor_elt, va_gc> *v)
    We also handle the fact that we might have been passed a pointer to the
    actual record and know how to look for fields in variant parts.  */
 
-static tree
+tree
 build_simple_component_ref (tree record_variable, tree component, tree field,
 			    bool no_fold_p)
 {
@@ -2128,18 +2138,26 @@ build_simple_component_ref (tree record_variable, tree component, tree field,
   if (TREE_CODE (base) == CONSTRUCTOR
       && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (base)))
     {
-      vec<constructor_elt, va_gc> *elts = CONSTRUCTOR_ELTS (base);
-      unsigned HOST_WIDE_INT idx;
-      tree index, value;
-      FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value)
-	if (index == field)
-	  return value;
+      unsigned int len = CONSTRUCTOR_NELTS (base);
+      gcc_assert (len > 0);
+
+      if (field == CONSTRUCTOR_ELT (base, 0)->index)
+	return CONSTRUCTOR_ELT (base, 0)->value;
+
+      if (len > 1)
+	{
+	  if (field == CONSTRUCTOR_ELT (base, 1)->index)
+	    return CONSTRUCTOR_ELT (base, 1)->value;
+	}
+      else
+	return NULL_TREE;
+
       return ref;
     }
 
   return fold (ref);
 }
-
+
 /* Likewise, but generate a Constraint_Error if the reference could not be
    found.  */
 

gcc/testsuite/ChangeLog

+2015-06-01  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/addr9_1.adb: New test.
+	* gnat.dg/addr9_2.adb: Likewise.
+	* gnat.dg/addr9_3.adb: Likewise.
+	* gnat.dg/addr9_4.adb: Likewise.
+
 2015-05-31  Eric Botcazou  <ebotcazou@adacore.com>
 
 	  * g++.dg/other/dump-ada-spec-4.C: New test.

gcc/testsuite/gnat.dg/addr9_1.adb

+-- { dg-do compile }
+
+with Ada.Streams; use Ada.Streams;
+
+procedure Addr9_1 is
+
+   type Signal_Type is mod 2 ** 16;
+
+   type A_Item is record
+      I : Signal_Type;
+      Q : Signal_Type;
+   end record
+   with Size => 32;
+
+   for A_Item use record
+      I at 0 range 0 .. 15;
+      Q at 2 range 0 .. 15;
+   end record;
+
+   type A_Array_Type is
+     array (Positive range <>)
+     of A_Item
+   with Alignment => 16;
+
+   pragma Pack (A_Array_Type);
+
+   type B_Array_Type is new Ada.Streams.Stream_Element_Array
+   with Alignment => 16;
+
+   Ct_Count : constant := 7_000;
+
+   package Set is
+      A : aliased A_Array_Type := (1 .. Ct_Count => <>);
+      B : aliased B_Array_Type := (1 .. Ct_Count * A_Item'Size / 8 => <>);
+      for B'Address use A'Address;
+   end Set;
+
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/addr9_2.adb

+-- { dg-do compile }
+
+with Ada.Streams; use Ada.Streams;
+
+procedure Addr9_2 is
+
+   type Signal_Type is mod 2 ** 16;
+
+   type A_Item is record
+      I : Signal_Type;
+      Q : Signal_Type;
+   end record
+   with Size => 32;
+
+   for A_Item use record
+      I at 0 range 0 .. 15;
+      Q at 2 range 0 .. 15;
+   end record;
+
+   type A_Array_Type is
+     array (Positive range <>)
+     of A_Item
+   with Alignment => 16;
+
+   pragma Pack (A_Array_Type);
+
+   type B_Array_Type is new Ada.Streams.Stream_Element_Array
+   with Alignment => 16;
+
+   Ct_Count : constant := 7_000;
+
+   package Set is
+      A : A_Array_Type := (1 .. Ct_Count => <>);
+      B : aliased B_Array_Type := (1 .. Ct_Count * A_Item'Size / 8 => <>);
+      for B'Address use A'Address; -- { dg-warning "aliased object" }
+   end Set;
+
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/addr9_3.adb

+-- { dg-do compile }
+
+with Ada.Streams; use Ada.Streams;
+
+procedure Addr9_3 is
+
+   type Signal_Type is mod 2 ** 16;
+
+   type A_Item is record
+      I : Signal_Type;
+      Q : Signal_Type;
+   end record
+   with Size => 32;
+
+   for A_Item use record
+      I at 0 range 0 .. 15;
+      Q at 2 range 0 .. 15;
+   end record;
+
+   type A_Array_Type is
+     array (Positive range <>)
+     of A_Item
+   with Alignment => 16;
+
+   pragma Pack (A_Array_Type);
+
+   type B_Array_Type is new Ada.Streams.Stream_Element_Array
+   with Alignment => 16;
+
+   Ct_Count : constant := 7_000;
+
+   package Set is
+      A : aliased A_Array_Type := (1 .. Ct_Count => <>);
+      B : B_Array_Type := (1 .. Ct_Count * A_Item'Size / 8 => <>);
+      for B'Address use A'Address;
+   end Set;
+
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/addr9_4.adb

+-- { dg-do compile }
+
+with Ada.Streams; use Ada.Streams;
+
+procedure Addr9_4 is
+
+   type Signal_Type is mod 2 ** 16;
+
+   type A_Item is record
+      I : Signal_Type;
+      Q : Signal_Type;
+   end record
+   with Size => 32;
+
+   for A_Item use record
+      I at 0 range 0 .. 15;
+      Q at 2 range 0 .. 15;
+   end record;
+
+   type A_Array_Type is
+     array (Positive range <>)
+     of A_Item
+   with Alignment => 16;
+
+   pragma Pack (A_Array_Type);
+
+   type B_Array_Type is new Ada.Streams.Stream_Element_Array
+   with Alignment => 16;
+
+   Ct_Count : constant := 7_000;
+
+   package Set is
+      A : A_Array_Type := (1 .. Ct_Count => <>);
+      B : B_Array_Type := (1 .. Ct_Count * A_Item'Size / 8 => <>);
+      for B'Address use A'Address;
+   end Set;
+
+begin
+   null;
+end;