Fix ICE due to map typespecs with different sized charlens being copied.

2016-10-07  Fritz Reese  <fritzoreese@gmail.com>

Fix ICE due to map typespecs with different sized charlens being copied.

	gcc/fortran/
	* interface.c (compare_components): Check charlen for BT_CHAR.

	gcc/testsuite/gfortran.dg/
	* dec_union_11.f90: New testcase.

From-SVN: r240875

gcc/fortran/ChangeLog

+2016-10-07  Fritz Reese  <fritzoreese@gmail.com>
+
+	* interface.c (compare_components): Check charlen for BT_CHAR.
+
 2016-10-07  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/77406

gcc/fortran/interface.c

@@ -495,6 +495,17 @@ compare_components (gfc_component *cmp1, gfc_component *cmp2,
   if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
     return 0;
 
+  if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER)
+    {
+      gfc_charlen *l1 = cmp1->ts.u.cl;
+      gfc_charlen *l2 = cmp2->ts.u.cl;
+      if (l1 && l2 && l1->length && l2->length
+          && l1->length->expr_type == EXPR_CONSTANT
+          && l2->length->expr_type == EXPR_CONSTANT
+          && gfc_dep_compare_expr (l1->length, l2->length) != 0)
+        return 0;
+    }
+
   /* Make sure that link lists do not put this function into an
      endless recursive loop!  */
   if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)

gcc/testsuite/ChangeLog

+2016-10-07  Fritz Reese  <fritzoreese@gmail.com>
+
+	* gfortran.dg/dec_union_11.f90: New testcase.
+
 2016-10-07  Nathan Sidwell  <nathan@acm.org>
 
 	PR c++/66443

gcc/testsuite/gfortran.dg/dec_union_11.f90

+! { dg-do compile }
+! { dg-options "-g -fdec-structure" }
+!
+! Test a regression where typespecs of unions containing character buffers of
+! different lengths where copied, resulting in a bad gimple tree state.
+!
+
+subroutine sub2 (otherbuf)
+  integer, parameter :: L_bbuf = 65536
+  integer, parameter :: L_bbuf2 = 24
+
+  structure /buffer2/
+    union
+     map
+      character(L_bbuf2)  sbuf
+     end map
+    end union
+  end structure
+  structure /buffer/
+    union
+     map
+      character(L_bbuf)  sbuf
+     end map
+    end union
+  end structure
+
+  record /buffer/ buf1
+  record /buffer2/ buf2
+  common /c/ buf1, buf2
+
+  record /buffer2/ otherbuf
+end subroutine
+
+subroutine sub()
+  integer, parameter :: L_bbuf = 65536
+  integer, parameter :: L_bbuf2 = 24
+
+  structure /buffer2/
+    union
+     map
+      character(L_bbuf2)  sbuf
+     end map
+    end union
+  end structure
+  structure /buffer/
+    union
+     map
+      character(L_bbuf)  sbuf
+     end map
+    end union
+  end structure
+
+  record /buffer/ buf1
+  record /buffer2/ buf2
+  common /c/ buf1, buf2
+
+  call sub2 (buf1) ! { dg-warning "Type mismatch" }
+  return
+end subroutine
+
+call sub()
+
+end