re PR fortran/36704 (Procedure pointer as function result)

2009-04-09  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36704
	* decl.c (add_hidden_procptr_result): New function for handling
	procedure pointer return values by adding a hidden result variable.
	(variable_decl,match_procedure_decl,gfc_match_function_decl,
	gfc_match_subroutine,gfc_match_end,attr_decl1): Handle procedure pointer
	return values.
	* parse.c (parse_interface): Add EXTERNAL attribute only after
	FUNCTION/SUBROUTINE declaration is complete.
	* primary.c (replace_hidden_procptr_result): New function for replacing
	function symbol by hidden result variable.
	(gfc_match_rvalue,match_variable): Replace symbol by hidden result
	variable.
	* resolve.c (resolve_contained_fntype,resolve_function,resolve_variable,
	resolve_symbol): Allow for procedure pointer function results.
	(resolve_fl_procedure): Conflict detection moved here from
	'check_conflict'.
	* symbol.c (gfc_check_function_type): Allow for procedure pointer
	function results.
	(check_conflict): Move some conflict detection to resolution stage.
	* trans-types.c (gfc_sym_type,gfc_get_function_type): Handle hidden
	result variables.


2009-04-09  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36704
	* gfortran.dg/external_procedures_1.f90: Modified.
	* gfortran.dg/proc_ptr_result_1.f90: New.
	* gfortran.dg/proc_ptr_result_2.f90: New.
	* gfortran.dg/proc_ptr_result_3.f90: New.

From-SVN: r145815

gcc/fortran/ChangeLog

+2009-04-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36704
+	* decl.c (add_hidden_procptr_result): New function for handling
+	procedure pointer return values by adding a hidden result variable.
+	(variable_decl,match_procedure_decl,gfc_match_function_decl,
+	gfc_match_subroutine,gfc_match_end,attr_decl1): Handle procedure pointer
+	return values.
+	* parse.c (parse_interface): Add EXTERNAL attribute only after
+	FUNCTION/SUBROUTINE declaration is complete.
+	* primary.c (replace_hidden_procptr_result): New function for replacing
+	function symbol by hidden result variable.
+	(gfc_match_rvalue,match_variable): Replace symbol by hidden result
+	variable.
+	* resolve.c (resolve_contained_fntype,resolve_function,resolve_variable,
+	resolve_symbol): Allow for procedure pointer function results.
+	(resolve_fl_procedure): Conflict detection moved here from
+	'check_conflict'.
+	* symbol.c (gfc_check_function_type): Allow for procedure pointer
+	function results.
+	(check_conflict): Move some conflict detection to resolution stage.
+	* trans-types.c (gfc_sym_type,gfc_get_function_type): Handle hidden
+	result variables.
+
 2009-04-08  Jakub Jelinek  <jakub@redhat.com>
 
 	* trans-types.c (gfc_init_types): Ensure gfc_integer_types doesn't

gcc/fortran/decl.c

@@ -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,66 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
 }
 
 
+/* Procedure pointer return value without RESULT statement:
+   Add "hidden" result variable named "ppr@".  */
+
+static gfc_try
+add_hidden_procptr_result (gfc_symbol *sym)
+{
+  bool case1,case2;
+
+  if (gfc_notification_std (GFC_STD_F2003) == ERROR)
+    return FAILURE;
+
+  /* First usage case: PROCEDURE and EXTERNAL statements.  */
+  case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
+	  && strcmp (gfc_current_block ()->name, sym->name) == 0
+	  && 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;
+      if (sym->result->attr.external && sym->result->attr.pointer)
+	{
+	  sym->result->attr.pointer = 0;
+	  sym->result->attr.proc_pointer = 1;
+	}
+
+      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 +4272,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;
 
@@ -4415,6 +4490,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);
@@ -4812,6 +4891,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
@@ -5259,12 +5342,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;
@@ -5375,6 +5467,8 @@ attr_decl1 (void)
       goto cleanup;
     }
 
+  add_hidden_procptr_result (sym);
+
   return MATCH_YES;
 
 cleanup:

gcc/fortran/parse.c

@@ -2113,14 +2113,6 @@ loop:
 	  gfc_free_namespace (gfc_current_ns);
 	  goto loop;
 	}
-      if (current_interface.type != INTERFACE_ABSTRACT &&
-	 !gfc_new_block->attr.dummy &&
-	 gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
-	{
-	  reject_statement ();
-	  gfc_free_namespace (gfc_current_ns);
-	  goto loop;
-	}
       break;
 
     case ST_PROCEDURE:
@@ -2213,6 +2205,10 @@ decl:
       goto decl;
     }
 
+  /* Add EXTERNAL attribute to function or subroutine.  */
+  if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
+    gfc_add_external (&prog_unit->attr, &gfc_current_locus);
+
   current_interface = save;
   gfc_add_interface (prog_unit);
   pop_state ();

gcc/fortran/primary.c

@@ -2358,6 +2358,30 @@ check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
 }
 
 
+/* 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.  */
 
@@ -2394,6 +2418,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);
@@ -2583,6 +2609,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;
@@ -2912,7 +2940,8 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 	  break;
 	}
 
-      if (sym->attr.proc_pointer)
+      if (sym->attr.proc_pointer
+	  || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
 	break;
 
       /* Fall through to error */

gcc/fortran/resolve.c

@@ -344,7 +344,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
 	  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);
@@ -2530,7 +2530,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;
     }
 
@@ -4196,7 +4197,11 @@ resolve_variable (gfc_expr *e)
     return FAILURE;
 
   sym = e->symtree->n.sym;
-  if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
+  if (sym->attr.flavor == FL_PROCEDURE
+      && (!sym->attr.function
+	  || (sym->attr.function && sym->result
+	      && sym->result->attr.proc_pointer
+	      && !sym->result->attr.function)))
     {
       e->ts.type = BT_PROCEDURE;
       goto resolve_procedure;
@@ -8034,19 +8039,42 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
 	}
     }
   
-  if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
+  if (!sym->attr.proc_pointer)
+    {
+      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 && !sym->attr.proc_pointer)
+      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;
 }
@@ -9310,6 +9338,8 @@ resolve_symbol (gfc_symbol *sym)
 	      /* Result may be in another namespace.  */
 	      resolve_symbol (sym->result);
 
+	      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;
@@ -9318,6 +9348,7 @@ resolve_symbol (gfc_symbol *sym)
 		}
 	    }
 	}
+    }
 
   /* Assumed size arrays and assumed shape arrays must be dummy
      arguments.  */

gcc/fortran/symbol.c

@@ -320,7 +320,7 @@ gfc_check_function_type (gfc_namespace *ns)
 	      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);
@@ -453,10 +453,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (entry, intrinsic);
 
   if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
-    {
     conf (external, subroutine);
-      conf (external, function);
-    }
 
   conf (allocatable, pointer);
   conf_std (allocatable, dummy, GFC_STD_F2003);
@@ -626,14 +623,13 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       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);

gcc/fortran/trans-types.c

@@ -1616,8 +1616,8 @@ gfc_sym_type (gfc_symbol * sym)
   tree type;
   int byref;
 
-  /* Procedure Pointers inside COMMON blocks or as function result.  */
-  if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result))
+  /* Procedure Pointers inside COMMON blocks.  */
+  if (sym->attr.proc_pointer && sym->attr.in_common)
     {
       /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
       sym->attr.proc_pointer = 0;
@@ -2156,7 +2156,18 @@ gfc_get_function_type (gfc_symbol * sym)
     }
   else if (sym->result && sym->result->attr.proc_pointer)
     /* Procedure pointer return values.  */
+    {
+      if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
+	{
+	  /* Unset proc_pointer as gfc_get_function_type
+	     is called recursively.  */
+	  sym->result->attr.proc_pointer = 0;
+	  type = build_pointer_type (gfc_get_function_type (sym->result));
+	  sym->result->attr.proc_pointer = 1;
+	}
+      else
        type = gfc_sym_type (sym->result);
+    }
   else
     type = gfc_sym_type (sym);
 

gcc/testsuite/ChangeLog

+2009-04-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36704
+	* gfortran.dg/external_procedures_1.f90: Modified.
+	* gfortran.dg/proc_ptr_result_1.f90: New.
+	* gfortran.dg/proc_ptr_result_2.f90: New.
+	* gfortran.dg/proc_ptr_result_3.f90: New.
+
 2009-04-09  Richard Guenther  <rguenther@suse.de>
 
 	* gcc.dg/vect/vect-54.c: Make constant input data file-scope

gcc/testsuite/gfortran.dg/external_procedures_1.f90

 ! { dg-do compile }
+! { dg-options "-std=f95" }
+!
 ! This tests the patch for PR25024.
 
 ! PR25024 - The external attribute for subroutine a would cause an ICE.
   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)
@@ -24,18 +27,18 @@ program main
   interface
     function ext1 (y)
       real ext1, y
-      external ext1  ! { dg-error "Duplicate EXTERNAL attribute" }
-    end function ext1
+      external ext1
+    end function ext1  ! { dg-error "Duplicate EXTERNAL attribute" }
   end interface
   inval = 1.0
   print *, ext(inval)
   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
 

gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90

+! { dg-do run }
+!
+! PR 36704: Procedure pointer as function result
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module mo
+contains
+
+  function j()
+    procedure(),pointer :: j
+    intrinsic iabs
+    j => iabs
+  end function
+
+  subroutine sub(y)
+    integer,intent(inout) :: y
+    y = y**2
+  end subroutine
+
+end module
+
+
+program proc_ptr_14
+use mo
+implicit none
+intrinsic :: iabs
+integer :: x
+procedure(integer),pointer :: p,p2
+procedure(sub),pointer :: ps
+
+p => a()
+if (p(-1)/=1) call abort()
+p => b()
+if (p(-2)/=2) call abort()
+p => c()
+if (p(-3)/=3) call abort()
+p => d()
+if (p(-4)/=4) call abort()
+p => dd()
+if (p(-4)/=4) call abort()
+p => e(iabs)
+if (p(-5)/=5) call abort()
+p => ee()
+if (p(-5)/=5) call abort()
+p => f()
+if (p(-6)/=6) call abort()
+p => g()
+if (p(-7)/=7) call abort()
+
+ps => h(sub)
+x = 2
+call ps(x)
+if (x/=4) call abort()
+
+p => i()
+if (p(-8)/=8) call abort()
+p => j()
+if (p(-9)/=9) call abort()
+
+p => k(p2)
+if (p(-10)/=p2(-10)) call abort()
+
+p => l()
+if (p(-11)/=11) call abort()
+
+contains
+
+  function a()
+    procedure(integer),pointer :: a
+    a => iabs
+  end function
+
+  function b()
+    procedure(integer) :: b
+    pointer :: b
+    b => iabs
+  end function
+
+  function c()
+    pointer :: c
+    procedure(integer) :: c
+    c => iabs
+  end function
+
+  function d()
+    pointer :: d
+    external d
+    d => iabs
+  end function
+
+  function dd()
+    pointer :: dd
+    external :: dd
+    integer :: dd
+    dd => iabs
+  end function
+
+  function e(arg)
+    external :: e,arg
+    pointer :: e
+    e => arg
+  end function
+
+  function ee()
+    integer :: ee
+    external :: ee
+    pointer :: ee
+    ee => iabs
+  end function
+
+  function f()
+    pointer :: f
+    interface
+      integer function f(x)
+        integer :: x
+      end function
+    end interface
+    f => iabs
+  end function
+
+  function g()
+    interface
+      integer function g(x)
+        integer :: x
+      end function g
+    end interface
+    pointer :: g
+    g => iabs
+  end function
+
+  function h(arg)
+    interface
+      subroutine arg(b)
+        integer :: b
+      end subroutine arg
+    end interface
+    pointer :: h
+    interface
+      subroutine h(a)
+        integer :: a
+      end subroutine h
+    end interface
+    h => arg
+  end function
+
+  function i()
+    pointer :: i
+    interface
+      function i(x)
+        integer :: i,x
+      end function i
+    end interface
+    i => iabs
+  end function
+
+  function k(arg)
+    procedure(),pointer :: k,arg
+    k => iabs
+    arg => k
+  end function
+
+  function l()
+    procedure(iabs),pointer :: l
+    integer :: i
+    l => iabs
+    if (l(-11)/=11) call abort()
+  end function 
+
+end
+
+! { dg-final { cleanup-modules "mo" } }
+

gcc/testsuite/gfortran.dg/proc_ptr_result_2.f90

+! { dg-do compile }
+!
+! PR 36704: Procedure pointer as function result
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module proc_ptr_15
+
+  interface
+    function e(x)
+      real :: x
+      procedure(), pointer :: e
+    end function e
+  end interface
+
+  interface
+    function f(x)
+      real :: x
+      external :: f
+      pointer :: f
+    end function
+  end interface
+
+  interface
+    function g(x)
+      real :: x
+      pointer :: g
+      external :: g
+    end function
+  end interface
+
+contains
+
+  subroutine point_fun()
+    call set_fun(aux)
+  end subroutine
+
+  subroutine set_fun(y)
+    external :: y
+  end subroutine
+
+  function aux()
+    external aux
+    pointer aux
+    intrinsic sin
+    aux => sin
+  end function
+
+  function foo(x)
+    real :: x
+    interface
+      subroutine foo(i)  ! { dg-error "attribute conflicts with" }
+        integer :: i
+      end subroutine
+    end interface
+    !pointer :: foo
+  end function
+
+end
+
+! { dg-final { cleanup-modules "proc_ptr_15" } }
+

gcc/testsuite/gfortran.dg/proc_ptr_result_3.f90

+!{ dg-do run }
+!
+! PR 36704: Procedure pointer as function result
+!
+! Original test case from James Van Buskirk.
+!
+! Adapted by Janus Weil <janus@gcc.gnu.org>
+
+module store_subroutine
+   implicit none
+
+   abstract interface
+      subroutine sub(i)
+        integer, intent(inout) :: i
+      end subroutine sub
+   end interface
+
+   procedure(sub), pointer, private :: psub => NULL()
+
+contains
+
+   subroutine set_sub(x)
+      procedure(sub) x
+      psub => x
+   end subroutine set_sub
+
+   function get_sub()
+      procedure(sub), pointer :: get_sub
+      get_sub => psub
+   end function get_sub
+
+end module store_subroutine
+
+program test
+   use store_subroutine
+   implicit none
+   procedure(sub), pointer :: qsub
+   integer :: k = 1
+
+   call my_sub(k)
+   if (k/=3) call abort
+   qsub => get_sub()
+   call qsub(k)
+   if (k/=9) call abort
+end program test
+
+recursive subroutine my_sub(j)
+   use store_subroutine
+   implicit none
+   integer, intent(inout) :: j
+   j = j*3
+   call set_sub(my_sub)
+end subroutine my_sub
+
+! { dg-final { cleanup-modules "store_subroutine" } }
+