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

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

>>> +    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?
> What about keeping the original name?

This obviously does not work, since we cannot have two symbols with
the same name in one namespace.


>> 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?
> 12.5.2.1
>   /If RESULT is specified, the name of the result variable of the
> function is result-name and all occurrences of the function name in
> execution-part statements in the scoping unit refer to the function
> itself. If RESULT is not specified, the result variable is function-name
> and all occurrences of the function name in execution-part statements in
> the scoping unit are references to the result variable./
>
> I guess it is valid, and the f referenced is the (pointer) return value.
> If one wants the function to be (recursively) called, I guess it would
> need to use a result suffix. At least, that's what I would do.

Ok, thanks for pointing this out. I added a test case for the above
example. However there is still one variant of this which is not
working yet (see commented out line in the test case). Uncommenting
this line results in:

proc_ptr_13.f90: In function 'l':
proc_ptr_13.f90:157: error: type mismatch in comparison expression
logical(kind=4)
integer(kind=4) (*<T39d>) (void)
integer(kind=4)
if (D.1645 != 11) goto <D.1646>; else goto <D.1647>;

proc_ptr_13.f90:157: internal compiler error: verify_gimple failed

I haven't managed yet to fix this without breaking something else.
Seemingly something goes wrong somewhere in trans-*.c. I'm always
having some trouble with the trans-* stuff, but I'll keep trying.

Apart from the things above I made some more modifications to the
patch and added new test cases.

Cheers,
Janus

Index: gcc/testsuite/gfortran.dg/external_procedures_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/external_procedures_1.f90	(revision 142654)
+++ gcc/testsuite/gfortran.dg/external_procedures_1.f90	(working copy)
@@ -5,10 +5,11 @@
   subroutine A ()
     EXTERNAL A  ! { dg-error "EXTERNAL attribute conflicts with SUBROUTINE" }
   END
+
 function ext (y)
   real ext, y
-  external ext      ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
-  ext = y * y
+  external ext   ! { dg-error "is missing the pointer attribute" }
+  !ext = y * y
 end function ext
 
 function ext1 (y)
@@ -34,8 +35,8 @@ program main
 contains
   function inv (y)
     real inv, y
-    external inv     ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
-    inv = y * y * y
+    external inv   ! { dg-error "is missing the pointer attribute" }
+    !inv = y * y * y
   end function inv
 end program main
 
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 142654)
+++ 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 142654)
+++ gcc/fortran/decl.c	(working copy)
@@ -1667,6 +1667,17 @@ 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@");
+
+  if (gfc_current_state () == COMP_FUNCTION
+      && strcmp (name, gfc_current_block ()->name) == 0
+      && gfc_current_block ()->result
+      && strcmp ("ppr@", gfc_current_block ()->result->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 +4080,59 @@ 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 and EXTERNAL statements.  */
+  case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
+	  && strcmp (gfc_current_block ()->name, sym->name) == 0
+          && !(gfc_state_stack->previous
+	       && gfc_state_stack->previous->state == COMP_INTERFACE)
+	  && sym->attr.external;
+  /* 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 PROCEDURE/EXTERNAL/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 +4265,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 +4475,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 +4875,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 +5326,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 +5451,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 142654)
+++ 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);
@@ -2540,7 +2540,8 @@ resolve_function (gfc_expr *expr)
   if (expr->ts.type == BT_UNKNOWN)
     {
       if (expr->symtree->n.sym->result
-	    && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
+	    && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
+	    && !expr->symtree->n.sym->result->attr.proc_pointer)
 	expr->ts = expr->symtree->n.sym->result->ts;
     }
 
@@ -7935,18 +7936,41 @@ 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;
+	}
+      if (strcmp ("ppr@", sym->name) == 0)
+	{
+	  gfc_error ("Procedure pointer result '%s' at %L "
+		     "is missing the pointer attribute",
+		     sym->ns->proc_name->name, &sym->declared_at);
+	  return FAILURE;
+	}
     }
 
   return SUCCESS;
@@ -9114,11 +9138,14 @@ resolve_symbol (gfc_symbol *sym)
 	      /* Result may be in another namespace.  */
 	      resolve_symbol (sym->result);
 
-	      sym->ts = sym->result->ts;
-	      sym->as = gfc_copy_array_spec (sym->result->as);
-	      sym->attr.dimension = sym->result->attr.dimension;
-	      sym->attr.pointer = sym->result->attr.pointer;
-	      sym->attr.allocatable = sym->result->attr.allocatable;
+	      if (!sym->result->attr.proc_pointer)
+		{
+		  sym->ts = sym->result->ts;
+		  sym->as = gfc_copy_array_spec (sym->result->as);
+		  sym->attr.dimension = sym->result->attr.dimension;
+		  sym->attr.pointer = sym->result->attr.pointer;
+		  sym->attr.allocatable = sym->result->attr.allocatable;
+		}
 	    }
 	}
     }
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 142654)
+++ 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);
@@ -2575,6 +2601,8 @@ gfc_match_rvalue (gfc_expr **result)
       gfc_get_ha_sym_tree (name, &symtree);	/* Can't fail */
       sym = symtree->n.sym;
 
+      replace_hidden_procptr_result (&sym, &symtree);
+
       e = gfc_get_expr ();
       e->symtree = symtree;
       e->expr_type = EXPR_FUNCTION;
@@ -2904,7 +2932,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