re PR fortran/25098 (Variable as actual argument for procedure dummy argument allowed)

2006-06-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25098
	PR fortran/25147
	* interface.c (compare_parameter): Return 1 if the actual arg
	is external and the formal is a procedure.
	(compare_actual_formal): If the actual argument is a variable
	and the formal a procedure, this an error.  If a gsymbol exists
	for a procedure of the same name, this is not yet resolved and
	the error is cleared.

	* trans-intrinsic.c (gfc_conv_associated): Make provision for
	zero array length or zero string length contingent on presence
	of target, for consistency with standard.

2006-06-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25098
	* gfortran.dg/dummy_procedure_1.f90: New test.

	PR fortran/25147
	* gfortran.dg/dummy_procedure_2.f90: New test.

	* gfortran.dg/associated_2.f90: Correct to make consistent with
	standard.

From-SVN: r114296

7 files changed, 168 insertions, 27 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 59da690..a91cb42 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2006-06-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25098
+	PR fortran/25147
+	* interface.c (compare_parameter): Return 1 if the actual arg
+	is external and the formal is a procedure.
+	(compare_actual_formal): If the actual argument is a variable
+	and the formal a procedure, this an error.  If a gsymbol exists
+	for a procedure of the same name, this is not yet resolved and
+	the error is cleared.
+
+	* trans-intrinsic.c (gfc_conv_associated): Make provision for
+	zero array length or zero string length contingent on presence
+	of target, for consistency with standard.
+
 2006-05-30  Asher Langton  <langton2@llnl.gov>
 
 	* symbol.c (check_conflict): Allow external, function, and
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 74f7669..521876e 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1123,7 +1123,8 @@ compare_parameter (gfc_symbol * formal, gfc_expr * actual,
 	  && !compare_type_rank (formal, actual->symtree->n.sym))
 	return 0;
 
-      if (formal->attr.if_source == IFSRC_UNKNOWN)
+      if (formal->attr.if_source == IFSRC_UNKNOWN
+	    || actual->symtree->n.sym->attr.external)
 	return 1;		/* Assume match */
 
       return compare_interfaces (formal, actual->symtree->n.sym, 0);
@@ -1177,6 +1178,7 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 {
   gfc_actual_arglist **new, *a, *actual, temp;
   gfc_formal_arglist *f;
+  gfc_gsymbol *gsym;
   int i, n, na;
   bool rank_check;
 
@@ -1276,6 +1278,24 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 	  return 0;
 	}
 
+      /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
+	 provided for a procedure formal argument.  */
+      if (a->expr->ts.type != BT_PROCEDURE
+	  && a->expr->expr_type == EXPR_VARIABLE
+	  && f->sym->attr.flavor == FL_PROCEDURE)
+	{
+	  gsym = gfc_find_gsymbol (gfc_gsym_root,
+				   a->expr->symtree->n.sym->name);
+	  if (gsym == NULL || (gsym->type != GSYM_FUNCTION
+		&& gsym->type != GSYM_SUBROUTINE))
+	    {
+	      if (where)
+		gfc_error ("Expected a procedure for argument '%s' at %L",
+			   f->sym->name, &a->expr->where);
+	      return 0;
+	    }
+	}
+
       if (f->sym->as
 	  && f->sym->as->type == AS_ASSUMED_SHAPE
 	  && a->expr->expr_type == EXPR_VARIABLE
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 9575a31..c361ad4 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2823,23 +2823,6 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
   arg2 = arg1->next;
   ss1 = gfc_walk_expr (arg1->expr);
 
-  nonzero_charlen = NULL_TREE;
-  if (arg1->expr->ts.type == BT_CHARACTER)
-    nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
-			      arg1->expr->ts.cl->backend_decl,
-			      integer_zero_node);
-
-  nonzero_arraylen = NULL_TREE;
-  if (ss1 != gfc_ss_terminator)
-    {
-      arg1se.descriptor_only = 1;
-      gfc_conv_expr_lhs (&arg1se, arg1->expr);
-      tmp = gfc_conv_descriptor_stride (arg1se.expr,
-			gfc_rank_cst[arg1->expr->rank - 1]);
-      nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
-				 tmp, integer_zero_node);
-    }
-
   if (!arg2->expr)
     {
       /* No optional target.  */
@@ -2865,6 +2848,13 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
     {
       /* An optional target.  */
       ss2 = gfc_walk_expr (arg2->expr);
+
+      nonzero_charlen = NULL_TREE;
+      if (arg1->expr->ts.type == BT_CHARACTER)
+	nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
+				  arg1->expr->ts.cl->backend_decl,
+				  integer_zero_node);
+
       if (ss1 == gfc_ss_terminator)
         {
           /* A pointer to a scalar.  */
@@ -2878,12 +2868,23 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
         }
       else
         {
+
+	  /* An array pointer of zero length is not associated if target is
+	     present.  */
+	  arg1se.descriptor_only = 1;
+	  gfc_conv_expr_lhs (&arg1se, arg1->expr);
+	  tmp = gfc_conv_descriptor_stride (arg1se.expr,
+					    gfc_rank_cst[arg1->expr->rank - 1]);
+	  nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
+				 tmp, integer_zero_node);
+
           /* A pointer to an array, call library function _gfor_associated.  */
           gcc_assert (ss2 != gfc_ss_terminator);
           args = NULL_TREE;
           arg1se.want_pointer = 1;
           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
           args = gfc_chainon_list (args, arg1se.expr);
+
           arg2se.want_pointer = 1;
           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
           gfc_add_block_to_block (&se->pre, &arg2se.pre);
@@ -2891,15 +2892,18 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
           args = gfc_chainon_list (args, arg2se.expr);
           fndecl = gfor_fndecl_associated;
           se->expr = build_function_call_expr (fndecl, args);
+	  se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
+			     se->expr, nonzero_arraylen);
+
         }
-     }
 
-  if (nonzero_charlen != NULL_TREE)
-    se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
-		       se->expr, nonzero_charlen);
-  if (nonzero_arraylen != NULL_TREE)
-    se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
-		       se->expr, nonzero_arraylen);
+      /* If target is present zero character length pointers cannot
+	 be associated.  */
+      if (nonzero_charlen != NULL_TREE)
+	se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
+			   se->expr, nonzero_charlen);
+    }
+
   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c1f6dec..7743fa0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2006-06-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25098
+	* gfortran.dg/dummy_procedure_1.f90: New test.
+
+	PR fortran/25147
+	* gfortran.dg/dummy_procedure_2.f90: New test.
+
+	* gfortran.dg/associated_2.f90: Correct to make consistent with
+	standard.
+
 2006-05-31  Roger Sayle  <roger@eyesopen.com>
 
 	* gcc.target/i386/387-11.c: New test case.
diff --git a/gcc/testsuite/gfortran.dg/associated_2.f90 b/gcc/testsuite/gfortran.dg/associated_2.f90
index 7ef955f..5b8b689 100644
--- a/gcc/testsuite/gfortran.dg/associated_2.f90
+++ b/gcc/testsuite/gfortran.dg/associated_2.f90
@@ -13,26 +13,37 @@ contains
     integer, pointer, dimension(:, :, :)  :: a, b
     allocate (a(2,0,2))
     b => a
-    if (associated (b)) call abort ()
+! Even though b is zero length, associated returns true because
+! the target argument is not present (case (i))
+    if (.not. associated (b)) call abort ()
+    deallocate (a)
     allocate (a(2,1,2))
     b => a
     if (.not.associated (b)) call abort ()
+    deallocate (a)
   end subroutine test1
   subroutine test2 ()
     integer, pointer, dimension(:, :, :)  :: a, b
     allocate (a(2,0,2))
     b => a
+! Associated returns false because target is present (case(iii)).
     if (associated (b, a)) call abort ()
+    deallocate (a)
     allocate (a(2,1,2))
     b => a
     if (.not.associated (b, a)) call abort ()
+    deallocate (a)
   end subroutine test2
   subroutine test3 (n)
     integer :: n
     character(len=n), pointer, dimension(:)  :: a, b
     allocate (a(2))
     b => a
+! Again, with zero character length associated returns false
+! if target is present.
     if (associated (b, a) .and. (n .eq. 0)) call abort ()
+!
     if ((.not.associated (b, a))  .and. (n .ne. 0)) call abort ()
+    deallocate (a)
   end subroutine test3
-end
\ No newline at end of file
+end
diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90
new file mode 100644
index 0000000..66aca21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90
@@ -0,0 +1,47 @@
+! { dg-do compile }
+! Test the patch for PR25098, where passing a variable as an
+! actual argument to a formal argument that is a procedure
+! went undiagnosed.
+!
+! Based on contribution by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+integer function y()
+  y = 1
+end
+integer function z()
+  z = 1
+end
+
+module m1
+contains
+  subroutine s1(f)
+    interface
+      function f()
+        integer f
+      end function f
+    end interface
+  end subroutine s1
+end module m1
+
+  use m1
+  external y
+  interface
+   function x()
+     integer x
+   end function x
+  end interface
+
+  integer :: i, y, z
+  i=1
+  call s1(i) ! { dg-error "Expected a procedure for argument" }
+  call s1(w) ! { dg-error "not allowed as an actual argument" }
+  call s1(x) ! explicit interface
+  call s1(y) ! declared external
+  call s1(z) ! already compiled
+contains
+  integer function w()
+    w = 1
+  end function w
+end
+
+! { dg-final { cleanup-modules "m1" } }
diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_2.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_2.f90
new file mode 100644
index 0000000..dd609bd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dummy_procedure_2.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! Checks the fix for the bug exposed in fixing PR25147
+!
+! Contributed by Tobias Schlueter  <tobi@gcc.gnu.org>
+!
+module integrator
+  interface
+     function integrate(f,xmin,xmax)
+       implicit none
+       interface
+          function f(x)
+            real(8) :: f,x
+            intent(in) :: x
+          end function f
+       end interface
+       real(8) :: xmin, xmax, integrate
+     end function integrate
+  end interface
+end module integrator
+
+  use integrator
+  call foo1 ()
+  call foo2 ()
+contains
+  subroutine foo1 ()
+    real(8) :: f                   ! This was not trapped: PR25147/25098
+    print *,integrate (f,0d0,3d0) ! { dg-error "Expected a procedure" }
+  end subroutine foo1
+  subroutine foo2 ()
+    real(8), external :: g ! This would give an error, incorrectly.
+    print *,integrate (g,0d0,3d0)
+  end subroutine foo2
+end