decl.c (gnat_to_gnu_entity): Rewrite the handling of constrained discriminated record subtypes.

	* decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Rewrite the handling
	of constrained discriminated record subtypes.
	(components_to_record): Declare the type of the variants and of the
	qualified union.
	(build_subst_list): Move around.
	(compute_field_positions): Rename into...
	(build_position_list): ...this.  Return a TREE_VEC.
	(annotate_rep): Adjust for above renaming.
	(build_variant_list): New static function.
	(create_field_decl_from): Likewise.
	(get_rep_part): Likewise.
	(get_variant_part): Likewise.
	(create_variant_part_from): Likewise.
	(copy_and_substitute_in_size): Likewise.

From-SVN: r152272

1 files changed, 479 insertions, 159 deletions

diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 12d57bc..179418e 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -122,7 +122,6 @@ enum alias_set_op
 
 static void relate_alias_sets (tree, tree, enum alias_set_op);
 
-static tree build_subst_list (Entity_Id, Entity_Id, bool);
 static bool allocatable_size_p (tree, bool);
 static void prepend_one_attribute_to (struct attrib **,
 				      enum attr_type, tree, tree, Node_Id);
@@ -142,14 +141,21 @@ static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
 				  bool, bool, bool, bool, bool);
 static Uint annotate_value (tree);
 static void annotate_rep (Entity_Id, tree);
-static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
+static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
+static tree build_subst_list (Entity_Id, Entity_Id, bool);
+static tree build_variant_list (tree, tree, tree);
 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
 static void set_rm_size (Uint, tree, Entity_Id);
 static tree make_type_from_size (tree, tree, bool);
 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
 static void check_ok_for_atomic (tree, Entity_Id, bool);
-static int compatible_signatures_p (tree ftype1, tree ftype2);
+static int compatible_signatures_p (tree, tree);
+static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
+static tree get_rep_part (tree);
+static tree get_variant_part (tree);
+static tree create_variant_part_from (tree, tree, tree, tree, tree);
+static void copy_and_substitute_in_size (tree, tree, tree);
 static void rest_of_type_decl_compilation_no_defer (tree);
 
 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
@@ -3085,9 +3091,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    }
 
 	  /* When the subtype has discriminants and these discriminants affect
-	     the initial shape it has inherited, factor them in.  But for the
-	     of an Unchecked_Union (it must be an Itype), just return the type.
-
+	     the initial shape it has inherited, factor them in.  But for an
+	     Unchecked_Union (it must be an Itype), just return the type.
 	     We can't just test Is_Constrained because private subtypes without
 	     discriminants of types with discriminants with default expressions
 	     are Is_Constrained but aren't constrained!  */
@@ -3101,43 +3106,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    {
 	      tree gnu_subst_list
 		= build_subst_list (gnat_entity, gnat_base_type, definition);
-	      tree gnu_pos_list, gnu_field_list = NULL_TREE;
-	      tree gnu_unpad_base_type, t;
+	      tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
+	      tree gnu_variant_list, gnu_pos_list, gnu_field_list = NULL_TREE;
+	      bool selected_variant = false;
 	      Entity_Id gnat_field;
 
 	      gnu_type = make_node (RECORD_TYPE);
 	      TYPE_NAME (gnu_type) = gnu_entity_name;
 
 	      /* Set the size, alignment and alias set of the new type to
-		 match that of the old one, doing required substitutions.
-		 We do it this early because we need the size of the new
-		 type below to discard old fields if necessary.  */
-	      TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
-	      TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
-	      SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
-	      TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
-	      relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
-
-	      if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
-		for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
-		  TYPE_SIZE (gnu_type)
-		    = substitute_in_expr (TYPE_SIZE (gnu_type),
-					  TREE_PURPOSE (t),
-					  TREE_VALUE (t));
-
-	      if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
-		for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
-		  TYPE_SIZE_UNIT (gnu_type)
-		    = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
-					  TREE_PURPOSE (t),
-					  TREE_VALUE (t));
-
-	      if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
-		for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
-		  SET_TYPE_ADA_SIZE
-		    (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
-						   TREE_PURPOSE (t),
-						   TREE_VALUE (t)));
+		 match that of the old one, doing required substitutions.  */
+	      copy_and_substitute_in_size (gnu_type, gnu_base_type,
+					   gnu_subst_list);
 
 	      if (TREE_CODE (gnu_base_type) == RECORD_TYPE
 		  && TYPE_IS_PADDING_P (gnu_base_type))
@@ -3145,10 +3125,57 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	      else
 		gnu_unpad_base_type = gnu_base_type;
 
+	      /* Look for a REP part in the base type.  */
+	      gnu_rep_part = get_rep_part (gnu_unpad_base_type);
+
+	      /* Look for a variant part in the base type.  */
+	      gnu_variant_part = get_variant_part (gnu_unpad_base_type);
+
+	      /* If there is a variant part, we must compute whether the
+		 constraints statically select a particular variant.  If
+		 so, we simply drop the qualified union and flatten the
+		 list of fields.  Otherwise we'll build a new qualified
+		 union for the variants that are still relevant.  */
+	      if (gnu_variant_part)
+		{
+		  gnu_variant_list
+		    = build_variant_list (TREE_TYPE (gnu_variant_part),
+					  gnu_subst_list, NULL_TREE);
+
+		  /* If all the qualifiers are unconditionally true, the
+		     innermost variant is statically selected.  */
+		  selected_variant = true;
+		  for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
+		    if (!integer_onep (TREE_VEC_ELT (TREE_VALUE (t), 1)))
+		      {
+			selected_variant = false;
+			break;
+		      }
+
+		  /* Otherwise, create the new variants.  */
+		  if (!selected_variant)
+		    for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
+		      {
+			tree old_variant = TREE_PURPOSE (t);
+			tree new_variant = make_node (RECORD_TYPE);
+			TYPE_NAME (new_variant)
+			  = DECL_NAME (TYPE_NAME (old_variant));
+			copy_and_substitute_in_size (new_variant, old_variant,
+						     gnu_subst_list);
+			TREE_VEC_ELT (TREE_VALUE (t), 2) = new_variant;
+		      }
+		}
+	      else
+		{
+		  gnu_variant_list = NULL_TREE;
+		  selected_variant = false;
+		}
+
 	      gnu_pos_list
-		= compute_field_positions (gnu_unpad_base_type, NULL_TREE,
-					   size_zero_node, bitsize_zero_node,
-					   BIGGEST_ALIGNMENT);
+		= build_position_list (gnu_unpad_base_type,
+				       gnu_variant_list && !selected_variant,
+				       size_zero_node, bitsize_zero_node,
+				       BIGGEST_ALIGNMENT, NULL_TREE);
 
 	      for (gnat_field = First_Entity (gnat_entity);
 		   Present (gnat_field);
@@ -3166,16 +3193,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		      = Original_Record_Component (gnat_field);
 		    tree gnu_old_field
 		      = gnat_to_gnu_field_decl (gnat_old_field);
-		    tree gnu_offset
-		      = TREE_VALUE
-			(purpose_member (gnu_old_field, gnu_pos_list));
-		    tree gnu_pos = TREE_PURPOSE (gnu_offset);
-		    tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
-		    tree gnu_field, gnu_field_type, gnu_size, gnu_new_pos;
-		    tree gnu_last = NULL_TREE;
-		    unsigned int offset_align
-		      = tree_low_cst
-			(TREE_PURPOSE (TREE_VALUE (gnu_offset)), 1);
+		    tree gnu_context = DECL_CONTEXT (gnu_old_field);
+		    tree gnu_field, gnu_field_type, gnu_size;
+		    tree gnu_cont_type, gnu_last = NULL_TREE;
 
 		    /* If the type is the same, retrieve the GCC type from the
 		       old field to take into account possible adjustments.  */
@@ -3219,67 +3239,50 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		    else
 		      gnu_size = TYPE_SIZE (gnu_field_type);
 
-		    if (CONTAINS_PLACEHOLDER_P (gnu_pos))
-		      for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
-			gnu_pos = substitute_in_expr (gnu_pos,
-						      TREE_PURPOSE (t),
-						      TREE_VALUE (t));
-
-		    /* If the position is now a constant, we can set it as the
-		       position of the field when we make it.  Otherwise, we
-		       need to deal with it specially below.  */
-		    if (TREE_CONSTANT (gnu_pos))
+		    /* If the context of the old field is the base type or its
+		       REP part (if any), put the field directly in the new
+		       type; otherwise look up the context in the variant list
+		       and put the field either in the new type if there is a
+		       selected variant or in one of the new variants.  */
+		    if (gnu_context == gnu_unpad_base_type
+		        || (gnu_rep_part
+			    && gnu_context == TREE_TYPE (gnu_rep_part)))
+		      gnu_cont_type = gnu_type;
+		    else
 		      {
-		        gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
-
-			/* Discard old fields that are outside the new type.
-			   This avoids confusing code scanning it to decide
-			   how to pass it to functions on some platforms.  */
-			if (TREE_CODE (gnu_new_pos) == INTEGER_CST
-			    && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST
-			    && !integer_zerop (gnu_size)
-			    && !tree_int_cst_lt (gnu_new_pos,
-						 TYPE_SIZE (gnu_type)))
+			t = purpose_member (gnu_context, gnu_variant_list);
+			if (t)
+			  {
+			    if (selected_variant)
+			      gnu_cont_type = gnu_type;
+			    else
+			      gnu_cont_type = TREE_VEC_ELT (TREE_VALUE (t), 2);
+			  }
+			else
+			  /* The front-end may pass us "ghost" components if
+			     it fails to recognize that a constrained subtype
+			     is statically constrained.  Discard them.  */
 			  continue;
 		      }
-		    else
-		      gnu_new_pos = NULL_TREE;
 
+		    /* Now create the new field modeled on the old one.  */
 		    gnu_field
-		      = create_field_decl
-			(DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
-			 DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos,
-			 !DECL_NONADDRESSABLE_P (gnu_old_field));
+		      = create_field_decl_from (gnu_old_field, gnu_field_type,
+						gnu_cont_type, gnu_size,
+						gnu_pos_list, gnu_subst_list);
 
-		    if (!TREE_CONSTANT (gnu_pos))
+		    /* Put it in one of the new variants directly.  */
+		    if (gnu_cont_type != gnu_type)
 		      {
-			normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
-			DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
-			DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
-			SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
-			DECL_SIZE (gnu_field) = gnu_size;
-			DECL_SIZE_UNIT (gnu_field)
-			  = convert (sizetype,
-				     size_binop (CEIL_DIV_EXPR, gnu_size,
-						 bitsize_unit_node));
-			layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
+			TREE_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
+			TYPE_FIELDS (gnu_cont_type) = gnu_field;
 		      }
 
-		    DECL_INTERNAL_P (gnu_field)
-		      = DECL_INTERNAL_P (gnu_old_field);
-		    SET_DECL_ORIGINAL_FIELD
-		      (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
-				   ? DECL_ORIGINAL_FIELD (gnu_old_field)
-				   : gnu_old_field));
-		    DECL_DISCRIMINANT_NUMBER (gnu_field)
-		      = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
-		    TREE_THIS_VOLATILE (gnu_field)
-		      = TREE_THIS_VOLATILE (gnu_old_field);
-
 		    /* To match the layout crafted in components_to_record,
 		       if this is the _Tag or _Parent field, put it before
 		       any other fields.  */
-		    if (gnat_name == Name_uTag || gnat_name == Name_uParent)
+		    else if (gnat_name == Name_uTag
+			     || gnat_name == Name_uParent)
 		      gnu_field_list = chainon (gnu_field_list, gnu_field);
 
 		    /* Similarly, if this is the _Controller field, put
@@ -3304,6 +3307,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		    save_gnu_tree (gnat_field, gnu_field, false);
 		  }
 
+	      /* If there is a variant list and no selected variant, we need
+		 to create the nest of variant parts from the old nest.  */
+	      if (gnu_variant_list && !selected_variant)
+		{
+		  tree new_variant_part
+		    = create_variant_part_from (gnu_variant_part,
+						gnu_variant_list, gnu_type,
+						gnu_pos_list, gnu_subst_list);
+		  TREE_CHAIN (new_variant_part) = gnu_field_list;
+		  gnu_field_list = new_variant_part;
+		}
+
 	      /* Now go through the entities again looking for Itypes that
 		 we have not elaborated but should (e.g., Etypes of fields
 		 that have Original_Components).  */
@@ -3318,11 +3333,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	      gnu_field_list = nreverse (gnu_field_list);
 	      finish_record_type (gnu_type, gnu_field_list, 2, true);
 
-	      /* Finalize size and mode.  */
-	      TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type));
-	      TYPE_SIZE_UNIT (gnu_type)
-		= variable_size (TYPE_SIZE_UNIT (gnu_type));
-
 	      /* See the E_Record_Type case for the rationale.  */
 	      if (Is_Tagged_Type (gnat_entity)
 		  || Is_Limited_Record (gnat_entity))
@@ -5549,37 +5559,6 @@ relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
   record_component_aliases (gnu_new_type);
 }
 
-/* Return a TREE_LIST describing the substitutions needed to reflect the
-   discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE.  They can
-   be in any order.  TREE_PURPOSE gives the tree for the discriminant and
-   TREE_VALUE is the replacement value.  They are in the form of operands
-   to substitute_in_expr.  DEFINITION is true if this is for a definition
-   of GNAT_SUBTYPE.  */
-
-static tree
-build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
-{
-  tree gnu_list = NULL_TREE;
-  Entity_Id gnat_discrim;
-  Node_Id gnat_value;
-
-  for (gnat_discrim = First_Stored_Discriminant (gnat_type),
-       gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
-       Present (gnat_discrim);
-       gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
-       gnat_value = Next_Elmt (gnat_value))
-    /* Ignore access discriminants.  */
-    if (!Is_Access_Type (Etype (Node (gnat_value))))
-      gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
-			    elaborate_expression
-			    (Node (gnat_value), gnat_subtype,
-			     get_entity_name (gnat_discrim), definition,
-			     true, false),
-			    gnu_list);
-
-  return gnu_list;
-}
-
 /* Return true if the size represented by GNU_SIZE can be handled by an
    allocation.  If STATIC_P is true, consider only what can be done with a
    static allocation.  */
@@ -6959,6 +6938,8 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
 		 otherwise, the union type definition will be lacking
 		 the fields associated with these empty variants.  */
 	      rest_of_record_type_compilation (gnu_variant_type);
+	      create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
+				NULL, true, debug_info_p, gnat_component_list);
 
 	      gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
 					     gnu_union_type, field_packed,
@@ -7005,6 +6986,9 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
 	      return;
 	    }
 
+	  create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
+			    NULL, true, debug_info_p, gnat_component_list);
+
 	  /* Deal with packedness like in gnat_to_gnu_field.  */
 	  union_field_packed
 	    = adjust_packed (gnu_union_type, gnu_record_type, packed);
@@ -7310,8 +7294,9 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type)
 
   /* We operate by first making a list of all fields and their position (we
      can get the size easily) and then update all the sizes in the tree.  */
-  gnu_list = compute_field_positions (gnu_type, NULL_TREE, size_zero_node,
-				      bitsize_zero_node, BIGGEST_ALIGNMENT);
+  gnu_list
+    = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
+			   BIGGEST_ALIGNMENT, NULL_TREE);
 
   for (gnat_field = First_Entity (gnat_entity);
        Present (gnat_field);
@@ -7346,9 +7331,8 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type)
 	      (gnat_field,
 	       annotate_value
 		 (size_binop (PLUS_EXPR,
-			      bit_from_pos (TREE_PURPOSE (TREE_VALUE (t)),
-					    TREE_VALUE (TREE_VALUE
-							(TREE_VALUE (t)))),
+			      bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
+					    TREE_VEC_ELT (TREE_VALUE (t), 2)),
 			      parent_offset)));
 
 	    Set_Esize (gnat_field,
@@ -7368,17 +7352,17 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type)
       }
 }
 
-/* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
-   FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
-   position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
-   placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position.  GNU_POS is
-   to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
-   the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
-   so far.  */
+/* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
+   the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
+   value to be placed into DECL_OFFSET_ALIGN and the bit position.  The list
+   of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
+   is set to true.  GNU_POS is to be added to the position, GNU_BITPOS to the
+   bit position, OFFSET_ALIGN is the present offset alignment.  GNU_LIST is a
+   pre-existing list to be chained to the newly created entries.  */
 
 static tree
-compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
-			 tree gnu_bitpos, unsigned int offset_align)
+build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
+		     tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
 {
   tree gnu_field;
 
@@ -7392,20 +7376,109 @@ compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
 					DECL_FIELD_OFFSET (gnu_field));
       unsigned int our_offset_align
 	= MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
+      tree v = make_tree_vec (3);
 
-      gnu_list
-	= tree_cons (gnu_field,
-		     tree_cons (gnu_our_offset,
-				tree_cons (size_int (our_offset_align),
-					   gnu_our_bitpos, NULL_TREE),
-				NULL_TREE),
-		     gnu_list);
+      TREE_VEC_ELT (v, 0) = gnu_our_offset;
+      TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
+      TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
+      gnu_list = tree_cons (gnu_field, v, gnu_list);
 
+      /* Recurse on internal fields, flattening the nested fields except for
+	 those in the variant part, if requested.  */
       if (DECL_INTERNAL_P (gnu_field))
-	gnu_list
-	  = compute_field_positions (TREE_TYPE (gnu_field), gnu_list,
+	{
+	  tree gnu_field_type = TREE_TYPE (gnu_field);
+	  if (do_not_flatten_variant
+	      && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
+	    gnu_list
+	      = build_position_list (gnu_field_type, do_not_flatten_variant,
+				     size_zero_node, bitsize_zero_node,
+				     BIGGEST_ALIGNMENT, gnu_list);
+	  else
+	    gnu_list
+	      = build_position_list (gnu_field_type, do_not_flatten_variant,
 				     gnu_our_offset, gnu_our_bitpos,
-				     our_offset_align);
+				     our_offset_align, gnu_list);
+	}
+    }
+
+  return gnu_list;
+}
+
+/* Return a TREE_LIST describing the substitutions needed to reflect the
+   discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE.  They can
+   be in any order.  TREE_PURPOSE gives the tree for the discriminant and
+   TREE_VALUE is the replacement value.  They are in the form of operands
+   to SUBSTITUTE_IN_EXPR.  DEFINITION is true if this is for a definition
+   of GNAT_SUBTYPE.  */
+
+static tree
+build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
+{
+  tree gnu_list = NULL_TREE;
+  Entity_Id gnat_discrim;
+  Node_Id gnat_value;
+
+  for (gnat_discrim = First_Stored_Discriminant (gnat_type),
+       gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
+       Present (gnat_discrim);
+       gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
+       gnat_value = Next_Elmt (gnat_value))
+    /* Ignore access discriminants.  */
+    if (!Is_Access_Type (Etype (Node (gnat_value))))
+      gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
+			    elaborate_expression
+			    (Node (gnat_value), gnat_subtype,
+			     get_entity_name (gnat_discrim), definition,
+			     true, false),
+			    gnu_list);
+
+  return gnu_list;
+}
+
+/* Scan all fields in QUAL_UNION_TYPE and return a TREE_LIST describing the
+   variants of QUAL_UNION_TYPE that are still relevant after applying the
+   substitutions described in SUBST_LIST.  TREE_PURPOSE is the type of the
+   variant and TREE_VALUE is a TREE_VEC containing the field, the new value
+   of the qualifier and NULL_TREE respectively.  GNU_LIST is a pre-existing
+   list to be chained to the newly created entries.  */
+
+static tree
+build_variant_list (tree qual_union_type, tree subst_list, tree gnu_list)
+{
+  tree gnu_field;
+
+  for (gnu_field = TYPE_FIELDS (qual_union_type);
+       gnu_field;
+       gnu_field = TREE_CHAIN (gnu_field))
+    {
+      tree t, qual = DECL_QUALIFIER (gnu_field);
+
+      for (t = subst_list; t; t = TREE_CHAIN (t))
+	qual = SUBSTITUTE_IN_EXPR (qual, TREE_PURPOSE (t), TREE_VALUE (t));
+
+      /* If the new qualifier is not unconditionally false, its variant may
+	 still be accessed.  */
+      if (!integer_zerop (qual))
+	{
+	  tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
+	  tree v = make_tree_vec (3);
+	  TREE_VEC_ELT (v, 0) = gnu_field;
+	  TREE_VEC_ELT (v, 1) = qual;
+	  TREE_VEC_ELT (v, 2) = NULL_TREE;
+	  gnu_list = tree_cons (variant_type, v, gnu_list);
+
+	  /* Recurse on the variant subpart of the variant, if any.  */
+	  variant_subpart = get_variant_part (variant_type);
+	  if (variant_subpart)
+	    gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
+					   subst_list, gnu_list);
+
+	  /* If the new qualifier is unconditionally true, the subsequent
+	     variants cannot be accessed.  */
+	  if (integer_onep (qual))
+	    break;
+	}
     }
 
   return gnu_list;
@@ -7916,6 +7989,253 @@ compatible_signatures_p (tree ftype1, tree ftype2)
   return 1;
 }
 
+/* Return a FIELD_DECL node modeled on OLD_FIELD.  FIELD_TYPE is its type
+   and RECORD_TYPE is the type of the parent.  If SIZE is nonzero, it is the
+   specified size for this field.  POS_LIST is a position list describing
+   the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
+   to this layout.  */
+
+static tree
+create_field_decl_from (tree old_field, tree field_type, tree record_type,
+			tree size, tree pos_list, tree subst_list)
+{
+  tree t = TREE_VALUE (purpose_member (old_field, pos_list));
+  tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
+  unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
+  tree new_pos, new_field;
+
+  if (CONTAINS_PLACEHOLDER_P (pos))
+    for (t = subst_list; t; t = TREE_CHAIN (t))
+      pos = SUBSTITUTE_IN_EXPR (pos, TREE_PURPOSE (t), TREE_VALUE (t));
+
+  /* If the position is now a constant, we can set it as the position of the
+     field when we make it.  Otherwise, we need to deal with it specially.  */
+  if (TREE_CONSTANT (pos))
+    new_pos = bit_from_pos (pos, bitpos);
+  else
+    new_pos = NULL_TREE;
+
+  new_field
+    = create_field_decl (DECL_NAME (old_field), field_type, record_type,
+			 DECL_PACKED (old_field), size, new_pos,
+			 !DECL_NONADDRESSABLE_P (old_field));
+
+  if (!new_pos)
+    {
+      normalize_offset (&pos, &bitpos, offset_align);
+      DECL_FIELD_OFFSET (new_field) = pos;
+      DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
+      SET_DECL_OFFSET_ALIGN (new_field, offset_align);
+      DECL_SIZE (new_field) = size;
+      DECL_SIZE_UNIT (new_field)
+	= convert (sizetype,
+		   size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
+      layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
+    }
+
+  DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
+  t = DECL_ORIGINAL_FIELD (old_field);
+  SET_DECL_ORIGINAL_FIELD (new_field, t ? t : old_field);
+  DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
+  TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
+
+  return new_field;
+}
+
+/* Return the REP part of RECORD_TYPE, if any.  Otherwise return NULL.  */
+
+static tree
+get_rep_part (tree record_type)
+{
+  tree field = TYPE_FIELDS (record_type);
+
+  /* The REP part is the first field, internal, another record, and its name
+     doesn't start with an underscore (i.e. is not generated by the FE).  */
+  if (DECL_INTERNAL_P (field)
+      && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
+      && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
+    return field;
+
+  return NULL_TREE;
+}
+
+/* Return the variant part of RECORD_TYPE, if any.  Otherwise return NULL.  */
+
+static tree
+get_variant_part (tree record_type)
+{
+  tree field;
+
+  /* The variant part is the only internal field that is a qualified union.  */
+  for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
+    if (DECL_INTERNAL_P (field)
+	&& TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
+      return field;
+
+  return NULL_TREE;
+}
+
+/* Return a new variant part modeled on OLD_VARIANT_PART.  VARIANT_LIST is
+   the list of variants to be used and RECORD_TYPE is the type of the parent.
+   POS_LIST is a position list describing the layout of fields present in
+   OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
+   layout.  */
+
+static tree
+create_variant_part_from (tree old_variant_part, tree variant_list,
+			  tree record_type, tree pos_list, tree subst_list)
+{
+  tree offset = DECL_FIELD_OFFSET (old_variant_part);
+  tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
+  tree old_union_type = TREE_TYPE (old_variant_part);
+  tree new_union_type, new_variant_part, t;
+  tree union_field_list = NULL_TREE;
+
+  /* First create the type of the variant part from that of the old one.  */
+  new_union_type = make_node (QUAL_UNION_TYPE);
+  TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
+
+  /* If the position of the variant part is constant, subtract it from the
+     size of the type of the parent to get the new size.  This manual CSE
+     reduces the code size when not optimizing.  */
+  if (TREE_CODE (offset) == INTEGER_CST && TREE_CODE (bitpos) == INTEGER_CST)
+    {
+      tree first_bit = bit_from_pos (offset, bitpos);
+      TYPE_SIZE (new_union_type)
+	= size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
+      TYPE_SIZE_UNIT (new_union_type)
+	= size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
+		      byte_from_pos (offset, bitpos));
+      SET_TYPE_ADA_SIZE (new_union_type,
+			 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
+ 				     first_bit));
+      TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
+      relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
+    }
+  else
+    copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
+
+  /* Now finish up the new variants and populate the union type.  */
+  for (t = variant_list; t; t = TREE_CHAIN (t))
+    {
+      tree old_field = TREE_VEC_ELT (TREE_VALUE (t), 0), new_field;
+      tree old_variant, old_variant_subpart, new_variant, field_list;
+
+      /* Skip variants that don't belong to this nesting level.  */
+      if (DECL_CONTEXT (old_field) != old_union_type)
+	continue;
+
+      /* Retrieve the list of fields already added to the new variant.  */
+      new_variant = TREE_VEC_ELT (TREE_VALUE (t), 2);
+      field_list = TYPE_FIELDS (new_variant);
+
+      /* If the old variant had a variant subpart, we need to create a new
+	 variant subpart and add it to the field list.  */
+      old_variant = TREE_PURPOSE (t);
+      old_variant_subpart = get_variant_part (old_variant);
+      if (old_variant_subpart)
+	{
+	  tree new_variant_subpart
+	    = create_variant_part_from (old_variant_subpart, variant_list,
+					new_variant, pos_list, subst_list);
+	  TREE_CHAIN (new_variant_subpart) = field_list;
+	  field_list = new_variant_subpart;
+	}
+
+      /* Finish up the new variant and create the field.  */
+      finish_record_type (new_variant, nreverse (field_list), 2, true);
+      compute_record_mode (new_variant);
+      rest_of_record_type_compilation (new_variant);
+
+      /* No need for debug info thanks to the XVS type.  */
+      create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
+			true, false, Empty);
+
+      new_field
+	= create_field_decl_from (old_field, new_variant, new_union_type,
+				  TYPE_SIZE (new_variant),
+				  pos_list, subst_list);
+      DECL_QUALIFIER (new_field) = TREE_VEC_ELT (TREE_VALUE (t), 1);
+      DECL_INTERNAL_P (new_field) = 1;
+      TREE_CHAIN (new_field) = union_field_list;
+      union_field_list = new_field;
+    }
+
+  /* Finish up the union type and create the variant part.  */
+  finish_record_type (new_union_type, union_field_list, 2, true);
+  compute_record_mode (new_union_type);
+  rest_of_record_type_compilation (new_union_type);
+
+  /* No need for debug info thanks to the XVS type.  */
+  create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
+		    true, false, Empty);
+
+  new_variant_part
+    = create_field_decl_from (old_variant_part, new_union_type, record_type,
+			      TYPE_SIZE (new_union_type),
+			      pos_list, subst_list);
+  DECL_INTERNAL_P (new_variant_part) = 1;
+
+  /* With multiple discriminants it is possible for an inner variant to be
+     statically selected while outer ones are not; in this case, the list
+     of fields of the inner variant is not flattened and we end up with a
+     qualified union with a single member.  Drop the useless container.  */
+  if (!TREE_CHAIN (union_field_list))
+    {
+      DECL_CONTEXT (union_field_list) = record_type;
+      DECL_FIELD_OFFSET (union_field_list)
+	= DECL_FIELD_OFFSET (new_variant_part);
+      DECL_FIELD_BIT_OFFSET (union_field_list)
+	= DECL_FIELD_BIT_OFFSET (new_variant_part);
+      SET_DECL_OFFSET_ALIGN (union_field_list,
+			     DECL_OFFSET_ALIGN (new_variant_part));
+      new_variant_part = union_field_list;
+    }
+
+  return new_variant_part;
+}
+
+/* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
+   which are both RECORD_TYPE, after applying the substitutions described
+   in SUBST_LIST.  */
+
+static void
+copy_and_substitute_in_size (tree new_type, tree old_type, tree subst_list)
+{
+  tree t;
+
+  TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
+  TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
+  SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
+  TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
+  relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
+
+  if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
+    for (t = subst_list; t; t = TREE_CHAIN (t))
+      TYPE_SIZE (new_type)
+	= SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
+			      TREE_PURPOSE (t),
+			      TREE_VALUE (t));
+
+  if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
+    for (t = subst_list; t; t = TREE_CHAIN (t))
+      TYPE_SIZE_UNIT (new_type)
+	= SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
+			      TREE_PURPOSE (t),
+			      TREE_VALUE (t));
+
+  if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
+    for (t = subst_list; t; t = TREE_CHAIN (t))
+      SET_TYPE_ADA_SIZE
+	(new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
+				       TREE_PURPOSE (t),
+				       TREE_VALUE (t)));
+
+  /* Finalize the size.  */
+  TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
+  TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
+}
+
 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
    type with all size expressions that contain F in a PLACEHOLDER_EXPR
    updated by replacing F with R.