Re: Procedure Pointers: a first patch

["Janus Weil" <jaydub66 at googlemail dot com>]

Hi all,

after fixing a few bugs related to PROCEDURE and INTERFACE statements,
I think it's time for me to return to my procedure pointer patch
(recent version attached), which still produces the same old
regressions it did a few weeks ago.

> The remaining failures now are:
>
> FAIL: gfortran.dg/f2c_6.f90
> FAIL: gfortran.dg/value_4.f90
> FAIL: gfortran.fortran-torture/execute/entry_7.f90

These are due to my present inability to distinguish between:

> interface
>  function f()
>    integer, pointer :: f
>  end function
> end interface
>
> ***
>
> interface
>  function f()
>    integer :: f
>  end function
> end interface
> pointer :: f
>
> The first one is a pointer-valued function, the second one a procedure
> pointer to an integer-valued function. No ambiguity here, right?
>
> But how does gfortran know? Presently I'm identifying procedure
> pointers as having
> 1) the "attr.pointer" attribute
> 2) one of these:
>    i) attr.procedure
>    ii) attr.external
>    iii) attr.flavor == FL_PROCEDURE && att.if_source == IFSRC_BODY
>
> If those criteria are met, I delete the pointer attribute and set the
> proc_pointer attribute (to distinguish it from normal pointers). The
> problem is that this identifies both of the above cases as procedure
> pointers.

My idea for solving this would be to make the proc_pointer field
wider, so that it can hold an additional state, which would indicate
that the symbol can definitely *not* be a procedure pointer. E.g. one
could use an enumeration like

typedef enum
{
  PROCPTR_MAYBE = 0,
  PROCPTR_NO,
  PROCPTR_YES
}
is_procptr;

So if a symbol has attr.pointer, then the default value PROCPTR_MAYBE
would indicate that this symbol *could* be a procedure pointer (e.g.
in the second case above). At some late resolving stage we would have
to convert this into PROCPTR_YES and delete attr.pointer.
For the first test case above, we would have to detect that the
POINTER attribute is specified inside the function body, which means
that it can not be a procedure pointer, and set PROCPTR_NO. With the
present patch we cannot make this distinction (i.e. we have no way to
remember this state).

I need some opinions on this solution. Do you think it makes sense? Is
there a case where it does not work? Or is there some easier way to
make the distinction?

Cheers,
Janus

Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90	(revision 136717)
+++ gcc/testsuite/gfortran.dg/proc_decl_1.f90	(working copy)
@@ -40,8 +40,6 @@ program prog
   procedure(dcos) :: my1
   procedure(amax0) :: my2  ! { dg-error "not allowed in PROCEDURE statement" }
 
-  procedure(),pointer:: ptr  ! { dg-error "not yet implemented" }
-
   type t
     procedure(),pointer:: p  ! { dg-error "not yet implemented" }
   end type
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 136717)
+++ gcc/fortran/interface.c	(working copy)
@@ -1959,6 +1959,17 @@ compare_actual_formal (gfc_actual_arglis
 	  return  0;
 	}
 
+      /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
+	 is provided for a procedure pointer formal argument.  */
+      if (f->sym->attr.proc_pointer
+	  && !a->expr->symtree->n.sym->attr.proc_pointer)
+	{
+	  if (where)
+	    gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+		       f->sym->name, &a->expr->where);
+	  return 0;
+	}
+
       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
 	 provided for a procedure formal argument.  */
       if (a->expr->ts.type != BT_PROCEDURE
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 136717)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -480,8 +480,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr
       else if (sym->attr.flavor == FL_PROCEDURE
 	       && se->expr != current_function_decl)
 	{
-	  gcc_assert (se->want_pointer);
-	  if (!sym->attr.dummy)
+	  if (!sym->attr.dummy && !sym->attr.proc_pointer)
 	    {
 	      gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
 	      se->expr = build_fold_addr_expr (se->expr);
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 136717)
+++ gcc/fortran/symbol.c	(working copy)
@@ -410,13 +410,18 @@ check_conflict (symbol_attribute *attr, 
 	  case FL_BLOCK_DATA:
 	  case FL_MODULE:
 	  case FL_LABEL:
-	  case FL_PROCEDURE:
 	  case FL_DERIVED:
 	  case FL_PARAMETER:
             a1 = gfc_code2string (flavors, attr->flavor);
             a2 = save;
 	    goto conflict;
 
+	  case FL_PROCEDURE:
+	    if (attr->proc_pointer) break;
+	    a1 = gfc_code2string (flavors, attr->flavor);
+            a2 = save;
+	    goto conflict;
+
 	  case FL_VARIABLE:
 	  case FL_NAMELIST:
 	  default:
@@ -557,13 +562,6 @@ check_conflict (symbol_attribute *attr, 
   conf (procedure, value)
   conf (procedure, volatile_)
   conf (procedure, entry)
-  /* TODO: Implement procedure pointers.  */
-  if (attr->procedure && attr->pointer)
-    {
-      gfc_error ("Fortran 2003: Procedure pointers at %L are "
-		 "not yet implemented in gfortran", where);
-      return FAILURE;
-    }
 
   a1 = gfc_code2string (flavors, attr->flavor);
 
@@ -619,11 +617,11 @@ check_conflict (symbol_attribute *attr, 
       break;
 
     case FL_PROCEDURE:
-      conf2 (intent);
+      if (!attr->proc_pointer)
+        conf2 (intent);
 
       if (attr->subroutine)
 	{
-	  conf2 (pointer);
 	  conf2 (target);
 	  conf2 (allocatable);
 	  conf2 (result);
@@ -866,6 +864,12 @@ gfc_add_external (symbol_attribute *attr
       return FAILURE;
     }
 
+  if (attr->pointer)
+    {
+      attr->pointer = 0;
+      attr->proc_pointer = 1;
+    }
+
   attr->external = 1;
 
   return check_conflict (attr, NULL, where);
@@ -916,7 +920,19 @@ gfc_add_pointer (symbol_attribute *attr,
   if (check_used (attr, NULL, where))
     return FAILURE;
 
-  attr->pointer = 1;
+  if (attr->pointer)
+    {
+      duplicate_attr ("POINTER", where);
+      return FAILURE;
+    }
+
+  if (attr->procedure || attr->external
+      || (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+      && gfc_find_state (COMP_INTERFACE) == FAILURE))
+    attr->proc_pointer = 1;
+  else
+    attr->pointer = 1;
+
   return check_conflict (attr, NULL, where);
 }
 
@@ -1337,6 +1353,12 @@ gfc_add_flavor (symbol_attribute *attr, 
       return FAILURE;
     }
 
+  /*if (f == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY && attr->pointer)
+    {
+      attr->pointer = 0;
+      attr->proc_pointer = 1;
+    }*/
+
   attr->flavor = f;
 
   return check_conflict (attr, name, where);
@@ -1476,6 +1498,13 @@ gfc_add_explicit_interface (gfc_symbol *
       return FAILURE;
     }
 
+  /*if (sym->attr.flavor == FL_PROCEDURE && source == IFSRC_IFBODY
+      && sym->attr.pointer)
+    {
+      sym->attr.pointer = 0;
+      sym->attr.proc_pointer = 1;
+    }*/
+
   sym->formal = formal;
   sym->attr.if_source = source;
 
@@ -1641,6 +1670,8 @@ gfc_copy_attr (symbol_attribute *dest, s
     goto fail;
   if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
     goto fail;
+  if (src->proc_pointer)
+    dest->proc_pointer = 1;
 
   return SUCCESS;
 
@@ -3574,7 +3605,7 @@ static void
 gen_fptr_param (gfc_formal_arglist **head,
                 gfc_formal_arglist **tail,
                 const char *module_name,
-                gfc_namespace *ns, const char *f_ptr_name)
+                gfc_namespace *ns, const char *f_ptr_name, int proc)
 {
   gfc_symbol *param_sym = NULL;
   gfc_symtree *param_symtree = NULL;
@@ -3593,7 +3624,10 @@ gen_fptr_param (gfc_formal_arglist **hea
 
   /* Set up the necessary fields for the fptr output param sym.  */
   param_sym->refs++;
-  param_sym->attr.pointer = 1;
+  if (proc)
+    param_sym->attr.proc_pointer = 1;
+  else
+    param_sym->attr.pointer = 1;
   param_sym->attr.dummy = 1;
   param_sym->attr.use_assoc = 1;
 
@@ -3773,21 +3807,23 @@ build_formal_args (gfc_symbol *new_proc_
   gfc_current_ns->proc_name = new_proc_sym;
 
   /* Generate the params.  */
-  if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
-      (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
+  if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
     {
       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
 		      gfc_current_ns, "cptr", old_sym->intmod_sym_id);
       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
-		      gfc_current_ns, "fptr");
-
+		      gfc_current_ns, "fptr", 1);
+    }
+  else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+    {
+      gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+		      gfc_current_ns, "cptr", old_sym->intmod_sym_id);
+      gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+		      gfc_current_ns, "fptr", 0);
       /* If we're dealing with c_f_pointer, it has an optional third arg.  */
-      if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
-	{
-	  gen_shape_param (&head, &tail,
-			   (const char *) new_proc_sym->module,
-			   gfc_current_ns, "shape");
-	}
+      gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
+		       gfc_current_ns, "shape");
+
     }
   else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
     {
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 136717)
+++ gcc/fortran/decl.c	(working copy)
@@ -4033,6 +4033,7 @@ match_procedure_decl (void)
   locus old_loc, entry_loc;
   gfc_symbol *sym, *proc_if = NULL;
   int num;
+  gfc_expr *initializer = NULL;
 
   old_loc = entry_loc = gfc_current_locus;
 
@@ -4151,7 +4152,7 @@ got_ts:
 	    return MATCH_ERROR;
 	}
 
-      if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
+      if (!sym->attr.dummy && gfc_add_external (&sym->attr, NULL) == FAILURE)
 	return MATCH_ERROR;
       if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
 	return MATCH_ERROR;
@@ -4171,6 +4172,36 @@ got_ts:
 	  sym->attr.function = sym->ts.interface->attr.function;
 	}
 
+      if (gfc_match (" =>") == MATCH_YES)
+	{
+	  if (!current_attr.pointer)
+	    {
+	      gfc_error ("Initialization at %C isn't for a pointer variable");
+	      m = MATCH_ERROR;
+	      goto cleanup;
+	    }
+
+	  m = gfc_match_null (&initializer);
+	  if (m == MATCH_NO)
+	    {
+	      gfc_error ("Pointer initialization requires a NULL() at %C");
+	      m = MATCH_ERROR;
+	    }
+
+	  if (gfc_pure (NULL))
+	    {
+	      gfc_error ("Initialization of pointer at %C is not allowed in "
+			 "a PURE procedure");
+	      m = MATCH_ERROR;
+	    }
+
+	  if (m != MATCH_YES)
+	    goto cleanup;
+
+	}
+
+      gfc_set_sym_referenced (sym);
+
       if (gfc_match_eos () == MATCH_YES)
 	return MATCH_YES;
       if (gfc_match_char (',') != MATCH_YES)
@@ -4180,6 +4211,11 @@ got_ts:
 syntax:
   gfc_error ("Syntax error in PROCEDURE statement at %C");
   return MATCH_ERROR;
+
+cleanup:
+  /* Free stuff up and return.  */
+  gfc_free_expr (initializer);
+  return m;
 }
 
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 136717)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -620,7 +620,7 @@ typedef struct
   unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
     optional:1, pointer:1, target:1, value:1, volatile_:1,
     dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
-    implied_index:1, subref_array_pointer:1;
+    implied_index:1, subref_array_pointer:1, proc_pointer:1;
 
   ENUM_BITFIELD (save_state) save:2;
 
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 136717)
+++ gcc/fortran/expr.c	(working copy)
@@ -2873,7 +2873,7 @@ gfc_check_pointer_assign (gfc_expr *lval
   int is_pure;
   int pointer, check_intent_in;
 
-  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
+  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN && !lvalue->symtree->n.sym->attr.proc_pointer)
     {
       gfc_error ("Pointer assignment target is not a POINTER at %L",
 		 &lvalue->where);
@@ -2893,7 +2893,8 @@ gfc_check_pointer_assign (gfc_expr *lval
   /* Check INTENT(IN), unless the object itself is the component or
      sub-component of a pointer.  */
   check_intent_in = 1;
-  pointer = lvalue->symtree->n.sym->attr.pointer;
+  pointer = lvalue->symtree->n.sym->attr.pointer
+	      | lvalue->symtree->n.sym->attr.proc_pointer;
 
   for (ref = lvalue->ref; ref; ref = ref->next)
     {
@@ -2932,6 +2933,10 @@ gfc_check_pointer_assign (gfc_expr *lval
   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
     return SUCCESS;
 
+  /* TODO checks on rvalue for a procedure pointer assignment.  */
+  if (lvalue->symtree->n.sym->attr.proc_pointer)
+    return SUCCESS;
+
   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
       gfc_error ("Different types in pointer assignment at %L; attempted "
@@ -2973,7 +2978,7 @@ gfc_check_pointer_assign (gfc_expr *lval
     lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
 
   attr = gfc_expr_attr (rvalue);
-  if (!attr.target && !attr.pointer)
+  if (!attr.target && !attr.pointer && lvalue->ts.type!=BT_PROCEDURE)
     {
       gfc_error ("Pointer assignment target is neither TARGET "
 		 "nor POINTER at %L", &rvalue->where);
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 136717)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -1104,6 +1104,31 @@ gfc_restore_sym (gfc_symbol * sym, gfc_s
 }
 
 
+/* Declare a procedure pointer.  */
+
+static tree
+get_proc_pointer_decl (gfc_symbol *sym)
+{
+  tree decl;
+
+  decl = sym->backend_decl;
+  if (decl)
+    return decl;
+
+  decl = build_decl (VAR_DECL, get_identifier (sym->name),
+		     build_pointer_type (gfc_get_function_type (sym)));
+
+  if (sym->ns->proc_name->backend_decl == current_function_decl
+      || sym->attr.contained)
+    gfc_add_decl_to_function (decl);
+  else
+    gfc_add_decl_to_parent_function (decl);
+
+  sym->backend_decl = decl;
+  return decl;
+}
+
+
 /* Get a basic decl for an external function.  */
 
 tree
@@ -1126,6 +1151,9 @@ gfc_get_extern_function_decl (gfc_symbol
      to know that.  */
   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
 
+  if (sym->attr.proc_pointer)
+    return get_proc_pointer_decl (sym);
+
   if (sym->attr.intrinsic)
     {
       /* Call the resolution function to get the actual name.  This is
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 136717)
+++ gcc/fortran/match.c	(working copy)
@@ -26,6 +26,7 @@ along with GCC; see the file COPYING3.  
 #include "match.h"
 #include "parse.h"
 
+int gfc_matching_procptr_assignment = 0;
 
 /* For debugging and diagnostic purposes.  Return the textual representation
    of the intrinsic operator OP.  */
@@ -1329,6 +1330,7 @@ gfc_match_pointer_assignment (void)
   old_loc = gfc_current_locus;
 
   lvalue = rvalue = NULL;
+  gfc_matching_procptr_assignment = 0;
 
   m = gfc_match (" %v =>", &lvalue);
   if (m != MATCH_YES)
@@ -1337,7 +1339,11 @@ gfc_match_pointer_assignment (void)
       goto cleanup;
     }
 
+  if (lvalue->symtree->n.sym->attr.proc_pointer)
+    gfc_matching_procptr_assignment = 1;
+
   m = gfc_match (" %e%t", &rvalue);
+  gfc_matching_procptr_assignment = 0;
   if (m != MATCH_YES)
     goto cleanup;
 
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(revision 136717)
+++ gcc/fortran/match.h	(working copy)
@@ -33,6 +33,8 @@ extern gfc_symbol *gfc_new_block;
    separate.  */
 extern gfc_st_label *gfc_statement_label;
 
+extern int gfc_matching_procptr_assignment;
+
 /****************** All gfc_match* routines *****************/
 
 /* match.c.  */
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 136717)
+++ gcc/fortran/primary.c	(working copy)
@@ -2324,6 +2324,9 @@ gfc_match_rvalue (gfc_expr **result)
 	}
     }
 
+  if (gfc_matching_procptr_assignment)
+    goto procptr0;
+
   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
     goto function0;
 
@@ -2400,6 +2403,23 @@ gfc_match_rvalue (gfc_expr **result)
     /* If we're here, then the name is known to be the name of a
        procedure, yet it is not sure to be the name of a function.  */
     case FL_PROCEDURE:
+
+    /* Procedure Pointer Assignments. */
+    procptr0:
+      if (gfc_matching_procptr_assignment)
+	{
+	  if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
+	  if (gfc_intrinsic_name (sym->name, 0)
+	      || gfc_intrinsic_name (sym->name, 1))
+	    sym->attr.intrinsic = 1;
+	  e = gfc_get_expr ();
+	  e->expr_type = EXPR_VARIABLE;
+	  e->symtree = symtree;
+	  m = match_varspec (e, 0);
+	  /* TODO: Parse functions returning a procptr.  */
+	  break;
+	}
+
       if (sym->attr.subroutine)
 	{
 	  gfc_error ("Unexpected use of subroutine name '%s' at %C",
@@ -2781,6 +2801,9 @@ match_variable (gfc_expr **result, int e
 	  break;
 	}
 
+      if (sym->attr.proc_pointer)
+	break;
+
       /* Fall through to error */
 
     default: