[Patch, Fortran] PR 39997/40541

[Janus Weil <janus at gcc dot gnu dot org>]

Hi all,

here is a patch which does several things:

1) It enables the interface checking for procedure pointer
assignments, where the rhs is a function returning a procedure pointer
(i.e. PR 40451).

2) If external procedures without an explicit return type cannot be
implicitly typed, they get the 'subroutine' attribute (i.e. PR 39997
comment #3, lower part).

3) Both of these changes together revealed a couple of invalid test
cases (which were mostly due to a misunderstanding on my side
regarding the usage of PROCEDURE statements with implicit interfaces).
Those have been fixed. This also includes proc_ptr_result_1.f90, which
has been failing lately after a patch by Richard, but now works again.

4) A small fix for procedure pointer results, where in some cases the
type of the return value was not recognized (also revealed by the
extended checking).

Regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2009-06-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39997
	PR fortran/40541
	* decl.c (add_hidden_procptr_result): Copy the typespec to the hidden
	result.
	* expr.c (gfc_check_pointer_assign): Enable interface check for
	procedure pointer assignments where the rhs is a function returning a
	procedure pointer.
	* resolve.c (resolve_symbol): If an external procedure with unspecified
	return type can not be implicitly typed, it must be a subroutine.


2009-06-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39997
	PR fortran/40541
	* gfortran.dg/proc_ptr_15.f90: Fixed and extended.
	* gfortran.dg/proc_ptr_common_1.f90: Fixed invalid test case.
	* gfortran.dg/proc_ptr_result_1.f90: Ditto.
	* gfortran.dg/proc_ptr_result_5.f90: New.

Index: gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90	(revision 148947)
+++ gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90	(working copy)
@@ -19,7 +19,7 @@ program main
   integer :: x,y
   intrinsic sin,cos
   procedure(real), pointer :: func1
-  external func2
+  real, external :: func2
   pointer func2
   common /com/ func1,func2,x,y
   x = 5
@@ -27,4 +27,5 @@ program main
   func1 => cos
   func2 => sin
   call one()
-end program main 
+end program main
+
Index: gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90	(revision 148947)
+++ gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90	(working copy)
@@ -9,7 +9,7 @@ contains
 
   function j()
     implicit none
-    procedure(),pointer :: j
+    procedure(integer),pointer :: j
     intrinsic iabs
     j => iabs
   end function
@@ -36,12 +36,20 @@ p => b()
 if (p(-2)/=2) call abort()
 p => c()
 if (p(-3)/=3) call abort()
-p => d()
-if (p(-4)/=4) call abort()
+
+ps => d()
+x = 4
+call ps(x)
+if (x/=16) call abort()
+
 p => dd()
 if (p(-4)/=4) call abort()
-p => e(iabs)
-if (p(-5)/=5) call abort()
+
+ps => e(sub)
+x = 5
+call ps(x)
+if (x/=25) call abort()
+
 p => ee()
 if (p(-5)/=5) call abort()
 p => f()
@@ -87,7 +95,7 @@ contains
   function d()
     pointer :: d
     external d
-    d => iabs
+    d => sub
   end function
 
   function dd()
@@ -157,7 +165,7 @@ contains
   end function
 
   function k(arg)
-    procedure(),pointer :: k,arg
+    procedure(integer),pointer :: k,arg
     k => iabs
     arg => k
   end function
Index: gcc/testsuite/gfortran.dg/proc_ptr_15.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_15.f90	(revision 148947)
+++ gcc/testsuite/gfortran.dg/proc_ptr_15.f90	(working copy)
@@ -15,7 +15,7 @@ real(4), external, pointer :: p6
 ! valid
 p2 => iabs
 p3 => sub
-p4 => p2
+p4 => p3
 p6 => p1
 
 ! invalid
@@ -23,6 +23,7 @@ p1 => iabs   ! { dg-error "Type/kind mis
 p1 => p2     ! { dg-error "Type/kind mismatch in return value" }
 p1 => p5     ! { dg-error "Type/kind mismatch in return value" }
 p6 => iabs   ! { dg-error "Type/kind mismatch in return value" }
+p4 => p2     ! { dg-error "is not a subroutine" }
 
 contains
 
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 148947)
+++ gcc/fortran/decl.c	(working copy)
@@ -4117,6 +4117,7 @@ add_hidden_procptr_result (gfc_symbol *s
       sym->result->attr.pointer = sym->attr.pointer;
       sym->result->attr.external = sym->attr.external;
       sym->result->attr.referenced = sym->attr.referenced;
+      sym->result->ts = sym->ts;
       sym->attr.proc_pointer = 0;
       sym->attr.pointer = 0;
       sym->attr.external = 0;
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 148947)
+++ gcc/fortran/expr.c	(working copy)
@@ -3189,10 +3189,14 @@ gfc_check_pointer_assign (gfc_expr *lval
       /* TODO: Enable interface check for PPCs.  */
       if (is_proc_ptr_comp (rvalue, NULL))
 	return SUCCESS;
-      if (rvalue->expr_type == EXPR_VARIABLE
-	  && !gfc_compare_interfaces (lvalue->symtree->n.sym,
-				      rvalue->symtree->n.sym, 0, 1, err,
-				      sizeof(err)))
+      if ((rvalue->expr_type == EXPR_VARIABLE
+	   && !gfc_compare_interfaces (lvalue->symtree->n.sym,
+				       rvalue->symtree->n.sym, 0, 1, err,
+				       sizeof(err)))
+	  || (rvalue->expr_type == EXPR_FUNCTION
+	      && !gfc_compare_interfaces (lvalue->symtree->n.sym,
+					  rvalue->symtree->n.sym->result, 0, 1,
+					  err, sizeof(err))))
 	{
 	  gfc_error ("Interface mismatch in procedure pointer assignment "
 		     "at %L: %s", &rvalue->where, err);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 148947)
+++ gcc/fortran/resolve.c	(working copy)
@@ -9548,9 +9548,15 @@ resolve_symbol (gfc_symbol *sym)
   /* Assign default type to symbols that need one and don't have one.  */
   if (sym->ts.type == BT_UNKNOWN)
     {
+
       if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
 	gfc_set_default_type (sym, 1, NULL);
 
+      if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
+	  && !sym->attr.function && !sym->attr.subroutine
+	  && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
+	gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
+
       if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
 	{
 	  /* The specific case of an external procedure should emit an error

Attachment: proc_ptr_result_5.f90
Description: Binary data