[Ada] Fix ICE with packed array declared as private (2)

[Ada] Fix ICE with packed array declared as private (2)

[Eric Botcazou]

[-- Attachment #1: Type: text/plain, Size: 668 bytes --]

This is a variant of
  http://gcc.gnu.org/ml/gcc-patches/2009-04/msg01581.html
where the extra conversion is inserted around an OUT actual parameter in a 
function call.  Fixed by adjusting the above change to this new case.

Tested on i586-suse-linux, applied on the mainline.


2009-11-25  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/trans.c (unchecked_conversion_lhs_nop): Rename into...
	(unchecked_conversion_nop): ...this.  Handle actual parameters.
	(gnat_to_gnu): Adjust for above renaming.


2009-11-25  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/specs/pack6.ads: New test.
	* gnat.dg/specs/pack6_pkg.ads: New helper.


-- 
Eric Botcazou

[-- Attachment #2: p.diff --]
[-- Type: text/x-diff, Size: 2406 bytes --]

Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c	(revision 154515)
+++ gcc-interface/trans.c	(working copy)
@@ -3432,19 +3432,21 @@ Compilation_Unit_to_gnu (Node_Id gnat_no
   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.  */
+/* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
+   as gigi is concerned.  This is used to avoid conversions on the LHS.  */
 
 static bool
-unchecked_conversion_lhs_nop (Node_Id gnat_node)
+unchecked_conversion_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.  */
+  /* The conversion must be on the LHS of an assignment or an actual parameter
+     of a call.  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))
+	&& Name (Parent (gnat_node)) == gnat_node)
+      && !(Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
+	   && Name (Parent (gnat_node)) != gnat_node))
     return false;
 
   from_type = Etype (Expression (gnat_node));
@@ -4156,7 +4158,7 @@ gnat_to_gnu (Node_Id gnat_node)
       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))
+      if (unchecked_conversion_nop (gnat_node))
 	{
 	  gnu_result_type = TREE_TYPE (gnu_result);
 	  break;
@@ -5409,7 +5411,7 @@ gnat_to_gnu (Node_Id 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)))
+	      && unchecked_conversion_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

[-- Attachment #3: pack6.ads --]
[-- Type: text/x-adasrc, Size: 445 bytes --]

-- { dg-do compile }

with Ada.Finalization;
with Pack6_Pkg;

package Pack6 is

  package Eight_Bits is new Pack6_Pkg (8);

  type Some_Data is record
    Byte_1 : Eight_Bits.Object;
    Byte_2 : Eight_Bits.Object;
  end record;

  for Some_Data use record
    Byte_1 at 0 range 0 .. 7;
    Byte_2 at 1 range 0 .. 7;
  end record;

  type Top_Object is new Ada.Finalization.Controlled with record
    Data : Some_Data;
  end record;

end Pack6;

[-- Attachment #4: pack6_pkg.ads --]
[-- Type: text/x-adasrc, Size: 221 bytes --]

generic

  Size : Positive;

package Pack6_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 Pack6_Pkg;