Re: [4.5, Patch, Fortran] PR 36704: Procedure pointer as function result

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

Hi Mikael,

first off: thanks a lot for your review!

> Now, the details.
>
> About this:
> +
> +  if (add_hidden_procptr_result (sym) == SUCCESS)
> +    sym = sym->result;
> +
> Is it really needed in the case of a subroutine ?

Actually, yes. This snippet appearing inside gfc_match_subroutine is
needed for cases like the one labeled "h" in my test case, where a
function returns a pointer to a subroutine, and the subroutine is
specified by an INTERFACE statement.


> +    sym = sym->result;
> sym->name becomes invalid. Try this for example:
> --- proc_ptr_13.f90     2008-12-08 16:44:13.000000000 +0100
> +++ proc_ptr_13.f90.old 2008-12-08 16:44:08.000000000 +0100
> @@ -57,7 +57,7 @@
>   function f()
>     pointer :: f
>     interface
> -      integer function f(x) bind(c)
> +      integer function f(x)
>         integer :: x
>       end function
>     end interface

Hm, good point. In the error message the wrong name appears. However,
I'm not sure how to fix this. Anyway I need to replace the symbol by
sym->result here, so that the rest of the function interface is
applied to the result, not to the original function symbol.

I don't really want to add an extra check like "if (strcmp
("ppr@",sym->name) ..." to every possible error message :(

Ideas, anyone?


> +  else if (strcmp (block_name, "ppr@") == 0
> This is hard to understand if it's not used close to where "ppr@" was
> defined. One should either use sym->attr.proc_pointer && (...) or add a
> comment before explaining what we are doing  or simply reminding that
> ppr stands for procedure pointer result.

I don't think I can use sym->attr.proc_pointer here, since the pointer
attribute may not have been specified at this point (cf. case "g").
But a simple comment will do, I guess.


> Looks good otherwise. I failed to make it fail.

Nice to hear :)


> PS: Why not add a runtime test for h and i as well ?

Yeah, will do. No particular reason, apart from laziness.


> PPS: How are generic intrinsics handled? I tried this, and it doesn't
> complain. (And chooses the real_4 specific according to gdb).
> --- proc_ptr_13.f90.old 2008-12-08 16:44:08.000000000 +0100
> +++ proc_ptr_13.f90     2008-12-08 17:29:53.000000000 +0100
> @@ -90,10 +90,11 @@
>     pointer :: i
>     interface
>       function i(x)
> -        real :: i,x
> +        real :: i
> +        real(8) :: x
>       end function i
>     end interface
>     i => sin

Ok, this is more of a general procptr issue, not specific to function results.
One reason for this being accepted silently, is that there are still
some interface checks missing for procptr assignments (see PR38290).
This is next on my list for 4.5 :)


I also found one other thing that was missing: Up to now I only
included cases where the function gets assigned some value. However it
is also possible to assign another procptr to the return value inside
the function (see my new testcase "k"), which I fixed now.

Am I missing anything else? I think all other uses of a procptr return
value inside the returning function would be recursive. Or ambiguous
in some way. Example:

  function f()
    procedure(real),pointer :: f
    f => ...
    print *,f()
  end function

How would one interpret this? Which function is called in the print
statement? The function that is the return value of f? Or the function
f itself (recursively)? Is this example legal at all?


I have updated the patch & testcase, and also added a test for Tobias'
objection regarding use-association.

If there are any further comments on the patch: Keep it coming ;)
Anyway we'll have some time until this can be checked in. And I still
have to think of a way to handle the wrong name in error messages that
Mikael complained about ...

Cheers,
Janus

Index: gcc/testsuite/gfortran.dg/external_procedures_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/external_procedures_1.f90	(revision 142536)
+++ gcc/testsuite/gfortran.dg/external_procedures_1.f90	(working copy)
@@ -5,10 +5,10 @@
   subroutine A ()
     EXTERNAL A  ! { dg-error "EXTERNAL attribute conflicts with SUBROUTINE" }
   END
-function ext (y)
+function ext (y)   ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
   real ext, y
-  external ext      ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
-  ext = y * y
+  external ext
+  !ext = y * y
 end function ext
 
 function ext1 (y)
@@ -32,10 +32,10 @@ program main
   print *, ext1(inval)
   print *, inv(inval)
 contains
-  function inv (y)
+  function inv (y)  ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
     real inv, y
-    external inv     ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
-    inv = y * y * y
+    external inv
+    !inv = y * y * y
   end function inv
 end program main
 
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 142536)
+++ gcc/fortran/symbol.c	(working copy)
@@ -319,7 +319,7 @@ gfc_check_function_type (gfc_namespace *
 	      proc->attr.allocatable = proc->result->attr.allocatable;
 	    }
 	}
-      else
+      else if (!proc->result->attr.proc_pointer)
 	{
 	  gfc_error ("Function result '%s' at %L has no IMPLICIT type",
 		     proc->result->name, &proc->result->declared_at);
@@ -452,10 +452,7 @@ check_conflict (symbol_attribute *attr,
   conf (entry, intrinsic);
 
   if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
-    {
-      conf (external, subroutine);
-      conf (external, function);
-    }
+    conf (external, subroutine);
 
   conf (allocatable, pointer);
   conf_std (allocatable, dummy, GFC_STD_F2003);
@@ -625,14 +622,13 @@ check_conflict (symbol_attribute *attr,
       break;
 
     case FL_PROCEDURE:
-      /* Conflicts with INTENT will be checked at resolution stage,
-	 see "resolve_fl_procedure".  */
+      /* Conflicts with INTENT, SAVE and RESULT will be checked
+	 at resolution stage, see "resolve_fl_procedure".  */
 
       if (attr->subroutine)
 	{
 	  conf2 (target);
 	  conf2 (allocatable);
-	  conf2 (result);
 	  conf2 (in_namelist);
 	  conf2 (dimension);
 	  conf2 (function);
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 142536)
+++ gcc/fortran/decl.c	(working copy)
@@ -1667,6 +1667,11 @@ variable_decl (int elem)
 	}
     }
 
+  /* Procedure pointer as function result.  */
+  if (gfc_current_state () == COMP_FUNCTION
+      && strcmp ("ppr@", gfc_current_block ()->name) == 0
+      && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
+    strcpy (name, "ppr@");
 
   /* OK, we've successfully matched the declaration.  Now put the
      symbol in the current namespace, because it might be used in the
@@ -4069,6 +4074,57 @@ gfc_match_suffix (gfc_symbol *sym, gfc_s
 }
 
 
+/* Procedure pointer return value without RESULT statement:
+   Add "hidden" result variable.  */
+
+static gfc_try
+add_hidden_procptr_result (gfc_symbol *sym)
+{
+  bool case1,case2;
+  /* First usage case: PROCEDURE, EXTERNAL or POINTER statements.  */
+  case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block () != NULL
+	  && strcmp (gfc_current_block ()->name, sym->name) == 0
+	  && sym->attr.proc_pointer;
+  /* Second usage case: INTERFACE statements.  */
+  case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
+	  && gfc_state_stack->previous->state == COMP_FUNCTION
+	  && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
+
+  if (case1 || case2)
+    {
+      gfc_symtree *stree;
+      if (case1)
+        gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree);
+      else if (case2)
+        gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree);
+      sym->result = stree->n.sym;
+
+      sym->result->attr.proc_pointer = sym->attr.proc_pointer;
+      sym->result->attr.pointer = sym->attr.pointer;
+      sym->result->attr.external = sym->attr.external;
+      sym->result->attr.referenced = sym->attr.referenced;
+      sym->attr.proc_pointer = 0;
+      sym->attr.pointer = 0;
+      sym->attr.external = 0;
+
+      return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
+    }
+  /* POINTER after INTERFACE statement.  */
+  else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
+	   && sym->result && sym->result != sym && sym->result->attr.external
+	   && sym == gfc_current_ns->proc_name
+	   && sym == sym->result->ns->proc_name
+	   && strcmp ("ppr@", sym->result->name) == 0)
+    {
+      sym->result->attr.proc_pointer = 1;
+      sym->attr.pointer = 0;
+      return SUCCESS;
+    }
+  else
+    return FAILURE;
+}
+
+
 /* Match a PROCEDURE declaration (R1211).  */
 
 static match
@@ -4201,6 +4257,10 @@ got_ts:
 
       if (gfc_add_external (&sym->attr, NULL) == FAILURE)
 	return MATCH_ERROR;
+
+      if (add_hidden_procptr_result (sym) == SUCCESS)
+	sym = sym->result;
+
       if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
 	return MATCH_ERROR;
 
@@ -4407,6 +4467,10 @@ gfc_match_function_decl (void)
     }
   if (get_proc_name (name, &sym, false))
     return MATCH_ERROR;
+
+  if (add_hidden_procptr_result (sym) == SUCCESS)
+    sym = sym->result;
+
   gfc_new_block = sym;
 
   m = gfc_match_formal_arglist (sym, 0, 0);
@@ -4803,6 +4867,10 @@ gfc_match_subroutine (void)
 
   if (get_proc_name (name, &sym, false))
     return MATCH_ERROR;
+
+  if (add_hidden_procptr_result (sym) == SUCCESS)
+    sym = sym->result;
+
   gfc_new_block = sym;
 
   /* Check what next non-whitespace character is so we can tell if there
@@ -5250,12 +5318,21 @@ gfc_match_end (gfc_statement *st)
   if (block_name == NULL)
     goto syntax;
 
-  if (strcmp (name, block_name) != 0)
+  if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
     {
       gfc_error ("Expected label '%s' for %s statement at %C", block_name,
 		 gfc_ascii_statement (*st));
       goto cleanup;
     }
+  /* Procedure pointer as function result.  */
+  else if (strcmp (block_name, "ppr@") == 0
+	   && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
+    {
+      gfc_error ("Expected label '%s' for %s statement at %C",
+		 gfc_current_block ()->ns->proc_name->name,
+		 gfc_ascii_statement (*st));
+      goto cleanup;
+    }
 
   if (gfc_match_eos () == MATCH_YES)
     return MATCH_YES;
@@ -5366,6 +5443,8 @@ attr_decl1 (void)
       goto cleanup;
     }
 
+  add_hidden_procptr_result (sym);
+
   return MATCH_YES;
 
 cleanup:
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 142536)
+++ gcc/fortran/resolve.c	(working copy)
@@ -343,7 +343,7 @@ resolve_contained_fntype (gfc_symbol *sy
 	  if (sym->result == sym)
 	    gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
 		       sym->name, &sym->declared_at);
-	  else
+	  else if (!sym->result->attr.proc_pointer)
 	    gfc_error ("Result '%s' of contained function '%s' at %L has "
 		       "no IMPLICIT type", sym->result->name, sym->name,
 		       &sym->result->declared_at);
@@ -7935,18 +7935,34 @@ resolve_fl_procedure (gfc_symbol *sym, i
 	}
     }
   
-  if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
-    {
-      gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
-		 "in '%s' at %L", sym->name, &sym->declared_at);
-      return FAILURE;
-    }
-
-  if (sym->attr.intent && !sym->attr.proc_pointer)
+  if (!sym->attr.proc_pointer)
     {
-      gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
-		 "in '%s' at %L", sym->name, &sym->declared_at);
-      return FAILURE;
+      if (sym->attr.save == SAVE_EXPLICIT)
+	{
+	  gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
+		     "in '%s' at %L", sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+      if (sym->attr.intent)
+	{
+	  gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
+		     "in '%s' at %L", sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+      if (sym->attr.subroutine && sym->attr.result)
+	{
+	  gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
+		     "in '%s' at %L", sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+      if (sym->attr.external && sym->attr.function
+	  && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
+	      || sym->attr.contained))
+	{
+	  gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
+		     "in '%s' at %L", sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
     }
 
   return SUCCESS;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 142536)
+++ gcc/fortran/primary.c	(working copy)
@@ -2350,6 +2350,30 @@ check_for_implicit_index (gfc_symtree **
 }
 
 
+/* Procedure pointer as function result: Replace the function symbol by the
+   auto-generated hidden result variable named "ppr@".  */
+
+static gfc_try
+replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
+{
+  /* Check for procedure pointer result variable.  */
+  if ((*sym)->attr.function && !(*sym)->attr.external
+      && (*sym)->result && (*sym)->result != *sym
+      && (*sym)->result->attr.proc_pointer
+      && (*sym) == gfc_current_ns->proc_name
+      && (*sym) == (*sym)->result->ns->proc_name
+      && strcmp ("ppr@", (*sym)->result->name) == 0)
+    {
+      /* Automatic replacement with "hidden" result variable.  */
+      (*sym)->result->attr.referenced = (*sym)->attr.referenced;
+      *sym = (*sym)->result;
+      *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
+      return SUCCESS;
+    }
+  return FAILURE;
+}
+
+
 /* Matches a variable name followed by anything that might follow it--
    array reference, argument list of a function, etc.  */
 
@@ -2386,6 +2410,8 @@ gfc_match_rvalue (gfc_expr **result)
   e = NULL;
   where = gfc_current_locus;
 
+  replace_hidden_procptr_result (&sym, &symtree);
+
   /* If this is an implicit do loop index and implicitly typed,
      it should not be host associated.  */
   m = check_for_implicit_index (&symtree, &sym);
@@ -2904,7 +2930,8 @@ match_variable (gfc_expr **result, int e
 	  break;
 	}
 
-      if (sym->attr.proc_pointer)
+      if (sym->attr.proc_pointer
+	  || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
 	break;
 
       /* Fall through to error */

Attachment: proc_ptr_13.f90
Description: Binary data