From fec5ce248546144be3bec8655fd72c091c813594 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Thu, 15 Dec 2016 15:07:51 +0100 Subject: [PATCH] re PR fortran/78800 ([OOP] ICE in compare_parameter, at fortran/interface.c:2246) 2016-12-15 Janus Weil PR fortran/78800 * interface.c (compare_allocatable): Avoid additional errors on bad class declarations. (compare_parameter): Put the result of gfc_expr_attr into a variable, in order to avoid calling it multiple times. Exit early on bad class declarations to avoid ICE. 2016-12-15 Janus Weil PR fortran/78800 * gfortran.dg/unlimited_polymorphic_27.f90: New test case. From-SVN: r243691 --- gcc/fortran/ChangeLog | 9 +++++++++ gcc/fortran/interface.c | 19 ++++++++++--------- gcc/testsuite/ChangeLog | 5 +++++ .../gfortran.dg/unlimited_polymorphic_27.f90 | 16 ++++++++++++++++ 4 files changed, 40 insertions(+), 9 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/unlimited_polymorphic_27.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 17bc404583f..604c4d401fe 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2016-12-15 Janus Weil + + PR fortran/78800 + * interface.c (compare_allocatable): Avoid additional errors on bad + class declarations. + (compare_parameter): Put the result of gfc_expr_attr into a variable, + in order to avoid calling it multiple times. Exit early on bad class + declarations to avoid ICE. + 2016-12-14 Martin Jambor * trans-openmp.c: Include omp-general.h. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index a6f4e7204e1..8c09b905181 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2075,13 +2075,13 @@ done: static int compare_allocatable (gfc_symbol *formal, gfc_expr *actual) { - symbol_attribute attr; - if (formal->attr.allocatable || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable)) { - attr = gfc_expr_attr (actual); - if (!attr.allocatable) + symbol_attribute attr = gfc_expr_attr (actual); + if (actual->ts.type == BT_CLASS && !attr.class_ok) + return 1; + else if (!attr.allocatable) return 0; } @@ -2237,6 +2237,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } + symbol_attribute actual_attr = gfc_expr_attr (actual); + if (actual->ts.type == BT_CLASS && !actual_attr.class_ok) + return 1; + if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) && actual->ts.type != BT_HOLLERITH && formal->ts.type != BT_ASSUMED @@ -2278,9 +2282,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } - if (!gfc_expr_attr (actual).class_ok) - return 0; - if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual)) && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, CLASS_DATA (formal)->ts.u.derived)) @@ -2345,7 +2346,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, /* F2015, 12.5.2.8. */ if (formal->attr.dimension && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) - && gfc_expr_attr (actual).dimension + && actual_attr.dimension && !gfc_is_simply_contiguous (actual, true, true)) { if (where) @@ -2406,7 +2407,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } if (formal->attr.allocatable && !formal->attr.codimension - && gfc_expr_attr (actual).codimension) + && actual_attr.codimension) { if (formal->attr.intent == INTENT_OUT) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 081bfe14871..9a95e010308 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-12-15 Janus Weil + + PR fortran/78800 + * gfortran.dg/unlimited_polymorphic_27.f90: New test case. + 2016-12-15 Toma Tabacu * gcc.target/mips/mips.exp (mips-dg-options): Upgrade to R2 for diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_27.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_27.f90 new file mode 100644 index 00000000000..c16831eff78 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_27.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 78800: [OOP] ICE in compare_parameter, at fortran/interface.c:2246 +! +! Contributed by Gerhard Steinmetz + +program p + type t + end type + class(*) :: z ! { dg-error "must be dummy, allocatable or pointer" } + call s(z) +contains + subroutine s(x) + type(t) :: x + end +end -- 2.30.2