trans.c (unchecked_conversion_lhs_nop): New predicate.

* gcc-interface/trans.c (unchecked_conversion_lhs_nop): New predicate.
	(gnat_to_gnu) <N_Unchecked_Type_Conversion>: Return the expression
	if the conversion is on the LHS of an assignment and a no-op.
	<all> Do not convert the result to the result type if the Parent
	node is such a conversion.

From-SVN: r146450

gcc/ada/ChangeLog

@@ -1,3 +1,11 @@
+2009-04-20  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gcc-interface/trans.c (unchecked_conversion_lhs_nop): New predicate.
+	(gnat_to_gnu) <N_Unchecked_Type_Conversion>: Return the expression
+	if the conversion is on the LHS of an assignment and a no-op.
+	<all> Do not convert the result to the result type if the Parent
+	node is such a conversion.
+
 2009-04-20  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc-interface/ada-tree.h (DECL_HAS_REP_P): Delete.

gcc/ada/gcc-interface/trans.c

@@ -3362,6 +3362,43 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
   invalidate_global_renaming_pointers ();
 }
 
+/* Return whether GNAT_NODE, an unchecked type conversion, is on the LHS
+   of an assignment and a no-op as far as gigi is concerned.  */
+
+static bool
+unchecked_conversion_lhs_nop (Node_Id gnat_node)
+{
+  Entity_Id from_type, to_type;
+
+  /* The conversion must be on the LHS of an assignment.  Otherwise, even
+     if the conversion was essentially a no-op, it could de facto ensure
+     type consistency and this should be preserved.  */
+  if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement
+	&& Name (Parent (gnat_node)) == gnat_node))
+    return false;
+
+  from_type = Etype (Expression (gnat_node));
+
+  /* We're interested in artificial conversions generated by the front-end
+     to make private types explicit, e.g. in Expand_Assign_Array.  */
+  if (!Is_Private_Type (from_type))
+    return false;
+
+  from_type = Underlying_Type (from_type);
+  to_type = Etype (gnat_node);
+
+  /* The direct conversion to the underlying type is a no-op.  */
+  if (to_type == from_type)
+    return true;
+
+  /* For an array type, the conversion to the PAT is a no-op.  */
+  if (Ekind (from_type) == E_Array_Subtype
+      && to_type == Packed_Array_Type (from_type))
+    return true;
+
+  return false;
+}
+
 /* This function is the driver of the GNAT to GCC tree transformation
    process.  It is the entry point of the tree transformer.  GNAT_NODE is the
    root of some GNAT tree.  Return the root of the corresponding GCC tree.
@@ -4040,6 +4077,14 @@ gnat_to_gnu (Node_Id gnat_node)
 
     case N_Unchecked_Type_Conversion:
       gnu_result = gnat_to_gnu (Expression (gnat_node));
+
+      /* Skip further processing if the conversion is deemed a no-op.  */
+      if (unchecked_conversion_lhs_nop (gnat_node))
+	{
+	  gnu_result_type = TREE_TYPE (gnu_result);
+	  break;
+	}
+
       gnu_result_type = get_unpadded_type (Etype (gnat_node));
 
       /* If the result is a pointer type, see if we are improperly
@@ -5292,7 +5337,8 @@ gnat_to_gnu (Node_Id gnat_node)
        1. If this is the Name of an assignment statement or a parameter of
 	  a procedure call, return the result almost unmodified since the
 	  RHS will have to be converted to our type in that case, unless
-	  the result type has a simpler size.   Similarly, don't convert
+	  the result type has a simpler size.  Likewise if there is just
+	  a no-op unchecked conversion in-between.  Similarly, don't convert
 	  integral types that are the operands of an unchecked conversion
 	  since we need to ignore those conversions (for 'Valid).
 
@@ -5315,6 +5361,8 @@ gnat_to_gnu (Node_Id gnat_node)
   if (Present (Parent (gnat_node))
       && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
 	   && Name (Parent (gnat_node)) == gnat_node)
+	  || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
+	      && unchecked_conversion_lhs_nop (Parent (gnat_node)))
 	  || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
 	      && Name (Parent (gnat_node)) != gnat_node)
 	  || Nkind (Parent (gnat_node)) == N_Parameter_Association

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2009-04-20  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/pack13.ad[sb]: New test.
+	* gnat.dg/pack13_pkg.ads: New helper.
+
 2009-04-20  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/discr11.ad[sb]: New test.

gcc/testsuite/gnat.dg/pack13.adb

@@ -0,0 +1,10 @@
+-- [ dg-do compile }
+
+package body Pack13 is
+
+  procedure Set (Myself : Object_Ptr; The_Data : Thirty_Two_Bits.Object) is
+  begin
+    Myself.Something.Data_1 := The_Data;
+  end;
+
+end Pack13;

gcc/testsuite/gnat.dg/pack13.ads

@@ -0,0 +1,33 @@
+with Pack13_Pkg;
+
+package Pack13 is
+
+  package Four_Bits is new Pack13_Pkg (4);
+  package Thirty_Two_Bits is new Pack13_Pkg (32);
+
+  type Object is private;
+  type Object_Ptr is access all Object;
+
+  procedure Set (Myself : Object_Ptr; The_Data : Thirty_Two_Bits.Object);
+
+private
+
+  type Some_Record is record
+    Data_1     : Thirty_Two_Bits.Object;
+    Data_2     : Thirty_Two_Bits.Object;
+    Small_Data : Four_Bits.Object;
+  end record;
+  for Some_Record use record
+    Data_1 at 0 range 0 .. 31;
+    Data_2 at 4 range 0 .. 31;
+    Small_Data at 8 range 0 .. 3;
+  end record;
+
+  type Object is record
+    Something : Some_Record;
+  end record;
+  for Object use record
+    Something at 0 range 0 .. 67;
+  end record;
+
+end Pack13;

gcc/testsuite/gnat.dg/pack13_pkg.ads

@@ -0,0 +1,17 @@
+generic
+
+  Size : Positive;
+
+package Pack13_Pkg is
+
+  type Object is private;
+
+private
+
+  type Bit is range 0 .. 1;
+  for Bit'size use 1;
+
+  type Object is array (1 .. Size) of Bit;
+  pragma Pack (Object);
+
+end Pack13_Pkg;