Fix initialization of UNIONs with -finit-derived.

	gcc/fortran/
	* expr.c (generate_union_initializer, get_union_initializer): New.
	* expr.c (component_initializer): Consider BT_UNION specially.
	* resolve.c (resolve_structure_cons): Hack for BT_UNION.
	* trans-expr.c (gfc_trans_subcomponent_assign): Ditto.
	* trans-expr.c (gfc_conv_union_initializer): New.
	* trans-expr.c (gfc_conv_structure): Replace UNION handling code with
	new function gfc_conv_union_initializer.

	gcc/testsuite/gfortran.dg/
	* dec_init_1.f90, dec_init_2.f90: Remove -fdump-tree-original.
	* dec_init_3.f90, dec_init_4.f90: New tests.

From-SVN: r241626

gcc/fortran/ChangeLog

+2016-10-27  Fritz Reese <fritzoreese@gmail.com>
+
+	* expr.c (generate_union_initializer, get_union_initializer): New.
+	* expr.c (component_initializer): Consider BT_UNION specially.
+	* resolve.c (resolve_structure_cons): Hack for BT_UNION.
+	* trans-expr.c (gfc_trans_subcomponent_assign): Ditto.
+	* trans-expr.c (gfc_conv_union_initializer): New.
+	* trans-expr.c (gfc_conv_structure): Replace UNION handling code with
+	new function gfc_conv_union_initializer.
+
 2016-10-26  Steven G. Kargl <kargl@gcc.gnu.org>
 
 	PR fortran/78092

gcc/fortran/expr.c

@@ -4160,6 +4160,60 @@ gfc_has_default_initializer (gfc_symbol *der)
 }
 
 
+/*
+   Generate an initializer expression which initializes the entirety of a union.
+   A normal structure constructor is insufficient without undue effort, because
+   components of maps may be oddly aligned/overlapped. (For example if a
+   character is initialized from one map overtop a real from the other, only one
+   byte of the real is actually initialized.)  Unfortunately we don't know the
+   size of the union right now, so we can't generate a proper initializer, but
+   we use a NULL expr as a placeholder and do the right thing later in
+   gfc_trans_subcomponent_assign.
+ */
+static gfc_expr *
+generate_union_initializer (gfc_component *un)
+{
+  if (un == NULL || un->ts.type != BT_UNION)
+    return NULL;
+
+  gfc_expr *placeholder = gfc_get_null_expr (&un->loc);
+  placeholder->ts = un->ts;
+  return placeholder;
+}
+
+
+/* Get the user-specified initializer for a union, if any. This means the user
+   has said to initialize component(s) of a map.  For simplicity's sake we
+   only allow the user to initialize the first map.  We don't have to worry
+   about overlapping initializers as they are released early in resolution (see
+   resolve_fl_struct).   */
+
+static gfc_expr *
+get_union_initializer (gfc_symbol *union_type, gfc_component **map_p)
+{
+  gfc_component *map;
+  gfc_expr *init=NULL;
+
+  if (!union_type || union_type->attr.flavor != FL_UNION)
+    return NULL;
+
+  for (map = union_type->components; map; map = map->next)
+    {
+      if (gfc_has_default_initializer (map->ts.u.derived))
+        {
+          init = gfc_default_initializer (&map->ts);
+          if (map_p)
+            *map_p = map;
+          break;
+        }
+    }
+
+  if (map_p && !init)
+    *map_p = NULL;
+
+  return init;
+}
+
 /* Fetch or generate an initializer for the given component.
    Only generate an initializer if generate is true.  */
 
@@ -4177,6 +4231,43 @@ component_initializer (gfc_typespec *ts, gfc_component *c, bool generate)
   if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
     init = gfc_generate_initializer (&c->ts, true);
 
+  else if (c->ts.type == BT_UNION && c->ts.u.derived->components)
+    {
+      gfc_component *map = NULL;
+      gfc_constructor *ctor;
+      gfc_expr *user_init;
+
+      /* If we don't have a user initializer and we aren't generating one, this
+         union has no initializer.  */
+      user_init = get_union_initializer (c->ts.u.derived, &map);
+      if (!user_init && !generate)
+        return NULL;
+
+      /* Otherwise use a structure constructor.  */
+      init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind,
+                                                 &c->loc);
+      init->ts = c->ts;
+
+      /* If we are to generate an initializer for the union, add a constructor
+         which initializes the whole union first.  */
+      if (generate)
+        {
+          ctor = gfc_constructor_get ();
+          ctor->expr = generate_union_initializer (c);
+          gfc_constructor_append (&init->value.constructor, ctor);
+        }
+
+      /* If we found an initializer in one of our maps, apply it.  Note this
+         is applied _after_ the entire-union initializer above if any.  */
+      if (user_init)
+        {
+          ctor = gfc_constructor_get ();
+          ctor->expr = user_init;
+          ctor->n.component = map;
+          gfc_constructor_append (&init->value.constructor, ctor);
+        }
+    }
+
   /* Treat simple components like locals.  */
   else
     {

gcc/fortran/resolve.c

@@ -1158,6 +1158,12 @@ resolve_structure_cons (gfc_expr *expr, int init)
       if (!cons->expr)
 	continue;
 
+      /* Unions use an EXPR_NULL contrived expression to tell the translation
+         phase to generate an initializer of the appropriate length.
+         Ignore it here.  */
+      if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
+        continue;
+
       if (!gfc_resolve_expr (cons->expr))
 	{
 	  t = false;

gcc/fortran/trans-expr.c

@@ -7315,7 +7315,29 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 			fold_convert (TREE_TYPE (tmp), se.expr));
       gfc_add_block_to_block (&block, &se.post);
     }
-  else if (gfc_bt_struct (expr->ts.type) && expr->ts.f90_type != BT_VOID)
+  else if (expr->ts.type == BT_UNION)
+    {
+      tree tmp;
+      gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
+      /* We mark that the entire union should be initialized with a contrived
+         EXPR_NULL expression at the beginning.  */
+      if (c->n.component == NULL && c->expr->expr_type == EXPR_NULL)
+        {
+          tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+		            dest, build_constructor (TREE_TYPE (dest), NULL));
+	  gfc_add_expr_to_block (&block, tmp);
+          c = gfc_constructor_next (c);
+        }
+      /* The following constructor expression, if any, represents a specific
+         map intializer, as given by the user.  */
+      if (c != NULL && c->expr != NULL)
+        {
+          gcc_assert (expr->expr_type == EXPR_STRUCTURE);
+	  tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
+	  gfc_add_expr_to_block (&block, tmp);
+        }
+    }
+  else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
     {
       if (expr->expr_type != EXPR_STRUCTURE)
 	{
@@ -7457,6 +7479,43 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
   return gfc_finish_block (&block);
 }
 
+void
+gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
+                            gfc_component *un, gfc_expr *init)
+{
+  gfc_constructor *ctor;
+
+  if (un->ts.type != BT_UNION || un == NULL || init == NULL)
+    return;
+
+  ctor = gfc_constructor_first (init->value.constructor);
+
+  if (ctor == NULL || ctor->expr == NULL)
+    return;
+
+  gcc_assert (init->expr_type == EXPR_STRUCTURE);
+
+  /* If we have an 'initialize all' constructor, do it first.  */
+  if (ctor->expr->expr_type == EXPR_NULL)
+    {
+      tree union_type = TREE_TYPE (un->backend_decl);
+      tree val = build_constructor (union_type, NULL);
+      CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
+      ctor = gfc_constructor_next (ctor);
+    }
+
+  /* Add the map initializer on top.  */
+  if (ctor != NULL && ctor->expr != NULL)
+    {
+      gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
+      tree val = gfc_conv_initializer (ctor->expr, &un->ts,
+                                       TREE_TYPE (un->backend_decl),
+                                       un->attr.dimension, un->attr.pointer,
+                                       un->attr.proc_pointer);
+      CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
+    }
+}
+
 /* Build an expression for a constructor. If init is nonzero then
    this is part of a static variable initializer.  */
 
@@ -7485,24 +7544,6 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       return;
     }
 
-  /* Though unions appear to have multiple map components, they must only
-     have a single initializer since each map overlaps. TODO: squash map
-     constructors?  */
-  if (expr->ts.type == BT_UNION)
-    {
-      c = gfc_constructor_first (expr->value.constructor);
-      cm = c->n.component;
-      val = gfc_conv_initializer (c->expr, &expr->ts,
-                                  TREE_TYPE (cm->backend_decl),
-                                  cm->attr.dimension, cm->attr.pointer,
-                                  cm->attr.proc_pointer);
-      val = unshare_expr_without_location (val);
-
-      /* Append it to the constructor list.  */
-      CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
-      goto finish;
-    }
-
   cm = expr->ts.u.derived->components;
 
   for (c = gfc_constructor_first (expr->value.constructor);
@@ -7537,6 +7578,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 	CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
 				fold_convert (TREE_TYPE (cm->backend_decl),
 					      integer_zero_node));
+      else if (cm->ts.type == BT_UNION)
+        gfc_conv_union_initializer (v, cm, c->expr);
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -7549,7 +7592,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
 	}
     }
-finish:
+
   se->expr = build_constructor (type, v);
   if (init)
     TREE_CONSTANT (se->expr) = 1;

gcc/testsuite/ChangeLog

+2016-10-27  Fritz Reese <fritzoreese@gmail.com>
+
+	* gfortran.dg/dec_init_1.f90: Remove -fdump-tree-original.
+	* gfortran.dg/dec_init_2.f90: Likewise.
+	* gfortran.dg/dec_init_3.f90: New test.
+	* gfortran.dg/dec_init_4.f90: Likewise.
+
 2016-10-27  Bin Cheng  <bin.cheng@arm.com>
 
 	* gcc.dg/fold-narrowbopcst-1.c: New test.

gcc/testsuite/gfortran.dg/dec_init_1.f90

 ! { dg-do run }
-! { dg-options "-fdec-structure -finit-derived -finit-local-zero -fdump-tree-original" }
+! { dg-options "-fdec-structure -finit-derived -finit-local-zero" }
 !
 ! Test -finit-derived with DEC structure and union.
 !

gcc/testsuite/gfortran.dg/dec_init_2.f90

 ! { dg-do run }
-! { dg-options "-fdec-structure -finit-derived -finit-integer=42 -finit-real=nan -finit-logical=true -finit-character=32 -fdump-tree-original" }
+! { dg-options "-fdec-structure -finit-derived -finit-integer=42 -finit-real=nan -finit-logical=true -finit-character=32" }
 ! { dg-add-options ieee }
 !
 ! Test -finit-derived with DEC structure and union.

gcc/testsuite/gfortran.dg/dec_init_3.f90

+! { dg-do run }
+! { dg-options "-fdec-structure -finit-derived -finit-local-zero" }
+!
+! Test -finit-derived with DEC structure and union.
+!
+
+subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2)
+  implicit none
+  integer, intent(in) :: i1
+  real, intent(in) :: r1
+  character, intent(in) :: c1
+  logical, intent(in) :: l1
+  integer, intent(inout) :: i2
+  real, intent(inout) :: r2
+  character, intent(inout) :: c2
+  logical, intent(inout) :: l2
+  print *, i1, i2, l1, l2, c1, c2, r1, r2
+  if ( i1 .ne. 0 .or. i2 .ne. 0 ) call abort()
+  if ( l1 .or. l2 ) call abort()
+  if ( c1 .ne. achar(0) .or. c2 .ne. achar(0) ) call abort()
+  if ( r1 .ne. 0.0 .or. r2 .ne. 0.0 ) call abort()
+end subroutine
+
+subroutine sub
+  structure /s1/
+    integer i
+  end structure
+
+  structure /s2/
+    union
+      map
+        integer m11
+        real m12
+        character m13
+        logical m14
+      end map
+      map
+        logical m21
+        character m22
+        real m23
+        integer m24
+      end map
+      map
+        character(32) s
+        record /s1/ r
+      end map
+    end union
+  end structure
+  record /s2/ x
+  call dummy (x.m11, x.m12, x.m13, x.m14, x.m24, x.m23, x.m22, x.m21)
+  print *, x.r.i
+  if ( x.r.i .ne. 0 ) then
+    call abort ()
+  endif
+end subroutine
+
+call sub
+
+end

gcc/testsuite/gfortran.dg/dec_init_4.f90

+! { dg-do run }
+! { dg-options "-fdec-structure -finit-derived -finit-local-zero" }
+!
+! Test a UNION with explicit initialization and -finit-derived.
+!
+
+subroutine sub
+  structure /s2/
+    integer(4) :: i = 8
+    union ! U7
+      map
+        integer(4) :: x = 1600
+        integer(4) :: y = 1800
+      end map
+      map
+        integer(2) a, b, c, d, e, f, g, h
+      end map
+    end union
+  end structure
+  record /s2/ r2
+
+  ! Initialized unions
+  if ( r2.i .ne. 8 ) then
+    print *, 'structure init'
+    call abort()
+  endif
+
+  ! Explicit initializations
+  if ( r2.x .ne. 1600 .or. r2.y .ne. 1800) then
+    r2.x = r2.y
+    print *, 'union explicit init'
+    call abort()
+  endif
+
+  ! Initialization from -finit-derived
+  if ( r2.h .ne. 0 ) then
+    r2.h = 135
+    print *, 'union default init'
+    call abort()
+  endif
+
+end subroutine
+
+! Initialization expressions
+structure /s3/
+  integer(4) :: i = 8
+  union ! U7
+    map
+      integer(4) :: x = 1600
+      integer(4) :: y = 1800
+    end map
+    map
+      integer(2) a, b, c, d, e
+    end map
+  end union
+end structure
+
+record /s3/ r3
+
+! Initialized unions
+if ( r3.i .ne. 8 ) then
+  print *, 'structure init'
+  call abort()
+endif
+
+! Explicit initializations
+if ( r3.x .ne. 1600 .or. r3.y .ne. 1800) then
+  r3.x = r3.y
+  print *, 'union explicit init'
+  call abort()
+endif
+
+! Initialization from -finit-derived
+if ( r3.e .ne. 0 ) then
+  r3.e = 135
+  print *, 'union default init'
+  call abort()
+endif
+
+end