diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index bdc2d849ee8..115747ea960 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2012-03-17 Tobias Burnus + + PR fortran/52585 + * trans-intrinsic.c (gfc_conv_associated): Fix handling of + procpointer dummy arguments. + 2012-03-16 Janne Blomqvist * trans-intrinsic.c (build_round_expr): Don't use BUILT_IN_IROUND diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 876eec55076..ab4f47fc5d3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5761,10 +5761,14 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) /* No optional target. */ if (ss1 == gfc_ss_terminator) { - /* A pointer to a scalar. */ - arg1se.want_pointer = 1; - gfc_conv_expr (&arg1se, arg1->expr); - tmp2 = arg1se.expr; + /* A pointer to a scalar. */ + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + if (arg1->expr->symtree->n.sym->attr.proc_pointer + && arg1->expr->symtree->n.sym->attr.dummy) + arg1se.expr = build_fold_indirect_ref_loc (input_location, + arg1se.expr); + tmp2 = arg1se.expr; } else { @@ -5794,12 +5798,21 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) if (ss1 == gfc_ss_terminator) { - /* A pointer to a scalar. */ - gcc_assert (ss2 == gfc_ss_terminator); - arg1se.want_pointer = 1; - gfc_conv_expr (&arg1se, arg1->expr); - arg2se.want_pointer = 1; - gfc_conv_expr (&arg2se, arg2->expr); + /* A pointer to a scalar. */ + gcc_assert (ss2 == gfc_ss_terminator); + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + if (arg1->expr->symtree->n.sym->attr.proc_pointer + && arg1->expr->symtree->n.sym->attr.dummy) + arg1se.expr = build_fold_indirect_ref_loc (input_location, + arg1se.expr); + + arg2se.want_pointer = 1; + gfc_conv_expr (&arg2se, arg2->expr); + if (arg2->expr->symtree->n.sym->attr.proc_pointer + && arg2->expr->symtree->n.sym->attr.dummy) + arg2se.expr = build_fold_indirect_ref_loc (input_location, + arg2se.expr); gfc_add_block_to_block (&se->pre, &arg1se.pre); gfc_add_block_to_block (&se->post, &arg1se.post); tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ab3261e03b7..532cb9f27b9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2012-03-17 Tobias Burnus + + PR fortran/52585 + * gfortran.dg/proc_ptr_36.f90: New. + 2012-03-16 Martin Jambor * gcc.dg/misaligned-expand-1.c: New test. diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_36.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_36.f90 new file mode 100644 index 00000000000..ada5c565872 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_36.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! PR fortran/52585 +! +! Test proc-pointer dummies with ASSOCIATE +! +! Contributed by Mat Cross of NAG +! +module m0 + abstract interface + subroutine sub + end subroutine sub + end interface + interface + subroutine s(ss, isassoc) + import sub + logical :: isassoc + procedure(sub), pointer, intent(in) :: ss + end subroutine s + end interface +end module m0 + +use m0, only : sub, s +procedure(sub) :: sub2, pp +pointer :: pp +pp => sub2 +if (.not. associated(pp)) call abort () +if (.not. associated(pp,sub2)) call abort () +call s(pp, .true.) +pp => null() +if (associated(pp)) call abort () +if (associated(pp,sub2)) call abort () +call s(pp, .false.) +end + +subroutine s(ss, isassoc) + use m0, only : sub + logical :: isassoc + procedure(sub), pointer, intent(in) :: ss + procedure(sub) :: sub2 + if (isassoc .neqv. associated(ss)) call abort () + if (isassoc .neqv. associated(ss,sub2)) call abort () +end subroutine s + +subroutine sub2 +end subroutine sub2 + +! { dg-final { cleanup-modules "m0" } }