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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0c0ed033017d0f61db1cb45bde44e10797e2bc07..a03636aeeb85599f7f7553e97fe1410aa629922e 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/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.

diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 0b29e3312cd843b5869f7d14fb8afeeab76e319b..9558302c02e2c1b8d27d2eb1e269bfd69155a302 100644 (file)
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -3362,6 +3362,43 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
   invalidate_global_renaming_pointers ();
 }
 \f
+/* 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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5a072fc876582278e5f412cc699873cb98f063f1..8f0516dbdc5b0163d00b5093fcd6f8481ecb87fd 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/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.

diff --git a/gcc/testsuite/gnat.dg/pack13.adb b/gcc/testsuite/gnat.dg/pack13.adb
new file mode 100644 (file)
index 0000000..dd9cb09
--- /dev/null
+++ b/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;

diff --git a/gcc/testsuite/gnat.dg/pack13.ads b/gcc/testsuite/gnat.dg/pack13.ads
new file mode 100644 (file)
index 0000000..1836311
--- /dev/null
+++ b/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;

diff --git a/gcc/testsuite/gnat.dg/pack13_pkg.ads b/gcc/testsuite/gnat.dg/pack13_pkg.ads
new file mode 100644 (file)
index 0000000..afe8bec
--- /dev/null
+++ b/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;