From 75a3c61ae44b7820baf7946c3ddf3632adedcccf Mon Sep 17 00:00:00 2001 From: Louis Krupp Date: Tue, 16 Jan 2018 01:09:11 +0000 Subject: [PATCH] re PR fortran/82257 (f951: Internal compiler error segmentation fault) 2018-01-15 Louis Krupp 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 PR fortran/82257 * gfortran.dg/unlimited_polymorphic_28.f90: New test. From-SVN: r256720 --- gcc/fortran/ChangeLog | 9 ++++ gcc/fortran/interface.c | 8 ++- gcc/fortran/misc.c | 3 +- gcc/fortran/resolve.c | 4 +- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/unlimited_polymorphic_28.f90 | 51 +++++++++++++++++++ 6 files changed, 76 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90 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 + + 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 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 + + PR fortran/82257 + * gfortran.dg/unlimited_polymorphic_28.f90: New test. + 2018-01-15 Martin Sebor 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 -- 2.30.2