From 4dc86aa8aa24c359ebba7ac25530ce5af520a0c3 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Sat, 17 Mar 2012 18:03:59 +0100 Subject: re PR fortran/52585 (Wrong result for ASSOCIATED with dummy procedure pointer) 2012-03-17 Tobias Burnus PR fortran/52585 * trans-intrinsic.c (gfc_conv_associated): Fix handling of procpointer dummy arguments. 2012-03-17 Tobias Burnus PR fortran/52585 * gfortran.dg/proc_ptr_36.f90: New. From-SVN: r185485 --- gcc/fortran/ChangeLog | 6 ++++ gcc/fortran/trans-intrinsic.c | 33 ++++++++++++++------- gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gfortran.dg/proc_ptr_36.f90 | 48 +++++++++++++++++++++++++++++++ 4 files changed, 82 insertions(+), 10 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_36.f90 (limited to 'gcc') diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index bdc2d84..115747e 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 876eec5..ab4f47f 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 ab3261e..532cb9f 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 0000000..ada5c56 --- /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" } } -- cgit v1.1