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

gcc/fortran/ChangeLog

+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-14  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34438

gcc/fortran/dump-parse-tree.c

@@ -731,6 +731,17 @@ gfc_show_symbol (gfc_symbol *sym)
 }
 
 
+/* Show a symbol for diagnostic purposes. */
+void
+gfc_show_symbol_n (const char * msg, gfc_symbol *sym)
+{
+  if (msg)
+    gfc_status (msg);
+  gfc_show_symbol (sym);
+  gfc_status_char ('\n');
+}
+
+
 /* Show a user-defined operator.  Just prints an operator
    and the name of the associated subroutine, really.  */
 

gcc/fortran/gfortran.h

@@ -2364,6 +2364,7 @@ void gfc_show_namelist (gfc_namelist *);
 void gfc_show_namespace (gfc_namespace *);
 void gfc_show_ref (gfc_ref *);
 void gfc_show_symbol (gfc_symbol *);
+void gfc_show_symbol_n (const char *, gfc_symbol *);
 void gfc_show_typespec (gfc_typespec *);
 
 /* parse.c */

gcc/fortran/resolve.c

@@ -1425,6 +1425,8 @@ resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
 	  else if (s->result != NULL && s->result->as != NULL)
 	    expr->rank = s->result->as->rank;
 
+	  gfc_set_sym_referenced (expr->value.function.esym);
+
 	  return MATCH_YES;
 	}
 

gcc/fortran/trans-array.c

@@ -1225,10 +1225,21 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
 
 	  loopbody = gfc_finish_block (&body);
 
-	  gfc_init_se (&se, NULL);
-	  gfc_conv_expr (&se, c->iterator->var);
-	  gfc_add_block_to_block (pblock, &se.pre);
-	  loopvar = se.expr;
+	  if (c->iterator->var->symtree->n.sym->backend_decl)
+	    {
+	      gfc_init_se (&se, NULL);
+	      gfc_conv_expr (&se, c->iterator->var);
+	      gfc_add_block_to_block (pblock, &se.pre);
+	      loopvar = se.expr;
+	    }
+	  else
+	    {
+	      /* If the iterator appears in a specification expression in
+		 an interface mapping, we need to make a temp for the loop
+		 variable because it is not declared locally.  */
+	      loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
+	      loopvar = gfc_create_var (loopvar, "loopvar");
+	    }
 
 	  /* Make a temporary, store the current value in that
 	     and return it, once the loop is done.  */
@@ -4491,6 +4502,47 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
 }
 
 
+/* gfc_conv_expr_descriptor needs the character length of elemental
+   functions before the function is called so that the size of the
+   temporary can be obtained.  The only way to do this is to convert
+   the expression, mapping onto the actual arguments.  */
+static void
+get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
+{
+  gfc_interface_mapping mapping;
+  gfc_formal_arglist *formal;
+  gfc_actual_arglist *arg;
+  gfc_se tse;
+
+  formal = expr->symtree->n.sym->formal;
+  arg = expr->value.function.actual;
+  gfc_init_interface_mapping (&mapping);
+
+  /* Set se = NULL in the calls to the interface mapping, to supress any
+     backend stuff.  */
+  for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+    {
+      if (!arg->expr)
+	continue;
+      if (formal->sym)
+	gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+    }
+
+  gfc_init_se (&tse, NULL);
+
+  /* Build the expression for the character length and convert it.  */
+  gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
+
+  gfc_add_block_to_block (&se->pre, &tse.pre);
+  gfc_add_block_to_block (&se->post, &tse.post);
+  tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
+  tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
+			  build_int_cst (gfc_charlen_type_node, 0));
+  expr->ts.cl->backend_decl = tse.expr;
+  gfc_free_interface_mapping (&mapping);
+}
+
+
 /* Convert an array for passing as an actual argument.  Expressions and
    vector subscripts are evaluated and stored in a temporary, which is then
    passed.  For whole arrays the descriptor is passed.  For array sections
@@ -4624,6 +4676,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	{
 	  /* Elemental function.  */
 	  need_tmp = 1;
+	  if (expr->ts.type == BT_CHARACTER
+		&& expr->ts.cl->length->expr_type != EXPR_CONSTANT)
+	    get_elemental_fcn_charlen (expr, se);
+
 	  info = NULL;
 	}
       else

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);

gcc/fortran/trans.h

@@ -695,6 +695,7 @@ typedef struct gfc_interface_sym_mapping
   struct gfc_interface_sym_mapping *next;
   gfc_symbol *old;
   gfc_symtree *new;
+  gfc_expr *expr;
 }
 gfc_interface_sym_mapping;
 
@@ -716,7 +717,7 @@ gfc_interface_mapping;
 void gfc_init_interface_mapping (gfc_interface_mapping *);
 void gfc_free_interface_mapping (gfc_interface_mapping *);
 void gfc_add_interface_mapping (gfc_interface_mapping *,
-				gfc_symbol *, gfc_se *);
+				gfc_symbol *, gfc_se *, gfc_expr *);
 void gfc_finish_interface_mapping (gfc_interface_mapping *,
 				   stmtblock_t *, stmtblock_t *);
 void gfc_apply_interface_mapping (gfc_interface_mapping *,

gcc/testsuite/ChangeLog

+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.
+
 2007-12-16  Richard Sandiford  <rsandifo@nildram.co.uk>
 
 	PR rtl-optimization/34415

gcc/testsuite/gfortran.dg/mapping_1.f90

+! { dg-do run }
+! Tests the fix for PR31213, which exposed rather a lot of
+! bugs - see the PR and the ChangeLog.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+module mykinds
+  implicit none
+  integer, parameter :: ik1 = selected_int_kind (2)
+  integer, parameter :: ik2 = selected_int_kind (4)
+  integer, parameter :: dp = selected_real_kind (15,300)
+end module mykinds
+
+module spec_xpr
+  use mykinds
+  implicit none
+  integer(ik2) c_size
+contains
+  pure function tricky (str,ugly)
+    character(*), intent(in) :: str
+    integer(ik1) :: ia_ik1(len(str))
+    interface yoagly
+      pure function ugly(n)
+        use mykinds
+        implicit none
+        integer, intent(in) :: n
+        complex(dp) :: ugly(3*n+2)
+      end function ugly
+    end interface yoagly
+    logical :: la(size (yoagly (size (ia_ik1))))
+    integer :: i
+    character(tricky_helper ((/(.TRUE., i=1, size (la))/)) + c_size) :: tricky
+
+    tricky = transfer (yoagly (1), tricky)
+  end function tricky
+
+  pure function tricky_helper (lb)
+    logical, intent(in) :: lb(:)
+    integer :: tricky_helper
+    tricky_helper = 2 * size (lb) + 3
+  end function tricky_helper
+end module spec_xpr
+
+module xtra_fun
+  implicit none
+contains
+  pure function butt_ugly(n)
+    use mykinds
+    implicit none
+    integer, intent(in) :: n
+    complex(dp) :: butt_ugly(3*n+2)
+    real(dp) pi, sq2
+
+    pi = 4 * atan (1.0_dp)
+    sq2 = sqrt (2.0_dp)
+    butt_ugly = cmplx (pi, sq2, dp)
+  end function butt_ugly
+end module xtra_fun
+
+program spec_test
+  use mykinds
+  use spec_xpr
+  use xtra_fun
+  implicit none
+  character(54) :: chr
+
+  c_size = 5
+  if (tricky ('Help me', butt_ugly) .ne. transfer (butt_ugly (1), chr)) call abort ()
+end program spec_test
+! { dg-final { cleanup-modules "mykinds spec_xpr xtra_fun" } }

gcc/testsuite/gfortran.dg/mapping_2.f90

+! { dg-do run }
+! Tests the fix for PR33998, in which the chain of expressions
+! determining the character length of my_string were not being
+! resolved by the formal to actual mapping.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+module test
+   implicit none
+   contains
+      function my_string(x)
+         integer i
+         real, intent(in) :: x(:)
+         character(0) h4(1:minval([(1,i=1,0)],1))
+         character(0) sv1(size(x,1):size(h4))
+         character(0) sv2(2*lbound(sv1,1):size(h4))
+         character(lbound(sv2,1)-3) my_string
+
+         do i = 1, len(my_string)
+            my_string(i:i) = achar(modulo(i-1,10)+iachar('0'))
+         end do
+      end function my_string
+end module test
+
+program len_test
+   use test
+   implicit none
+   real x(7)
+
+   if (my_string(x) .ne. "01234567890") call abort ()
+end program len_test
+! { dg-final { cleanup-modules "test" } }

gcc/testsuite/gfortran.dg/mapping_3.f90

+! { dg-do run }
+! Tests the fix for PR33888, in which the character length of
+! the elemental function myfunc was not being calculated before
+! the temporary for the array result was allocated.
+!
+! Contributed by Walter Spector <w6ws@earthlink.net>
+!
+program ftn95bug
+  implicit none
+
+  character(8) :: indata(4) =  &
+              (/ '12344321', '98766789', 'abcdefgh', 'ABCDEFGH' /)
+
+  call process (myfunc (indata))  ! <- This caused a gfortran ICE !
+
+contains
+
+  elemental function myfunc (s)
+    character(*), intent(in) :: s
+    character(len (s)) :: myfunc
+
+    myfunc = s
+
+  end function
+
+  subroutine process (strings)
+    character(*), intent(in) :: strings(:)
+
+    if (any (strings .ne. indata)) call abort ()
+
+  end subroutine
+
+end program