2012-03-17 Tobias Burnus <burnus@net-b.de>

        PR fortran/52585
        * trans-intrinsic.c (gfc_conv_associated): Fix handling of
        procpointer dummy arguments.

2012-03-17  Tobias Burnus  <burnus@net-b.de>

        PR fortran/52585
        * gfortran.dg/proc_ptr_36.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@185485 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index bdc2d84..115747e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2012-03-17  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/52585
+       * trans-intrinsic.c (gfc_conv_associated): Fix handling of
+       procpointer dummy arguments.
+
 2012-03-16  Janne Blomqvist  <jb@gcc.gnu.org>
 
        * 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 (file)
--- 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 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2012-03-17  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/52585
+       * gfortran.dg/proc_ptr_36.f90: New.
+
 2012-03-16  Martin Jambor  <mjambor@suse.cz>
 
        * 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 (file)
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" } }