re PR fortran/22146 (ICE when calling ELEMENTAL subroutines)

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

	PR fortran/22146
	* trans-array.c (gfc_reverse_ss): Remove static attribute.
	(gfc_walk_elemental_function_args): Replace gfc_expr * argument for
	the function call with the corresponding gfc_actual_arglist*.  Change
	code accordingly.
	(gfc_walk_function_expr): Call to gfc_walk_elemental_function_args
	now requires the actual argument list instead of the expression for
	the function call.
	* trans-array.h: Modify the prototype for gfc_walk_elemental_function_args
	and provide a prototype for gfc_reverse_ss.
	* trans-stmt.h (gfc_trans_call): Add the scalarization code for the case
	where an elemental subroutine has array valued actual arguments.

	PR fortran/25029
	PR fortran/21256
	PR fortran/20868
	PR fortran/20870
	* resolve.c (check_assumed_size_reference): New function to check for upper
	bound in assumed size array references.
	(resolve_assumed_size_actual): New function to do a very restricted scan
	of actual argument expressions of those procedures for which incomplete
	assumed size array references are not allowed.
	(resolve_function, resolve_call): Switch off assumed size checking of
	actual arguments, except for elemental procedures and intrinsic
	inquiry functions, in some circumstances.
	(resolve_variable): Call check_assumed_size_reference.

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

	PR fortran/22146
	* gfortran.dg/elemental_subroutine_1.f90: New test.
	* gfortran.dg/elemental_subroutine_2.f90: New test.

	PR fortran/25029
	PR fortran/21256
	* gfortran.dg/assumed_size_refs_1.f90: New test.

	PR fortran/20868
	PR fortran/20870
	* gfortran.dg/assumed_size_refs_2.f90: New test.
	* gfortran.dg/initialization_1.f90: Change warning message.

From-SVN: r109449

1 files changed, 137 insertions, 1 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2e870bb..5e64bf7 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -696,6 +696,69 @@ procedure_kind (gfc_symbol * sym)
   return PTYPE_UNKNOWN;
 }
 
+/* Check references to assumed size arrays.  The flag need_full_assumed_size
+   is non-zero when matching actual arguments.  */
+
+static int need_full_assumed_size = 0;
+
+static bool
+check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
+{
+  gfc_ref * ref;
+  int dim;
+  int last = 1;
+
+  if (need_full_assumed_size
+	|| !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
+      return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY)
+      for (dim = 0; dim < ref->u.ar.as->rank; dim++)
+	last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
+
+  if (last)
+    {
+      gfc_error ("The upper bound in the last dimension must "
+		 "appear in the reference to the assumed size "
+		 "array '%s' at %L.", sym->name, &e->where);
+      return true;
+    }
+  return false;
+}
+
+
+/* Look for bad assumed size array references in argument expressions
+  of elemental and array valued intrinsic procedures.  Since this is
+  called from procedure resolution functions, it only recurses at
+  operators.  */
+
+static bool
+resolve_assumed_size_actual (gfc_expr *e)
+{
+  if (e == NULL)
+   return false;
+
+  switch (e->expr_type)
+    {
+    case EXPR_VARIABLE:
+      if (e->symtree
+	    && check_assumed_size_reference (e->symtree->n.sym, e))
+	return true;
+      break;
+
+    case EXPR_OP:
+      if (resolve_assumed_size_actual (e->value.op.op1)
+	    || resolve_assumed_size_actual (e->value.op.op2))
+	return true;
+      break;
+
+    default:
+      break;
+    }
+  return false;
+}
+
 
 /* Resolve an actual argument list.  Most of the time, this is just
    resolving the expressions in the list.
@@ -1092,10 +1155,18 @@ resolve_function (gfc_expr * expr)
   gfc_actual_arglist *arg;
   const char *name;
   try t;
+  int temp;
+
+  /* Switch off assumed size checking and do this again for certain kinds
+     of procedure, once the procedure itself is resolved.  */
+  need_full_assumed_size++;
 
   if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
     return FAILURE;
 
+  /* Resume assumed_size checking. */
+  need_full_assumed_size--;
+
 /* See if function is already resolved.  */
 
   if (expr->value.function.name != NULL)
@@ -1133,6 +1204,9 @@ resolve_function (gfc_expr * expr)
   if (expr->expr_type != EXPR_FUNCTION)
     return t;
 
+  temp = need_full_assumed_size;
+  need_full_assumed_size = 0;
+
   if (expr->value.function.actual != NULL
       && ((expr->value.function.esym != NULL
 	   && expr->value.function.esym->attr.elemental)
@@ -1140,7 +1214,6 @@ resolve_function (gfc_expr * expr)
 	      && expr->value.function.isym->elemental)))
     {
       /* The rank of an elemental is the rank of its array argument(s).  */
-
       for (arg = expr->value.function.actual; arg; arg = arg->next)
 	{
 	  if (arg->expr != NULL && arg->expr->rank > 0)
@@ -1149,8 +1222,45 @@ resolve_function (gfc_expr * expr)
 	      break;
 	    }
 	}
+
+      /* Being elemental, the last upper bound of an assumed size array
+	 argument must be present.  */
+      for (arg = expr->value.function.actual; arg; arg = arg->next)
+	{
+	  if (arg->expr != NULL
+		&& arg->expr->rank > 0
+		&& resolve_assumed_size_actual (arg->expr))
+	    return FAILURE;
+	}
     }
 
+  else if (expr->value.function.actual != NULL
+      && expr->value.function.isym != NULL
+      && strcmp (expr->value.function.isym->name, "lbound"))
+    {
+      /* Array instrinsics must also have the last upper bound of an
+	 asumed size array argument.  UBOUND and SIZE have to be
+	 excluded from the check if the second argument is anything
+	 than a constant.  */
+      int inquiry;
+      inquiry = strcmp (expr->value.function.isym->name, "ubound") == 0
+		  || strcmp (expr->value.function.isym->name, "size") == 0;
+	    
+      for (arg = expr->value.function.actual; arg; arg = arg->next)
+	{
+	  if (inquiry && arg->next != NULL && arg->next->expr
+		&& arg->next->expr->expr_type != EXPR_CONSTANT)
+	    break;
+	  
+	  if (arg->expr != NULL
+		&& arg->expr->rank > 0
+		&& resolve_assumed_size_actual (arg->expr))
+	    return FAILURE;
+	}
+    }
+
+  need_full_assumed_size = temp;
+
   if (!pure_function (expr, &name))
     {
       if (forall_flag)
@@ -1400,9 +1510,17 @@ resolve_call (gfc_code * c)
 {
   try t;
 
+  /* Switch off assumed size checking and do this again for certain kinds
+     of procedure, once the procedure itself is resolved.  */
+  need_full_assumed_size++;
+
   if (resolve_actual_arglist (c->ext.actual) == FAILURE)
     return FAILURE;
 
+  /* Resume assumed_size checking. */
+  need_full_assumed_size--;
+
+
   t = SUCCESS;
   if (c->resolved_sym == NULL)
     switch (procedure_kind (c->symtree->n.sym))
@@ -1423,6 +1541,21 @@ resolve_call (gfc_code * c)
 	gfc_internal_error ("resolve_subroutine(): bad function type");
       }
 
+  if (c->ext.actual != NULL
+      && c->symtree->n.sym->attr.elemental)
+    {
+      gfc_actual_arglist * a;
+      /* Being elemental, the last upper bound of an assumed size array
+	 argument must be present.  */
+      for (a = c->ext.actual; a; a = a->next)
+	{
+	  if (a->expr != NULL
+		&& a->expr->rank > 0
+		&& resolve_assumed_size_actual (a->expr))
+	    return FAILURE;
+	}
+    }
+
   if (t == SUCCESS)
     find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
   return t;
@@ -2349,6 +2482,9 @@ resolve_variable (gfc_expr * e)
       e->ts = sym->ts;
     }
 
+  if (check_assumed_size_reference (sym, e))
+    return FAILURE;
+
   return SUCCESS;
 }