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

3 files changed, 64 insertions, 25 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);
 }