re PR fortran/31213 (ICE on valid code with gfortran)

2007-12-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31213
	PR fortran/33888
	PR fortran/33998
	* trans-array.c (gfc_trans_array_constructor_value): If the
	iterator variable does not have a backend_decl, use a local
	temporary.
	(get_elemental_fcn_charlen): New function to map the character
	length of an elemental function onto its actual arglist.
	(gfc_conv_expr_descriptor): Call the above so that the size of
	the temporary can be evaluated.
	* trans-expr.c : Include arith.h and change prototype of
	gfc_apply_interface_mapping_to_expr to return void.  Change all
	references to gfc_apply_interface_mapping_to_expr accordingly.
	(gfc_free_interface_mapping): Free the 'expr' field.
	(gfc_add_interface_mapping): Add an argument for the actual
	argument expression. This is copied to the 'expr' field of the
	mapping.  Only stabilize the backend_decl if the se is present.
	Copy the character length expression and only add it's backend
	declaration if se is present.  Return without working on the
	backend declaration for the new symbol if se is not present.
	(gfc_map_intrinsic_function) : To simplify intrinsics 'len',
	'size', 'ubound' and 'lbound' and then to map the result.
	(gfc_map_fcn_formal_to_actual): Performs the formal to actual
	mapping for the case of a function found in a specification
	expression in the interface being mapped.
	(gfc_apply_interface_mapping_to_ref): Remove seen_result and
	all its references. Remove the inline simplification of LEN
	and call gfc_map_intrinsic_function instead.  Change the
	order of mapping of the actual arguments and simplifying
	intrinsic functions.  Finally, if a function maps to an
	actual argument, call gfc_map_fcn_formal_to_actual.
	(gfc_conv_function_call): Add 'e' to the call to
	gfc_add_interface_mapping.
	* dump-parse-tree.c (gfc_show_symbol_n): New function for
	diagnostic purposes.
	* gfortran.h : Add prototype for gfc_show_symbol_n.
	* trans.h : Add 'expr' field to gfc_add_interface_mapping.
	Add 'expr' to prototype for gfc_show_symbol_n.
	* resolve.c (resolve_generic_f0): Set specific function as
	referenced.

2007-12-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31213
	PR fortran/33888
	PR fortran/33998
	* gfortran.dg/mapping_1.f90: New test.
	* gfortran.dg/mapping_2.f90: New test.
	* gfortran.dg/mapping_3.f90: New test.

From-SVN: r130988

1 files changed, 182 insertions, 32 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 91c7700..e33df0f 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -34,6 +34,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "langhooks.h"
 #include "flags.h"
 #include "gfortran.h"
+#include "arith.h"
 #include "trans.h"
 #include "trans-const.h"
 #include "trans-types.h"
@@ -43,7 +44,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "dependency.h"
 
 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
-static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
+static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
 						 gfc_expr *);
 
 /* Copy the scalarization loop variables.  */
@@ -1417,6 +1418,7 @@ gfc_free_interface_mapping (gfc_interface_mapping * mapping)
     {
       nextsym = sym->next;
       gfc_free_symbol (sym->new->n.sym);
+      gfc_free_expr (sym->expr);
       gfc_free (sym->new);
       gfc_free (sym);
     }
@@ -1521,7 +1523,8 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
 
 void
 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
-			   gfc_symbol * sym, gfc_se * se)
+			   gfc_symbol * sym, gfc_se * se,
+			   gfc_expr *expr)
 {
   gfc_interface_sym_mapping *sm;
   tree desc;
@@ -1539,6 +1542,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   new_sym->attr.pointer = sym->attr.pointer;
   new_sym->attr.allocatable = sym->attr.allocatable;
   new_sym->attr.flavor = sym->attr.flavor;
+  new_sym->attr.function = sym->attr.function;
 
   /* Create a fake symtree for it.  */
   root = NULL;
@@ -1551,26 +1555,32 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   sm->next = mapping->syms;
   sm->old = sym;
   sm->new = new_symtree;
+  sm->expr = gfc_copy_expr (expr);
   mapping->syms = sm;
 
   /* Stabilize the argument's value.  */
-  se->expr = gfc_evaluate_now (se->expr, &se->pre);
+  if (!sym->attr.function && se)
+    se->expr = gfc_evaluate_now (se->expr, &se->pre);
 
   if (sym->ts.type == BT_CHARACTER)
     {
       /* Create a copy of the dummy argument's length.  */
       new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
+      sm->expr->ts.cl = new_sym->ts.cl;
 
       /* If the length is specified as "*", record the length that
 	 the caller is passing.  We should use the callee's length
 	 in all other cases.  */
-      if (!new_sym->ts.cl->length)
+      if (!new_sym->ts.cl->length && se)
 	{
 	  se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
 	  new_sym->ts.cl->backend_decl = se->string_length;
 	}
     }
 
+  if (!se)
+    return;
+
   /* Use the passed value as-is if the argument is a function.  */
   if (sym->attr.flavor == FL_PROCEDURE)
     value = se->expr;
@@ -1706,21 +1716,161 @@ gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
 }
 
 
+/* Convert intrinsic function calls into result expressions.  */
+static bool
+gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping)
+{
+  gfc_symbol *sym;
+  gfc_expr *new_expr;
+  gfc_expr *arg1;
+  gfc_expr *arg2;
+  int d, dup;
+
+  arg1 = expr->value.function.actual->expr;
+  if (expr->value.function.actual->next)
+    arg2 = expr->value.function.actual->next->expr;
+  else
+    arg2 = NULL;
+
+  sym  = arg1->symtree->n.sym;
+
+  if (sym->attr.dummy)
+    return false;
+
+  new_expr = NULL;
+
+  switch (expr->value.function.isym->id)
+    {
+    case GFC_ISYM_LEN:
+      /* TODO figure out why this condition is necessary.  */
+      if (sym->attr.function
+	    && arg1->ts.cl->length->expr_type != EXPR_CONSTANT
+	    && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)
+	return false;
+
+      new_expr = gfc_copy_expr (arg1->ts.cl->length);
+      break;
+
+    case GFC_ISYM_SIZE:
+      if (!sym->as)
+	return false;
+
+      if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+	{
+	  dup = mpz_get_si (arg2->value.integer);
+	  d = dup - 1;
+	}
+      else
+	{
+	  dup = sym->as->rank;
+	  d = 0;
+	}
+
+      for (; d < dup; d++)
+	{
+	  gfc_expr *tmp;
+	  tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
+	  tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
+	  if (new_expr)
+	    new_expr = gfc_multiply (new_expr, tmp);
+	  else
+	    new_expr = tmp;
+	}
+      break;
+
+    case GFC_ISYM_LBOUND:
+    case GFC_ISYM_UBOUND:
+	/* TODO These implementations of lbound and ubound do not limit if
+	   the size < 0, according to F95's 13.14.53 and 13.14.113.  */
+
+      if (!sym->as)
+	return false;
+
+      if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+	d = mpz_get_si (arg2->value.integer) - 1;
+      else
+	/* TODO: If the need arises, this could produce an array of
+	   ubound/lbounds.  */
+	gcc_unreachable ();
+
+      if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
+	new_expr = gfc_copy_expr (sym->as->lower[d]);
+      else
+	new_expr = gfc_copy_expr (sym->as->upper[d]);
+      break;
+
+    default:
+      break;
+    }
+
+  gfc_apply_interface_mapping_to_expr (mapping, new_expr);
+  if (!new_expr)
+    return false;
+
+  gfc_replace_expr (expr, new_expr);
+  return true;
+}
+
+
+static void
+gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
+			      gfc_interface_mapping * mapping)
+{
+  gfc_formal_arglist *f;
+  gfc_actual_arglist *actual;
+
+  actual = expr->value.function.actual;
+  f = map_expr->symtree->n.sym->formal;
+
+  for (; f && actual; f = f->next, actual = actual->next)
+    {
+      if (!actual->expr)
+	continue;
+
+      gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
+    }
+
+  if (map_expr->symtree->n.sym->attr.dimension)
+    {
+      int d;
+      gfc_array_spec *as;
+
+      as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
+
+      for (d = 0; d < as->rank; d++)
+	{
+	  gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
+	  gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
+	}
+
+      expr->value.function.esym->as = as;
+    }
+
+  if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
+    {
+      expr->value.function.esym->ts.cl->length
+	= gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
+
+      gfc_apply_interface_mapping_to_expr (mapping,
+			expr->value.function.esym->ts.cl->length);
+    }
+}
+
+
 /* EXPR is a copy of an expression that appeared in the interface
    associated with MAPPING.  Walk it recursively looking for references to
    dummy arguments that MAPPING maps to actual arguments.  Replace each such
    reference with a reference to the associated actual argument.  */
 
-static int
+static void
 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
 				     gfc_expr * expr)
 {
   gfc_interface_sym_mapping *sym;
   gfc_actual_arglist *actual;
-  int seen_result = 0;
 
   if (!expr)
-    return 0;
+    return;
 
   /* Copying an expression does not copy its length, so do that here.  */
   if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
@@ -1733,17 +1883,21 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
   gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
 
   /* ...and to the expression's symbol, if it has one.  */
-  if (expr->symtree)
-    for (sym = mapping->syms; sym; sym = sym->next)
-      if (sym->old == expr->symtree->n.sym)
-	expr->symtree = sym->new;
+  /* TODO Find out why the condition on expr->symtree had to be moved into
+     the loop rather than being ouside it, as originally.  */
+  for (sym = mapping->syms; sym; sym = sym->next)
+    if (expr->symtree && sym->old == expr->symtree->n.sym)
+      {
+	if (sym->new->n.sym->backend_decl)
+	  expr->symtree = sym->new;
+	else if (sym->expr)
+	  gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
+      }
 
-  /* ...and to subexpressions in expr->value.  */
+      /* ...and to subexpressions in expr->value.  */
   switch (expr->expr_type)
     {
     case EXPR_VARIABLE:
-      if (expr->symtree->n.sym->attr.result)
-	seen_result = 1;
     case EXPR_CONSTANT:
     case EXPR_NULL:
     case EXPR_SUBSTRING:
@@ -1755,27 +1909,22 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
       break;
 
     case EXPR_FUNCTION:
+      for (actual = expr->value.function.actual; actual; actual = actual->next)
+	gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
+
       if (expr->value.function.esym == NULL
 	    && expr->value.function.isym != NULL
-	    && expr->value.function.isym->id == GFC_ISYM_LEN
-	    && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
-	    && gfc_apply_interface_mapping_to_expr (mapping,
-			expr->value.function.actual->expr))
-	{
-	  gfc_expr *new_expr;
-	  new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
-	  *expr = *new_expr;
-	  gfc_free (new_expr);
-	  gfc_apply_interface_mapping_to_expr (mapping, expr);
-	  break;
-	}
+	    && expr->value.function.actual->expr->symtree
+	    && gfc_map_intrinsic_function (expr, mapping))
+	break;
 
       for (sym = mapping->syms; sym; sym = sym->next)
 	if (sym->old == expr->value.function.esym)
-	  expr->value.function.esym = sym->new->n.sym;
-
-      for (actual = expr->value.function.actual; actual; actual = actual->next)
-	gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
+	  {
+	    expr->value.function.esym = sym->new->n.sym;
+	    gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
+	    expr->value.function.esym->result = sym->new->n.sym;
+	  }
       break;
 
     case EXPR_ARRAY:
@@ -1783,7 +1932,8 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
       gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
       break;
     }
-  return seen_result;
+
+  return;
 }
 
 
@@ -2351,7 +2501,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	}
 
       if (fsym && need_interface_mapping)
-	gfc_add_interface_mapping (&mapping, fsym, &parmse);
+	gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
 
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&post, &parmse.post);