diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 9 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 8 | ||||
| -rw-r--r-- | gcc/fortran/misc.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 4 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90 | 51 |
6 files changed, 76 insertions, 4 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 453dc74..0806ecd 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 caa719e..9e55e9d 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 80d282e..ec1f548 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 6756871..1ecfe05 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 aae8d1a..2933f83 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 0000000..b474a24 --- /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 |