re PR fortran/39850 (Too strict checking for procedures as actual argument)

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

	PR fortran/39850
	* interface.c (gfc_compare_interfaces): Take care of implicit typing
	when checking the function attribute. Plus another bugfix.
	(compare_parameter): Set attr.function and attr.subroutine according
	to the usage of a procedure as actual argument.


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

	PR fortran/39850
	* gfortran.dg/interface_19.f90: Add 'cleanup-modules'.
	* gfortran.dg/interface_20.f90: Ditto.
	* gfortran.dg/interface_21.f90: Ditto.
	* gfortran.dg/interface_22.f90: Ditto.
	* gfortran.dg/interface_30.f90: New.
	* gfortran.dg/proc_ptr_11.f90: Fix invalid test case.

From-SVN: r148767

9 files changed, 80 insertions, 5 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0d88c4b..1c1a6c1 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2009-06-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39850
+	* interface.c (gfc_compare_interfaces): Take care of implicit typing
+	when checking the function attribute. Plus another bugfix.
+	(compare_parameter): Set attr.function and attr.subroutine according
+	to the usage of a procedure as actual argument.
+
 2009-06-20  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/40452
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 4954389..7d26fe4 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -939,7 +939,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
 {
   gfc_formal_arglist *f1, *f2;
 
-  if (s1->attr.function && !s2->attr.function)
+  if (s1->attr.function && (s2->attr.subroutine
+      || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
+	  && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN)))
     {
       if (errmsg != NULL)
 	snprintf (errmsg, err_len, "'%s' is not a function", s2->name);
@@ -967,8 +969,6 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
 		      "of '%s'", s2->name);
 	  return 0;
 	}
-      if (s1->attr.if_source == IFSRC_DECL)
-	return 1;
     }
 
   if (s1->attr.if_source == IFSRC_UNKNOWN
@@ -1388,6 +1388,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   if (actual->ts.type == BT_PROCEDURE)
     {
       char err[200];
+      gfc_symbol *act_sym = actual->symtree->n.sym;
 
       if (formal->attr.flavor != FL_PROCEDURE)
 	{
@@ -1396,7 +1397,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  return 0;
 	}
 
-      if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1, err,
+      if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err,
 				   sizeof(err)))
 	{
 	  if (where)
@@ -1405,6 +1406,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  return 0;
 	}
 
+      if (formal->attr.function && !act_sym->attr.function)
+	gfc_add_function (&act_sym->attr, act_sym->name, &act_sym->declared_at);
+
+      if (formal->attr.subroutine && !act_sym->attr.subroutine)
+	gfc_add_subroutine (&act_sym->attr, act_sym->name,
+			    &act_sym->declared_at);
+
       return 1;
     }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 278e3f1..3618373 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,13 @@
+2009-06-21  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39850
+	* gfortran.dg/interface_19.f90: Add 'cleanup-modules'.
+	* gfortran.dg/interface_20.f90: Ditto.
+	* gfortran.dg/interface_21.f90: Ditto.
+	* gfortran.dg/interface_22.f90: Ditto.
+	* gfortran.dg/interface_30.f90: New.
+	* gfortran.dg/proc_ptr_11.f90: Fix invalid test case.
+
 2009-06-21  Uros Bizjak  <ubizjak@gmail.com>
 
 	* gcc.dg/tree-ssa/fre-vce-1.c: Cleanup "fre" tree dump.
diff --git a/gcc/testsuite/gfortran.dg/interface_19.f90 b/gcc/testsuite/gfortran.dg/interface_19.f90
index 2d72caa..7a88fc9 100644
--- a/gcc/testsuite/gfortran.dg/interface_19.f90
+++ b/gcc/testsuite/gfortran.dg/interface_19.f90
@@ -27,3 +27,6 @@ intrinsic dcos
 call sub()
 call sub(dcos)
 end
+
+! { dg-final { cleanup-modules "m" } }
+
diff --git a/gcc/testsuite/gfortran.dg/interface_20.f90 b/gcc/testsuite/gfortran.dg/interface_20.f90
index 829add2..9a7dc5c 100644
--- a/gcc/testsuite/gfortran.dg/interface_20.f90
+++ b/gcc/testsuite/gfortran.dg/interface_20.f90
@@ -18,3 +18,6 @@ implicit none
 intrinsic cos
 call sub(cos) ! { dg-error "wrong number of arguments" }
 end
+
+! { dg-final { cleanup-modules "m" } }
+
diff --git a/gcc/testsuite/gfortran.dg/interface_21.f90 b/gcc/testsuite/gfortran.dg/interface_21.f90
index e3db771..566a9ef 100644
--- a/gcc/testsuite/gfortran.dg/interface_21.f90
+++ b/gcc/testsuite/gfortran.dg/interface_21.f90
@@ -20,3 +20,6 @@ implicit none
 EXTERNAL foo  ! implicit interface is undefined
 call sub(foo) ! { dg-error "is not a function" }
 end
+
+! { dg-final { cleanup-modules "m" } }
+
diff --git a/gcc/testsuite/gfortran.dg/interface_22.f90 b/gcc/testsuite/gfortran.dg/interface_22.f90
index 6228fc9..fa8e517 100644
--- a/gcc/testsuite/gfortran.dg/interface_22.f90
+++ b/gcc/testsuite/gfortran.dg/interface_22.f90
@@ -23,3 +23,6 @@ module gswap
     module procedure sreal, schar, sint => sreal ! { dg-error "Syntax error in MODULE PROCEDURE statement" }
   end interface swap
 end module gswap
+
+! { dg-final { cleanup-modules "foo g gswap" } }
+
diff --git a/gcc/testsuite/gfortran.dg/interface_30.f90 b/gcc/testsuite/gfortran.dg/interface_30.f90
new file mode 100644
index 0000000..0576a42
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_30.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+!
+! PR39850: Too strict checking for procedures as actual argument
+!
+! Original test case by Tobias Burnus <burnus@gcc.gnu.org>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+real function func()
+  print *,"func"
+  func = 42.0
+end function func
+
+program test
+  external func1,func2,func3,func4  ! subroutine or implicitly typed real function
+  call sub1(func1)
+  call sub2(func2)
+  call sub1(func3)
+  call sub2(func3)  ! { dg-error "Type mismatch in argument" }
+  call sub2(func4)
+  call sub1(func4)  ! { dg-error "Interface mismatch in dummy procedure" }
+contains
+  subroutine sub1(a1)
+    interface
+      real function a1()
+      end function
+    end interface
+    print *, a1()
+  end subroutine sub1
+  subroutine sub2(a2)
+    interface
+      subroutine a2
+      end subroutine
+    end interface
+    call a2()
+  end subroutine
+end
+
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
index 469ebd4..4e8b3c2 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
@@ -55,7 +55,7 @@ program bsp
     end function add
 
     integer function f(x)
-      integer :: x
+      integer,intent(in) :: x
       f = 317 + x
     end function