* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Class_Wide_Type>: Fix

	comment.
	* gcc-interface/trans.c (process_freeze_entity): Use local copy of
	Ekind.  Return early for class-wide types.  Do not compute initializer
	unless necessary.  Reuse the tree for an associated class-wide type
	only if processing its root type.


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

7 files changed, 99 insertions, 53 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 7c6a63c37a5..79c4721e4a7 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2010-04-14  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Class_Wide_Type>: Fix
+	comment.
+	* gcc-interface/trans.c (process_freeze_entity): Use local copy of
+	Ekind.  Return early for class-wide types.  Do not compute initializer
+	unless necessary.  Reuse the tree for an associated class-wide type
+	only if processing its root type.
+
 2010-04-13  Duncan Sands  <baldrick@free.fr>
 
 	* gcc-interface/misc.c (gnat_eh_type_covers): Remove.
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 190aec6c7bc..7780cff32a4 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -4343,9 +4343,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	break;
       }
 
-      /* Simple class_wide types are always viewed as their root_type
-	 by Gigi unless an Equivalent_Type is specified.  */
     case E_Class_Wide_Type:
+      /* Class-wide types are always transformed into their root type.  */
       gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
       maybe_present = true;
       break;
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 6da6e7904f6..7716061f036 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -6073,92 +6073,85 @@ elaborate_all_entities (Node_Id gnat_node)
     elaborate_all_entities (Library_Unit (gnat_node));
 }
 
-/* Do the processing of N_Freeze_Entity, GNAT_NODE.  */
+/* Do the processing of GNAT_NODE, an N_Freeze_Entity.  */
 
 static void
 process_freeze_entity (Node_Id gnat_node)
 {
-  Entity_Id gnat_entity = Entity (gnat_node);
-  tree gnu_old;
-  tree gnu_new;
-  tree gnu_init
-    = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
-       && present_gnu_tree (Declaration_Node (gnat_entity)))
-      ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
+  const Entity_Id gnat_entity = Entity (gnat_node);
+  const Entity_Kind kind = Ekind (gnat_entity);
+  tree gnu_old, gnu_new;
 
-  /* If this is a package, need to generate code for the package.  */
-  if (Ekind (gnat_entity) == E_Package)
+  /* If this is a package, we need to generate code for the package.  */
+  if (kind == E_Package)
     {
       insert_code_for
-  	(Parent (Corresponding_Body
-  		 (Parent (Declaration_Node (gnat_entity)))));
+	(Parent (Corresponding_Body
+		 (Parent (Declaration_Node (gnat_entity)))));
       return;
     }
 
-  /* Check for old definition after the above call.  This Freeze_Node
-     might be for one its Itypes.  */
+  /* Don't do anything for class-wide types as they are always transformed
+     into their root type.  */
+  if (kind == E_Class_Wide_Type)
+    return;
+
+  /* Check for an old definition.  This freeze node might be for an Itype.  */
   gnu_old
-    = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
+    = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
 
-  /* If this entity has an Address representation clause, GNU_OLD is the
+  /* If this entity has an address representation clause, GNU_OLD is the
      address, so discard it here.  */
   if (Present (Address_Clause (gnat_entity)))
-    gnu_old = 0;
-
-  /* Don't do anything for class-wide types as they are always transformed
-     into their root type.  */
-  if (Ekind (gnat_entity) == E_Class_Wide_Type)
-    return;
+    gnu_old = NULL_TREE;
 
   /* Don't do anything for subprograms that may have been elaborated before
-     their freeze nodes.  This can happen, for example because of an inner call
-     in an instance body, or a previous compilation of a spec for inlining
-     purposes.  */
+     their freeze nodes.  This can happen, for example, because of an inner
+     call in an instance body or because of previous compilation of a spec
+     for inlining purposes.  */
   if (gnu_old
       && ((TREE_CODE (gnu_old) == FUNCTION_DECL
-	   && (Ekind (gnat_entity) == E_Function
-	       || Ekind (gnat_entity) == E_Procedure))
-	  || (gnu_old
-	      && TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
-	      && Ekind (gnat_entity) == E_Subprogram_Type)))
+	   && (kind == E_Function || kind == E_Procedure))
+	  || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
+	      && kind == E_Subprogram_Type)))
     return;
 
   /* If we have a non-dummy type old tree, we have nothing to do, except
      aborting if this is the public view of a private type whose full view was
      not delayed, as this node was never delayed as it should have been.  We
      let this happen for concurrent types and their Corresponding_Record_Type,
-     however, because each might legitimately be elaborated before it's own
+     however, because each might legitimately be elaborated before its own
      freeze node, e.g. while processing the other.  */
   if (gnu_old
       && !(TREE_CODE (gnu_old) == TYPE_DECL
 	   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
     {
-      gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
+      gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
 		   && Present (Full_View (gnat_entity))
 		   && No (Freeze_Node (Full_View (gnat_entity))))
 		  || Is_Concurrent_Type (gnat_entity)
-		  || (IN (Ekind (gnat_entity), Record_Kind)
+		  || (IN (kind, Record_Kind)
 		      && Is_Concurrent_Record_Type (gnat_entity)));
       return;
     }
 
   /* Reset the saved tree, if any, and elaborate the object or type for real.
-     If there is a full declaration, elaborate it and copy the type to
-     GNAT_ENTITY.  Likewise if this is the record subtype corresponding to
-     a class wide type or subtype.  */
+     If there is a full view, elaborate it and use the result.  And, if this
+     is the root type of a class-wide type, reuse it for the latter.  */
   if (gnu_old)
     {
       save_gnu_tree (gnat_entity, NULL_TREE, false);
-      if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
-  	  && Present (Full_View (gnat_entity))
-  	  && present_gnu_tree (Full_View (gnat_entity)))
-  	save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
-      if (Present (Class_Wide_Type (gnat_entity))
-	  && Class_Wide_Type (gnat_entity) != gnat_entity)
+      if (IN (kind, Incomplete_Or_Private_Kind)
+	  && Present (Full_View (gnat_entity))
+	  && present_gnu_tree (Full_View (gnat_entity)))
+	save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
+      if (IN (kind, Type_Kind)
+	  && Present (Class_Wide_Type (gnat_entity))
+	  && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
 	save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
     }
 
-  if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
+  if (IN (kind, Incomplete_Or_Private_Kind)
       && Present (Full_View (gnat_entity)))
     {
       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
@@ -6174,16 +6167,25 @@ process_freeze_entity (Node_Id gnat_node)
 	Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
 
       /* The above call may have defined this entity (the simplest example
-  	 of this is when we have a private enumeral type since the bounds
-  	 will have the public view.  */
+	 of this is when we have a private enumeral type since the bounds
+	 will have the public view).  */
       if (!present_gnu_tree (gnat_entity))
-  	save_gnu_tree (gnat_entity, gnu_new, false);
-      if (Present (Class_Wide_Type (gnat_entity))
-	  && Class_Wide_Type (gnat_entity) != gnat_entity)
-	save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
+	save_gnu_tree (gnat_entity, gnu_new, false);
     }
   else
-    gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
+    {
+      tree gnu_init
+	= (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
+	   && present_gnu_tree (Declaration_Node (gnat_entity)))
+	  ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
+
+      gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
+    }
+
+  if (IN (kind, Type_Kind)
+      && Present (Class_Wide_Type (gnat_entity))
+      && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
+    save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
 
   /* If we've made any pointers to the old version of this type, we
      have to update them.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 913b01a4c57..d0065311be2 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2010-04-14  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/class_wide.adb: Rename into...
+	* gnat.dg/class_wide1.adb: ...this.
+	* gnat.dg/class_wide2.ad[sb]: New test.
+
 2010-04-14  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/18918
diff --git a/gcc/testsuite/gnat.dg/class_wide.adb b/gcc/testsuite/gnat.dg/class_wide1.adb
index 5f345590945..ba6fea03293 100644
--- a/gcc/testsuite/gnat.dg/class_wide.adb
+++ b/gcc/testsuite/gnat.dg/class_wide1.adb
@@ -1,6 +1,6 @@
 -- { dg-do compile }
 
-procedure class_wide is
+procedure Class_Wide1 is
     package P is
        type T is tagged null record;
        procedure P1 (x : T'Class);
diff --git a/gcc/testsuite/gnat.dg/class_wide2.adb b/gcc/testsuite/gnat.dg/class_wide2.adb
new file mode 100644
index 00000000000..b82289d5ef5
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/class_wide2.adb
@@ -0,0 +1,13 @@
+-- { dg-do compile }
+
+package body Class_Wide2 is
+
+   procedure Initialize is
+      Var_Acc : Class_Acc := new Grand_Child;
+      Var     : Grand_Child'Class := Grand_Child'Class (Var_Acc.all);  -- { dg-bogus "already constrained" "" { xfail *-*-* } }
+
+   begin
+      Var := Grand_Child'Class (Var_Acc.all);
+   end Initialize;
+
+end Class_Wide2;
diff --git a/gcc/testsuite/gnat.dg/class_wide2.ads b/gcc/testsuite/gnat.dg/class_wide2.ads
new file mode 100644
index 00000000000..a1acc223e57
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/class_wide2.ads
@@ -0,0 +1,17 @@
+package Class_Wide2 is
+
+   type Root_1 (V : Integer) is tagged record
+      null;
+   end record;
+
+   type Child is new Root_1 (1) with null record;
+
+   type Class_Acc is access all Child'Class;
+
+   type Grand_Child is new Child with record
+      null;
+   end record;
+
+   procedure Initialize;
+
+end Class_Wide2;