From: Paul Thomas Date: Sun, 8 Nov 2015 16:47:58 +0000 (+0000) Subject: re PR fortran/68196 (ICE on function result with procedure pointer component) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=57905c2bb3dc00409591f58a8e335cd16c2940ff;p=gcc.git re PR fortran/68196 (ICE on function result with procedure pointer component) 2015-11-08 Paul Thomas 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-08 Paul Thomas PR fortran/68196 * gfortran.dg/proc_ptr_47.f90: New test. PR fortran/66465 * gfortran.dg/pr66465.f90: New test. From-SVN: r229954 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index fc3afba3aaf..ce3d7d03410 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2015-11-08 Paul Thomas + + 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-07 Steven G. Kargl PR fortran/68153 @@ -111,7 +125,7 @@ PR fortran/68154 * decl.c (add_init_expr_to_sym): if the char length in the typespec - is NULL, check for and use a constructor. + is NULL, check for and use a constructor. 2015-10-30 Steven G. Kargl diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 86dae5b000c..038ee218d94 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 ("%qs argument of %qs intrinsic at %L must be the same type " diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 7a9e2755a0f..8b49ae95a20 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -843,7 +843,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 780200e5f5d..ad6cee87606 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2366,6 +2366,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 || (flag_coarray == GFC_FCOARRAY_LIB @@ -2517,8 +2518,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 7cc0ac9d3be..2801c946fe7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2015-11-08 Paul Thomas + + PR fortran/68196 + * gfortran.dg/proc_ptr_47.f90: New test. + + PR fortran/66465 + * gfortran.dg/pr66465.f90: New test. + 2015-11-07 John David Anglin * gcc.dg/Wno-frame-address.c: Skip on hppa*-*-*. @@ -36,7 +44,7 @@ 2015-11-06 Dominique d'Humieres PR fortran/54224 - * gfortran.dg/warn_unused_function_2.f90: Add two new + * gfortran.dg/warn_unused_function_2.f90: Add two new "defined but not used" subroutines. 2015-11-06 Jakub Jelinek diff --git a/gcc/testsuite/gfortran.dg/pr66465.f90 b/gcc/testsuite/gfortran.dg/pr66465.f90 new file mode 100644 index 00000000000..ab868305051 --- /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 00000000000..43084f67e40 --- /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