re PR fortran/39997 (Procedure(), pointer & implicit typing: rejects-valid / accepts-invalid?)

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.

From-SVN: r148996

gcc/fortran/ChangeLog

@@ -1,3 +1,15 @@
+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-24  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/40427

gcc/fortran/decl.c

@@ -4117,6 +4117,7 @@ add_hidden_procptr_result (gfc_symbol *sym)
       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;

gcc/fortran/expr.c

@@ -3189,10 +3189,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       /* 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);

gcc/fortran/resolve.c

@@ -9551,6 +9551,11 @@ resolve_symbol (gfc_symbol *sym)
       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

gcc/testsuite/ChangeLog

@@ -1,3 +1,12 @@
+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.
+
 2009-06-26  Janis Johnson  <janis187@us.ibm.com>
 
 	PR c/39902

gcc/testsuite/gfortran.dg/proc_ptr_15.f90

@@ -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 mismatch in return value" }
 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
 

gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90

@@ -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
+

gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90

@@ -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

gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90

@@ -0,0 +1,20 @@
+! { dg-do compile }
+!
+! PR 40541: Assignment checking for proc-pointer => proc-ptr-returning-function()
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+program test
+  procedure(real), pointer :: p
+  p => f()  ! { dg-error "Type/kind mismatch in return value" }
+contains
+ function f()
+   pointer :: f
+   interface
+     logical(1) function f()
+     end function
+   end interface
+   f = .true._1
+ end function f
+end program test
+