This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

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


Hi all,

here goes another update to my procptr result patch. After a private
review by Paul, I made a small modification to stick to the original
error messages in external_procedures_1.f90 (which is now compiled
with -std=f95). Moreover ...


> All the examples in proc_ptr_14.f90 are working now. Only the
> construct in proc_ptr_15.f90 still gives me headaches. Will try to
> sort that out soon.

I finally managed to get the beast in proc_ptr_15.f90 working, and
added two more variants of it. The patch seems pretty complete to me
by now, and I fail to find any more exotic test cases. There have been
a few reviews already, but I am still missing approval.

Regression-tested on x86_64-unknown-linux-gnu. Ok for 4.5?

Cheers,
Janus



2009-03-11  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_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-03-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36704
	* gfortran.dg/external_procedures_1.f90: Modified.
	* gfortran.dg/proc_ptr_14.f90: New.
	* gfortran.dg/proc_ptr_15.f90: New.
Index: gcc/testsuite/gfortran.dg/external_procedures_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/external_procedures_1.f90	(Revision 144751)
+++ gcc/testsuite/gfortran.dg/external_procedures_1.f90	(Arbeitskopie)
@@ -1,14 +1,17 @@
 ! { 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
 
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 144751)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -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 144751)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -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_s
 }
 
 
+/* 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;
 
@@ -4407,6 +4482,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 +4882,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 +5333,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 +5458,8 @@ attr_decl1 (void)
       goto cleanup;
     }
 
+  add_hidden_procptr_result (sym);
+
   return MATCH_YES;
 
 cleanup:
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(Revision 144751)
+++ gcc/fortran/trans-types.c	(Arbeitskopie)
@@ -1613,8 +1613,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;
@@ -2146,7 +2146,18 @@ gfc_get_function_type (gfc_symbol * sym)
     }
   else if (sym->result && sym->result->attr.proc_pointer)
     /* Procedure pointer return values.  */
-    type = gfc_sym_type (sym->result);
+    {
+      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);
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 144751)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -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);
@@ -2509,7 +2509,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;
     }
 
@@ -7947,18 +7948,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;
@@ -9126,11 +9150,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/parse.c
===================================================================
--- gcc/fortran/parse.c	(Revision 144751)
+++ gcc/fortran/parse.c	(Arbeitskopie)
@@ -2114,14 +2114,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:
@@ -2214,6 +2206,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 ();
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(Revision 144751)
+++ gcc/fortran/primary.c	(Arbeitskopie)
@@ -2351,6 +2351,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.  */
 
@@ -2387,6 +2411,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);
@@ -2576,6 +2602,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;
@@ -2905,7 +2933,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 */
! { 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
    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)
    external :: arg
    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
    !print *,l(-11)
    if (l(-11)/=11) call abort()
  end function 

end

! { dg-final { cleanup-modules "mo" } }
! { dg-do compile }
!
! PR 36704: Procedure pointer as function result
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

  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

end


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]