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

[Fritz Reese <fritzoreese@gmail.com>]

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

When union type symbols are compared and they contain maps containing
characters with different lengths, their type symbols should have
different backend declarations otherwise the gimple tree explodes.
Strangely enough the gimple checker only explodes with '-g' enabled
and certain other specific conditions, however the problem seems
clear. See the attached testcase for an example, and the attached
patch for a fix.

RFC: My only concern is that this patch would technically also change
the way components are compared between derived types and class types,
not just union/map types. However from what I can tell if two derived
types are declared with character components of different lengths then
the two types should have distinct backend declarations anyway. If
anyone can think of any issues this patch might cause with derived
types/class types then I'd be okay guarding the new if statement to
only run for union/structure types. But with all my tests it doesn't
seem to result in any concrete differences.

The patch does pass all regression tests on x86_64-redhat-linux. I
will give it a couple days for the RFC before committing.

---
Fritz Reese

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

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

        * gcc/fortran/interface.c (compare_components): Check charlens.

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

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index e7f1878..17f544e 100644
--- a/gcc/fortran/interface.c
+++ b/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)
diff --git a/gcc/testsuite/gfortran.dg/dec_union_11.f90
b/gcc/testsuite/gfortran.dg/dec_union_11.f90
new file mode 100644
index 0000000..3ff4b49

diff --git a/gcc/testsuite/gfortran.dg/dec_union_11.f90
b/gcc/testsuite/gfortran.dg/dec_union_11.f90
new file mode 100644
index 0000000..3ff4b49
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dec_union_11.f90
@@ -0,0 +1,63 @@
+! { 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

[-- Attachment #2: comp_charlen.patch --]
[-- Type: text/x-patch, Size: 2349 bytes --]

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index e7f1878..17f544e 100644
--- a/gcc/fortran/interface.c
+++ b/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)
diff --git a/gcc/testsuite/gfortran.dg/dec_union_11.f90 b/gcc/testsuite/gfortran.dg/dec_union_11.f90
new file mode 100644
index 0000000..3ff4b49
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dec_union_11.f90
@@ -0,0 +1,63 @@
+! { 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