diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 65bcfa6..43edfd8 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -184,8 +184,11 @@ gfc_typename (gfc_typespec *ts, bool for_hash) break; } 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(*)"); + if (ts1 && ts1->u.derived) + if (ts1->u.derived->attr.unlimited_polymorphic) + sprintf (buffer, "CLASS(*)"); + else + sprintf (buffer, "CLASS(%s)", ts1->u.derived->name); else sprintf (buffer, "CLASS(%s)", ts->u.derived->name); break; diff --git a/gcc/testsuite/gfortran.dg/PR96870.f90 b/gcc/testsuite/gfortran.dg/PR96870.f90 new file mode 100644 index 0000000..c1b321e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR96870.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! Test fix for PR96870 +! + +Program main_p + + implicit none + + Type :: t0 + End Type t0 + + Type, extends(t0) :: t1 + End Type t1 + + type(t0), target :: x + class(t0), pointer :: p + + p => x + Call sub_1(x) ! { dg-error "Type mismatch in argument .p. at .1.; passed TYPE\\(t0\\) to CLASS\\(t1\\)" } + Call sub_1(p) ! { dg-error "Type mismatch in argument .p. at .1.; passed CLASS\\(t0\\) to CLASS\\(t1\\)" } + Call sub_2(x) ! { dg-error "Type mismatch in argument .p. at .1.; passed TYPE\\(t0\\) to TYPE\\(t1\\)" } + Call sub_2(p) ! { dg-error "Type mismatch in argument .p. at .1.; passed CLASS\\(t0\\) to TYPE\\(t1\\)" } + stop + +Contains + + Subroutine sub_1(p) + class(t1), Intent(In) :: p + + return + End Subroutine sub_1 + + Subroutine sub_2(p) + type(t1), Intent(In) :: p + + return + End Subroutine sub_2 + +End Program main_p +