The attach patch uses a temporary to possibly point at a
pointer that should not be pointed at something sometimes.
Regression tested on x86_64-*-freebsd. OK to commit?
2019-08-09 Steven G. Kargl <ka...@gcc.gnu.org>
PR fortran/88072
* misc.c (gfc_typename): Do not point to something that ought not
be point at.
2019-08-09 Steven G. Kargl <ka...@gcc.gnu.org>
PR fortran/88072
* gfortran.dg/pr88072.f90: New test.
* gfortran.dg/unlimited_polymorphic_28.f90: Fix error message.
--
Steve
Index: gcc/fortran/misc.c
===================================================================
--- gcc/fortran/misc.c (revision 274238)
+++ gcc/fortran/misc.c (working copy)
@@ -128,6 +128,7 @@ gfc_typename (gfc_typespec *ts)
static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
static int flag = 0;
char *buffer;
+ gfc_typespec *ts1;
buffer = flag ? buffer1 : buffer2;
flag = !flag;
@@ -159,9 +160,8 @@ gfc_typename (gfc_typespec *ts)
sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
break;
case BT_CLASS:
- if (ts->u.derived->components)
- ts = &ts->u.derived->components->ts;
- if (ts->u.derived->attr.unlimited_polymorphic)
+ ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
+ if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
sprintf (buffer, "CLASS(*)");
else
sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
Index: gcc/testsuite/gfortran.dg/pr88072.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr88072.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr88072.f90 (working copy)
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! PR fortran/88072
+! Original code contributed by Andrew Wood <andrew at fluidgravity dot co.uk>
+module m1
+
+ implicit none
+
+ type, abstract, public :: t1
+ integer, dimension(:), allocatable :: i
+ contains
+ procedure(f1), deferred :: f
+ end type t1
+
+ type, extends(t1), public :: t2 ! { dg-error "must be ABSTRACT because" }
+ contains
+ procedure :: f => f2 ! { dg-error "mismatch for the overriding" }
+ end type t2
+
+ abstract interface
+ function f1(this) ! { dg-error "must be dummy, allocatable or" }
+ import
+ class(t1) :: this
+ class(t1) :: f1
+ end function f1
+ end interface
+ contains
+ type(t2) function f2(this)
+ class(t2) :: this
+ end function f2
+end module m1
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90 (revision 274238)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90 (working copy)
@@ -21,7 +21,7 @@ implicit none
type,abstract,extends(c_base) :: c_derived
contains
- procedure :: f_base => f_derived ! { dg-error "Type mismatch in function result \\(CLASS\\(\\*\\)/CLASS\\(c_base\\)\\)" }
+ procedure :: f_base => f_derived ! { dg-error "Type mismatch in function result" }
end type c_derived
contains
