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

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158255 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 233c8b9..b62b913 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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..335941a 100644 (file)
--- 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 (file)
--- 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 (file)
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" } }