gigi.h (standard_datatypes): Add ADT_parent_name_id.

	* gcc-interface/gigi.h (standard_datatypes): Add ADT_parent_name_id.
	(parent_name_id): New macro.
	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Use it.
	* gcc-interface/trans.c (gigi): Initialize it.
	(lvalue_required_p) <N_Type_Conversion>: New case.
	<N_Qualified_Expression>: Likewise.
	<N_Allocator>: Likewise.
	* gcc-interface/utils.c (convert): Try to properly upcast tagged types.

From-SVN: r158255

7 files changed, 87 insertions, 5 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 233c8b9..b62b913 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,16 @@
 2010-04-13  Eric Botcazou  <ebotcazou@adacore.com>
 
+	* gcc-interface/gigi.h (standard_datatypes): Add ADT_parent_name_id.
+	(parent_name_id): New macro.
+	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Use it.
+	* gcc-interface/trans.c (gigi): Initialize it.
+	(lvalue_required_p) <N_Type_Conversion>: New case.
+	<N_Qualified_Expression>: Likewise.
+	<N_Allocator>: Likewise.
+	* gcc-interface/utils.c (convert): Try to properly upcast tagged types.
+
+2010-04-13  Eric Botcazou  <ebotcazou@adacore.com>
+
 	* gcc-interface/ada-tree.h (TYPE_BY_REFERENCE_P): Delete.
 	(DECL_CONST_ADDRESS_P): New macro.
 	(SET_DECL_ORIGINAL_FIELD_TO_FIELD): Likewise.
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index a333170..190aec6 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -2851,8 +2851,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 
 	    /* ...and reference the _Parent field of this record.  */
 	    gnu_field
-	      = create_field_decl (get_identifier
-				   (Get_Name_String (Name_uParent)),
+	      = create_field_decl (parent_name_id,
 				   gnu_parent, gnu_type, 0,
 				   has_rep
 				   ? TYPE_SIZE (gnu_parent) : NULL_TREE,
@@ -4392,6 +4391,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
      handling alignment and possible padding.  */
   if (is_type && (!gnu_decl || this_made_decl))
     {
+      /* Tell the middle-end that objects of tagged types are guaranteed to
+	 be properly aligned.  This is necessary because conversions to the
+	 class-wide type are translated into conversions to the root type,
+	 which can be less aligned than some of its derived types.  */
       if (Is_Tagged_Type (gnat_entity)
 	  || Is_Class_Wide_Equivalent_Type (gnat_entity))
 	TYPE_ALIGN_OK (gnu_type) = 1;
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index 8ba0637..d9459e5 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -374,9 +374,12 @@ enum standard_datatypes
   /* Likewise for freeing memory.  */
   ADT_free_decl,
 
-  /* Function decl node for 64-bit multiplication with overflow checking */
+  /* Function decl node for 64-bit multiplication with overflow checking.  */
   ADT_mulv64_decl,
 
+  /* Identifier for the name of the _Parent field in tagged record types.  */
+  ADT_parent_name_id,
+
   /* Types and decls used by our temporary exception mechanism.  See
      init_gigi_decls for details.  */
   ADT_jmpbuf_type,
@@ -408,6 +411,7 @@ extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
 #define malloc32_decl gnat_std_decls[(int) ADT_malloc32_decl]
 #define free_decl gnat_std_decls[(int) ADT_free_decl]
 #define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl]
+#define parent_name_id gnat_std_decls[(int) ADT_parent_name_id]
 #define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type]
 #define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type]
 #define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl]
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 97ac2f3..2c86db9 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -396,6 +396,9 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
 						     int64_type, NULL_TREE),
 			   NULL_TREE, false, true, true, NULL, Empty);
 
+  /* Name of the _Parent field in tagged record types.  */
+  parent_name_id = get_identifier (Get_Name_String (Name_uParent));
+
   /* Make the types and functions used for exception processing.  */
   jmpbuf_type
     = build_array_type (gnat_type_for_mode (Pmode, 0),
@@ -794,13 +797,29 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
 	      || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 		  && Is_Atomic (Entity (Name (gnat_parent)))));
 
+    case N_Type_Conversion:
+    case N_Qualified_Expression:
+      /* We must look through all conversions for composite types because we
+	 may need to bypass an intermediate conversion to a narrower record
+	 type that is generated for a formal conversion, e.g. the conversion
+	 to the root type of a hierarchy of tagged types generated for the
+	 formal conversion to the class-wide type.  */
+      if (!Is_Composite_Type (Underlying_Type (Etype (gnat_node))))
+	return 0;
+
+      /* ... fall through ... */
+
     case N_Unchecked_Type_Conversion:
-      /* Returning 0 is very likely correct but we get better code if we
-	 go through the conversion.  */
       return lvalue_required_p (gnat_parent,
 				get_unpadded_type (Etype (gnat_parent)),
 				constant, address_of_constant, aliased);
 
+    case N_Allocator:
+      /* We should only reach here through the N_Qualified_Expression case
+	 and, therefore, only for composite types.  Force an lvalue since
+	 a block-copy to the newly allocated area of memory is made.  */
+      return 1;
+
    case N_Explicit_Dereference:
       /* We look through dereferences for address of constant because we need
 	 to handle the special cases listed above.  */
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index 7353bdc..335941a2 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -4027,6 +4027,19 @@ convert (tree type, tree expr)
 					   etype)))
     return build1 (VIEW_CONVERT_EXPR, type, expr);
 
+  /* If we are converting between tagged types, try to upcast properly.  */
+  else if (ecode == RECORD_TYPE && code == RECORD_TYPE
+	   && TYPE_ALIGN_OK (etype) && TYPE_ALIGN_OK (type))
+    {
+      tree child_etype = etype;
+      do {
+	tree field = TYPE_FIELDS (child_etype);
+	if (DECL_NAME (field) == parent_name_id && TREE_TYPE (field) == type)
+	  return build_component_ref (expr, NULL_TREE, field, false);
+	child_etype = TREE_TYPE (field);
+      } while (TREE_CODE (child_etype) == RECORD_TYPE);
+    }
+
   /* In all other cases of related types, make a NOP_EXPR.  */
   else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
 	   || (code == INTEGER_CST && ecode == INTEGER_CST
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d267f5c..dcce334 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2010-04-13  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/derived_type1.adb: New test.
+
 2010-04-13  Matthias Klose  <doko@ubuntu.com>
 
 	* gcc.dg/plugindir1.c: New testcase.
diff --git a/gcc/testsuite/gnat.dg/derived_type1.adb b/gcc/testsuite/gnat.dg/derived_type1.adb
new file mode 100644
index 0000000..c50d5ef
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/derived_type1.adb
@@ -0,0 +1,28 @@
+-- { dg-do compile }
+-- { dg-options "-gnatws -fdump-tree-original" }
+
+procedure Derived_Type1 is
+
+  type Root is tagged null record;
+
+  type Derived1 is new Root with record
+    I1 : Integer;
+  end record;
+
+  type Derived2 is new Derived1 with record
+    I2: Integer;
+  end record;
+
+  R : Root;
+  D1 : Derived1;
+  D2 : Derived2;
+
+begin
+  R  := Root(D1);
+  R  := Root(D2);
+  D1 := Derived1(D2);
+end;
+
+-- { dg-final { scan-tree-dump-not "VIEW_CONVERT_EXPR<struct derived_type1__root>" "original" } }
+-- { dg-final { scan-tree-dump-not "VIEW_CONVERT_EXPR<struct derived_type1__derived1>" "original" } }
+-- { dg-final { cleanup-tree-dump "original" } }