From: Paul Thomas Date: Wed, 25 Nov 2015 05:28:10 +0000 (+0000) Subject: backport: re PR fortran/68196 (ICE on function result with procedure pointer component) X-Git-Tag: releases/gcc-4.9.4~491 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=371d702b7d9abed69137d4cb0f368f2c748b1049;p=thirdparty%2Fgcc.git backport: re PR fortran/68196 (ICE on function result with procedure pointer component) 2015-11-25 Paul Thomas Backport from trunk. PR fortran/68196 * class.c (has_finalizer_component): Prevent infinite recursion through this function if the derived type and that of its component are the same. * trans-types.c (gfc_get_derived_type): Do the same for proc pointers by ignoring the explicit interface for the component. PR fortran/66465 * check.c (same_type_check): If either of the expressions is BT_PROCEDURE, use the typespec from the symbol, rather than the expression. 2015-11-25 Paul Thomas Backport from trunk. PR fortran/68196 * gfortran.dg/proc_ptr_47.f90: New test. Backport from trunk. PR fortran/66465 * gfortran.dg/pr66465.f90: New test. From-SVN: r230852 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 337bd32eaf87..33270a1c24fb 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2015-11-25 Paul Thomas + + Backport from trunk. + PR fortran/68196 + * class.c (has_finalizer_component): Prevent infinite recursion + through this function if the derived type and that of its + component are the same. + * trans-types.c (gfc_get_derived_type): Do the same for proc + pointers by ignoring the explicit interface for the component. + + PR fortran/66465 + * check.c (same_type_check): If either of the expressions is + BT_PROCEDURE, use the typespec from the symbol, rather than the + expression. + 2013-10-19 Paul Thomas Backport from trunk diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index b83d9da148db..07cacd048fc4 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -399,7 +399,15 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, static bool same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) { - if (gfc_compare_types (&e->ts, &f->ts)) + gfc_typespec *ets = &e->ts; + gfc_typespec *fts = &f->ts; + + if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym) + ets = &e->symtree->n.sym->ts; + if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym) + fts = &f->symtree->n.sym->ts; + + if (gfc_compare_types (ets, fts)) return true; gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type " diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index f83a24bd1b00..32ddb6e34f7f 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -840,7 +840,11 @@ has_finalizer_component (gfc_symbol *derived) && c->ts.u.derived->f2k_derived->finalizers) return true; + /* Stop infinite recursion through this function by inhibiting + calls when the derived type and that of the component are + the same. */ if (c->ts.type == BT_DERIVED + && !gfc_compare_derived_types (derived, c->ts.u.derived) && !c->attr.pointer && !c->attr.allocatable && has_finalizer_component (c->ts.u.derived)) return true; diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 20069e239ccc..26db35fb8f5c 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2342,6 +2342,7 @@ gfc_get_derived_type (gfc_symbol * derived) gfc_component *c; gfc_dt_list *dt; gfc_namespace *ns; + tree tmp; if (derived->attr.unlimited_polymorphic) return ptr_type_node; @@ -2490,8 +2491,19 @@ gfc_get_derived_type (gfc_symbol * derived) node as DECL_CONTEXT of each FIELD_DECL. */ for (c = derived->components; c; c = c->next) { - if (c->attr.proc_pointer) + /* Prevent infinite recursion, when the procedure pointer type is + the same as derived, by forcing the procedure pointer component to + be built as if the explicit interface does not exist. */ + if (c->attr.proc_pointer + && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) + || (c->ts.u.derived + && !gfc_compare_derived_types (derived, c->ts.u.derived)))) field_type = gfc_get_ppc_type (c); + else if (c->attr.proc_pointer && derived->backend_decl) + { + tmp = build_function_type_list (derived->backend_decl, NULL_TREE); + field_type = build_pointer_type (tmp); + } else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) field_type = c->ts.u.derived->backend_decl; else diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 04a458433e7c..c2ba540f25dd 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2015-11-25 Paul Thomas + + Backport from trunk. + PR fortran/68196 + * gfortran.dg/proc_ptr_47.f90: New test. + + Backport from trunk. + PR fortran/66465 + * gfortran.dg/pr66465.f90: New test. + 2015-11-24 Kyrylo Tkachov Backport from mainline diff --git a/gcc/testsuite/gfortran.dg/pr66465.f90 b/gcc/testsuite/gfortran.dg/pr66465.f90 new file mode 100644 index 000000000000..ab8683050511 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr66465.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! Tests the fix for PR66465, in which the arguments of the call to +! ASSOCIATED were falsly detected to have different type/kind. +! +! Contributed by Damian Rouson +! + interface + real function HandlerInterface (arg) + real :: arg + end + end interface + + type TextHandlerTestCase + procedure (HandlerInterface), nopass, pointer :: handlerOut=>null() + end type + + type(TextHandlerTestCase) this + + procedure (HandlerInterface), pointer :: procPtr=>null() + + print*, associated(procPtr, this%handlerOut) +end diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 new file mode 100644 index 000000000000..43084f67e401 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! Tests the fix for PR68196 +! +! Contributed by Damian Rouson +! + type AA + integer :: i + procedure(foo), pointer :: funct + end type + class(AA), allocatable :: my_AA + type(AA) :: res + + allocate (my_AA, source = AA (1, foo)) + + res = my_AA%funct () + + if (res%i .ne. 3) call abort + if (.not.associated (res%funct)) call abort + if (my_AA%i .ne. 4) call abort + if (associated (my_AA%funct)) call abort + +contains + function foo(A) + class(AA), allocatable :: A + type(AA) foo + + if (.not.allocated (A)) then + allocate (A, source = AA (2, foo)) + endif + + select type (A) + type is (AA) + foo = AA (3, foo) + A = AA (4, NULL ()) + end select + end function +end