Dear All,
The patch for these PRs is fully explained by the the comments and/or
changelogs. PR66465 has no connection with PR68196, other than Damian
asking if it is connected!
Bootstrapped and regtested on x86_64/FC21 - OK for trunk and a few
weeks later 4.9 and 5 branches?
Cheers
Paul
2015-11-04 Paul Thomas <[email protected]>
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-04 Paul Thomas <[email protected]>
PR fortran/68196
* gfortran.dg/proc_ptr_47.f90: New test.
PR fortran/66465
* gfortran.dg/pr66465.f90: New test.
Index: gcc/fortran/check.c
===================================================================
*** gcc/fortran/check.c (revision 229571)
--- gcc/fortran/check.c (working copy)
*************** less_than_bitsize2 (const char *arg1, gf
*** 399,405 ****
static bool
same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
{
! if (gfc_compare_types (&e->ts, &f->ts))
return true;
gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
--- 399,413 ----
static bool
same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
{
! 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 "
Index: gcc/fortran/class.c
===================================================================
*** gcc/fortran/class.c (revision 229571)
--- gcc/fortran/class.c (working copy)
*************** has_finalizer_component (gfc_symbol *der
*** 843,849 ****
--- 843,853 ----
&& 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;
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c (revision 229571)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2366,2371 ****
--- 2366,2372 ----
gfc_component *c;
gfc_dt_list *dt;
gfc_namespace *ns;
+ tree tmp;
if (derived->attr.unlimited_polymorphic
|| (flag_coarray == GFC_FCOARRAY_LIB
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2517,2524 ****
node as DECL_CONTEXT of each FIELD_DECL. */
for (c = derived->components; c; c = c->next)
{
! if (c->attr.proc_pointer)
field_type = gfc_get_ppc_type (c);
else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
field_type = c->ts.u.derived->backend_decl;
else
--- 2518,2536 ----
node as DECL_CONTEXT of each FIELD_DECL. */
for (c = derived->components; c; c = c->next)
{
! /* 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
Index: gcc/testsuite/gfortran.dg/pr66465.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pr66465.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/pr66465.f90 (working copy)
***************
*** 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 <[email protected]>
+ !
+ 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
Index: gcc/testsuite/gfortran.dg/proc_ptr_47.f90
===================================================================
*** gcc/testsuite/gfortran.dg/proc_ptr_47.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/proc_ptr_47.f90 (working copy)
***************
*** 0 ****
--- 1,37 ----
+ ! { dg-do run }
+ ! Tests the fix for PR68196
+ !
+ ! Contributed by Damian Rouson <[email protected]>
+ !
+ 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
