From: Louis Krupp <louis.krupp@zoho.com>
Date: Tue, 16 Jan 2018 01:09:11 +0000 (+0000)
Subject: re PR fortran/82257 (f951: Internal compiler error segmentation fault)
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=75a3c61ae44b7820baf7946c3ddf3632adedcccf;p=gcc.git

re PR fortran/82257 (f951: Internal compiler error segmentation fault)

2018-01-15  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/82257
	* interface.c (compare_rank): Don't try to retrieve CLASS_DATA
	from symbol marked unlimited polymorphic.
	* resolve.c (resolve_structure_cons): Likewise.
	* misc.c (gfc_typename): Don't dereference derived->components
	if it's NULL.

2018-01-15  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/82257
	* gfortran.dg/unlimited_polymorphic_28.f90: New test.

From-SVN: r256720
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 453dc74ed66..0806ecd2ec7 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2018-01-15  Louis Krupp  <louis.krupp@zoho.com>
+
+	PR fortran/82257
+	* interface.c (compare_rank): Don't try to retrieve CLASS_DATA
+	from symbol marked unlimited polymorphic.
+	* resolve.c (resolve_structure_cons): Likewise.
+	* misc.c (gfc_typename): Don't dereference derived->components
+	if it's NULL.
+
 2018-01-15  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/54613
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index caa719e3ad5..9e55e9dc310 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -754,8 +754,12 @@ compare_rank (gfc_symbol *s1, gfc_symbol *s2)
   if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
     return true;
 
-  as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
-  as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
+  as1 = (s1->ts.type == BT_CLASS
+	 && !s1->ts.u.derived->attr.unlimited_polymorphic)
+	? CLASS_DATA (s1)->as : s1->as;
+  as2 = (s2->ts.type == BT_CLASS
+	 && !s2->ts.u.derived->attr.unlimited_polymorphic)
+	? CLASS_DATA (s2)->as : s2->as;
 
   r1 = as1 ? as1->rank : 0;
   r2 = as2 ? as2->rank : 0;
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 80d282efd07..ec1f548123a 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -156,7 +156,8 @@ gfc_typename (gfc_typespec *ts)
       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
       break;
     case BT_CLASS:
-      ts = &ts->u.derived->components->ts;
+      if (ts->u.derived->components)
+	ts = &ts->u.derived->components->ts;
       if (ts->u.derived->attr.unlimited_polymorphic)
 	sprintf (buffer, "CLASS(*)");
       else
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 67568710b05..1ecfe05ed79 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1289,7 +1289,9 @@ resolve_structure_cons (gfc_expr *expr, int init)
 	}
 
       rank = comp->as ? comp->as->rank : 0;
-      if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->as)
+      if (comp->ts.type == BT_CLASS
+	  && !comp->ts.u.derived->attr.unlimited_polymorphic
+	  && CLASS_DATA (comp)->as)
  	rank = CLASS_DATA (comp)->as->rank;
 
       if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index aae8d1a68fc..2933f83c32f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-01-15  Louis Krupp  <louis.krupp@zoho.com>
+
+	PR fortran/82257
+	* gfortran.dg/unlimited_polymorphic_28.f90: New test.
+
 2018-01-15  Martin Sebor  <msebor@redhat.com>
 
 	PR testsuite/83869
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90
new file mode 100644
index 00000000000..b474a243233
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90
@@ -0,0 +1,51 @@
+! { dg-do compile }
+!
+! PR 82257: ICE in gfc_typename(), compare_rank(), resolve_structure_cons()
+
+module m1
+
+implicit none
+
+  type,abstract :: c_base
+  contains
+    procedure(i1),private,deferred :: f_base
+  end type c_base
+
+  abstract interface
+    function i1(this) result(res)
+      import
+      class(c_base),intent(IN) :: this
+      class(c_base), pointer :: res
+    end function i1
+  end interface
+
+  type,abstract,extends(c_base) :: c_derived
+  contains
+    procedure :: f_base => f_derived ! { dg-error "Type mismatch in function result \\(CLASS\\(\\*\\)/CLASS\\(c_base\\)\\)" }
+  end type c_derived
+
+contains
+
+  function f_derived(this) result(res) ! { dg-error "must be dummy, allocatable or pointer" }
+    class(c_derived), intent(IN) :: this
+    class(*) :: res
+  end function f_derived
+
+end module m1
+
+module m2
+
+implicit none
+
+  type :: t
+  contains
+    procedure :: p
+  end type t
+
+contains
+
+  class(*) function p(this) ! { dg-error "must be dummy, allocatable or pointer" }
+    class(t), intent(IN) :: this
+  end function p
+
+end module m2