re PR fortran/29284 (ICE for optional subroutine argument)

2006-10-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29284
	PR fortran/29321
	PR fortran/29322
	* trans-expr.c (gfc_conv_function_call): Check the expression
	and the formal symbol are present when testing the actual
	argument.

	PR fortran/25091
	PR fortran/25092
	* resolve.c (resolve_entries): It is an error if the entries
	of an array-valued function do not have the same shape.

2006-10-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29284
	* gfortran.dg/optional_assumed_charlen_1.f90: New test.

	PR fortran/29321
	PR fortran/29322
	* gfortran.dg/missing_optional_dummy_2.f90: New test.

	PR fortran/25091
	PR fortran/25092
	* gfortran.dg/entry_array_specs_1.f90: New test.

From-SVN: r117413

3 files changed, 64 insertions, 29 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cf840a5..6e5584a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2006-10-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29284
+	PR fortran/29321
+	PR fortran/29322
+	* trans-expr.c (gfc_conv_function_call): Check the expression
+	and the formal symbol are present when testing the actual
+	argument.
+
+	PR fortran/25091
+	PR fortran/25092
+	* resolve.c (resolve_entries): It is an error if the entries
+	of an array-valued function do not have the same shape.
+
 2006-10-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	PR middle-end/27478
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index c9af0c0..854d3b4 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -419,23 +419,33 @@ resolve_entries (gfc_namespace * ns)
     {
       gfc_symbol *sym;
       gfc_typespec *ts, *fts;
-
+      gfc_array_spec *as, *fas;
       gfc_add_function (&proc->attr, proc->name, NULL);
       proc->result = proc;
+      fas = ns->entries->sym->as;
+      fas = fas ? fas : ns->entries->sym->result->as;
       fts = &ns->entries->sym->result->ts;
       if (fts->type == BT_UNKNOWN)
 	fts = gfc_get_default_type (ns->entries->sym->result, NULL);
       for (el = ns->entries->next; el; el = el->next)
 	{
 	  ts = &el->sym->result->ts;
+	  as = el->sym->as;
+	  as = as ? as : el->sym->result->as;
 	  if (ts->type == BT_UNKNOWN)
 	    ts = gfc_get_default_type (el->sym->result, NULL);
+
 	  if (! gfc_compare_types (ts, fts)
 	      || (el->sym->result->attr.dimension
 		  != ns->entries->sym->result->attr.dimension)
 	      || (el->sym->result->attr.pointer
 		  != ns->entries->sym->result->attr.pointer))
 	    break;
+
+	  else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
+	    gfc_error ("Procedure %s at %L has entries with mismatched "
+		       "array specifications", ns->entries->sym->name,
+		       &ns->entries->sym->declared_at);
 	}
 
       if (el == NULL)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e477f9c..4bce65e 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2006,38 +2006,49 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    } 
 	}
 
-      /* If an optional argument is itself an optional dummy argument,
-	 check its presence and substitute a null if absent.  */
-      if (e && e->expr_type == EXPR_VARIABLE
-	    && e->symtree->n.sym->attr.optional
-	    && fsym && fsym->attr.optional)
-	gfc_conv_missing_dummy (&parmse, e, fsym->ts);
-
-      if (fsym && need_interface_mapping)
-	gfc_add_interface_mapping (&mapping, fsym, &parmse);
+      if (fsym)
+	{
+	  if (e)
+	    {
+	      /* If an optional argument is itself an optional dummy
+		 argument, check its presence and substitute a null
+		 if absent.  */
+	      if (e->expr_type == EXPR_VARIABLE
+		    && e->symtree->n.sym->attr.optional
+		    && fsym->attr.optional)
+		gfc_conv_missing_dummy (&parmse, e, fsym->ts);
+
+	      /* If an INTENT(OUT) dummy of derived type has a default
+		 initializer, it must be (re)initialized here.  */
+	      if (fsym->attr.intent == INTENT_OUT
+		    && fsym->ts.type == BT_DERIVED
+		    && fsym->value)
+		{
+		  gcc_assert (!fsym->attr.allocatable);
+		  tmp = gfc_trans_assignment (e, fsym->value);
+		  gfc_add_expr_to_block (&se->pre, tmp);
+		}
 
-      gfc_add_block_to_block (&se->pre, &parmse.pre);
-      gfc_add_block_to_block (&post, &parmse.post);
+	      /* Obtain the character length of an assumed character
+		 length procedure from the typespec.  */
+	      if (fsym->ts.type == BT_CHARACTER
+		    && parmse.string_length == NULL_TREE
+		    && e->ts.type == BT_PROCEDURE
+		    && e->symtree->n.sym->ts.type == BT_CHARACTER
+		    && e->symtree->n.sym->ts.cl->length != NULL)
+		{
+		  gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
+		  parmse.string_length
+			= e->symtree->n.sym->ts.cl->backend_decl;
+		}
+	    }
 
-      /* If an INTENT(OUT) dummy of derived type has a default
-	 initializer, it must be (re)initialized here.  */
-      if (fsym && fsym->attr.intent == INTENT_OUT && fsym->ts.type == BT_DERIVED
-          && fsym->value)
-	{
-	  gcc_assert (!fsym->attr.allocatable);
-	  tmp = gfc_trans_assignment (e, fsym->value);
-	  gfc_add_expr_to_block (&se->pre, tmp);
+	  if (need_interface_mapping)
+	    gfc_add_interface_mapping (&mapping, fsym, &parmse);
 	}
 
-      if (fsym && fsym->ts.type == BT_CHARACTER
-	     && parmse.string_length == NULL_TREE
-	     && e->ts.type == BT_PROCEDURE
-	     && e->symtree->n.sym->ts.type == BT_CHARACTER
-	     && e->symtree->n.sym->ts.cl->length != NULL)
-	{
-	  gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
-	  parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
-	}
+      gfc_add_block_to_block (&se->pre, &parmse.pre);
+      gfc_add_block_to_block (&post, &parmse.post);
 
       /* Character strings are passed as two parameters, a length and a
          pointer.  */