[Ada] Copy of Unchecked_Union derived discriminated types

[Ada] Copy of Unchecked_Union derived discriminated types

[Pierre-Marie de Rodat]

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

The compiler crashes processing an assignment to a discriminated
record type that has pragma Unchecked_Union and Convention C and
is a derivation of a non-tagged record type with discriminants.

After this patch the following test compiles silently.

procedure Conversion is
   type small_array is array (0 .. 2) of Integer;
   type big_array   is array (0 .. 3) of Integer;

   type small_record is record
      field1 : aliased Integer     := 0;
      field2 : aliased small_array := (0, 0, 0);
   end record;

   type big_record is record
      field1 : aliased Integer   := 0;
      field2 : aliased big_array := (0, 0, 0, 0);
   end record;

   type myUnion (discr : Integer := 0) is record
      case discr is
         when 0 =>
            record1 : aliased small_record;
         when others =>
            record2 : aliased big_record;
      end case;
   end record;

   type UU_myUnion1 is new myUnion;
   pragma Unchecked_Union (UU_myUnion1);
   pragma Convention (C, UU_myUnion1);

   procedure Convert (A : in myUnion; B : out UU_myUnion1) is
      L : UU_myUnion1 := UU_myUnion1 (A);  --  Test
   begin
      B := L;
   end Convert;

begin
   null;
end Conversion;

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

2017-09-29  Javier Miranda  <miranda@adacore.com>

	* exp_ch5.adb (Expand_Assign_Record): Do not generate code to copy
	discriminants if the target is an Unchecked_Union record type.

gcc/testsuite/

2017-09-29  Javier Miranda  <miranda@adacore.com>

	* gnat.dg/unchecked_union3.adb: New testcase.

[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 1915 bytes --]

Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb	(revision 253283)
+++ exp_ch5.adb	(working copy)
@@ -1577,7 +1577,14 @@
          --  suppressed in this case). It is unnecessary but harmless in
          --  other cases.
 
-         if Has_Discriminants (L_Typ) then
+         --  Special case: no copy if the target has no discriminants.
+
+         if Has_Discriminants (L_Typ)
+           and then Is_Unchecked_Union (Base_Type (L_Typ))
+         then
+            null;
+
+         elsif Has_Discriminants (L_Typ) then
             F := First_Discriminant (R_Typ);
             while Present (F) loop
 
Index: ../testsuite/gnat.dg/unchecked_union3.adb
===================================================================
--- ../testsuite/gnat.dg/unchecked_union3.adb	(revision 0)
+++ ../testsuite/gnat.dg/unchecked_union3.adb	(revision 0)
@@ -0,0 +1,38 @@
+--  { dg-do compile }
+
+procedure Unchecked_Union3 is
+   type small_array is array (0 .. 2) of Integer;
+   type big_array   is array (0 .. 3) of Integer;
+
+   type small_record is record
+      field1 : aliased Integer     := 0;
+      field2 : aliased small_array := (0, 0, 0);
+   end record;
+
+   type big_record is record
+      field1 : aliased Integer   := 0;
+      field2 : aliased big_array := (0, 0, 0, 0);
+   end record;
+
+   type myUnion (discr : Integer := 0) is record
+      case discr is
+         when 0 =>
+            record1 : aliased small_record;
+         when others =>
+            record2 : aliased big_record;
+      end case;
+   end record;
+
+   type UU_myUnion1 is new myUnion;
+   pragma Unchecked_Union (UU_myUnion1);
+   pragma Convention (C, UU_myUnion1);
+
+   procedure Convert (A : in myUnion; B : out UU_myUnion1) is
+      L : UU_myUnion1 := UU_myUnion1 (A);  --  Test
+   begin
+      B := L;
+   end Convert;
+
+begin
+   null;
+end Unchecked_Union3;