Re: Procedure Pointers: a first patch

[Tobias Burnus <burnus at net-b dot de>]

Hi all, hi Janus,

Janus Weil wrote:
> > Well, the problem is that the procedure pointer is passed as value and not
> > as reference.
> > See  http://gcc.gnu.org/ml/fortran/2008-05/msg00299.html
> >     
Try the attached patch (on top of your patch) and the attached test program:

$ gfortran proc_pointer_1.f90 proc_pointer_1_c.c
$ ./a.out
$

I'm not sure whether my patch is really elegant, but it seems to work ;-)

Tobias
! { dg-do run }
! { dg-additional-sources proc_pointer_1_c.c }
!
! PR fortran/32580
! Procedure pointer test
!
program proc_pointer_test
  use iso_c_binding, only: c_int
  implicit none

  interface
    subroutine assignF(f)
      import c_int
      procedure(Integer(c_int)), pointer :: f
    end subroutine
  end interface

  procedure(Integer(c_int)), pointer :: ptr

  call assignF(ptr)
  if(ptr() /= 42) call abort()

  ptr => f55
  if(ptr() /= 55) call abort()  

  call foo(ptr)
  if(ptr() /= 65) call abort()  

contains

 subroutine foo(a)
   procedure(integer(c_int)), pointer :: a
   if(a() /= 55) call abort()
   a => f65
   if(a() /= 65) call abort()
 end subroutine foo

 integer(c_int) function f55()
    f55 = 55
 end function f55

 integer(c_int) function f65()
    f65 = 65
 end function f65
end program proc_pointer_test

/* Procedure pointer test. Used by proc_pointer_1.f90.
   PR fortran/32580.  */

int f(void) {
  return 42;
}

void assignf_(int(**ptr)(void)) {
  *ptr = f;
}

Index: trans-expr.c
===================================================================
--- trans-expr.c	(Revision 137004)
+++ trans-expr.c	(Arbeitskopie)
@@ -1372,6 +1371,8 @@ gfc_conv_function_val (gfc_se * se, gfc_
   if (sym->attr.dummy)
     {
       tmp = gfc_get_symbol_decl (sym);
+      if (sym->attr.proc_pointer)
+        tmp = build_fold_indirect_ref (tmp);
       gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
 	      && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
     }
@@ -2498,9 +2499,10 @@ gfc_conv_function_call (gfc_se * se, gfc
 	      else
 		{
 		  gfc_conv_expr_reference (&parmse, e);
-		  if (fsym && fsym->attr.pointer
-		      && fsym->attr.flavor != FL_PROCEDURE
-		      && e->expr_type != EXPR_NULL)
+		  if (fsym && e->expr_type != EXPR_NULL
+		      && ((fsym->attr.pointer
+			   && fsym->attr.flavor != FL_PROCEDURE)
+			  || fsym->attr.proc_pointer))
 		    {
 		      /* Scalar pointer dummy args require an extra level of
 			 indirection. The null pointer already contains
@@ -3867,6 +3869,11 @@ gfc_trans_pointer_assignment (gfc_expr *
       gfc_init_se (&rse, NULL);
       rse.want_pointer = 1;
       gfc_conv_expr (&rse, expr2);
+
+      if (expr1->symtree->n.sym->attr.proc_pointer
+	  && expr1->symtree->n.sym->attr.dummy)
+	lse.expr = build_fold_indirect_ref (lse.expr);
+
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
       gfc_add_modify_expr (&block, lse.expr,
Index: trans-decl.c
===================================================================
--- trans-decl.c	(Revision 137004)
+++ trans-decl.c	(Arbeitskopie)
@@ -1540,6 +1581,9 @@ create_function_arglist (gfc_symbol * sy
 	    type = gfc_sym_type (f->sym);
 	}
 
+      if (f->sym->attr.proc_pointer)
+        type = build_pointer_type (type);
+
       /* Build a the argument declaration.  */
       parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);