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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148996 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d8ea53d..2cfbe24 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/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

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 021392d..179d1e2 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/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;

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index d2f73d6..2049fa4 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/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);

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 9bb6e22..9ea2a2d 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4956bfc..cdfe1ff 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/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

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_15.f90
index 57269b0..3d37ee2 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_15.f90
+++ b/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
 

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90
index 0cfdec0..df2ef0b 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90
+++ b/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
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90
index f3f7252..df830d3 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90
+++ b/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

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90
new file mode 100644 (file)
index 0000000..0e60cbb
--- /dev/null
+++ b/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
+