[Patch, fortran] PR31213 , PR33888 and PR33998 - formal actual mapping problems

[Patch, fortran] PR31213 , PR33888 and PR33998 - formal actual mapping problems

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 3594 bytes --]

:ADDPATCH fortran:

The attached patch builds upon Richard Sandiford's interface mapping
mechanism to permit the compilation of calls to horrors like:

  pure function tricky (str,ugly)                 ! PR31213
    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

At the same time, the extensions to the mapping mechanism permit a
solution to PR33888, where the size of the temporary for an array
valued call to an elemental function was failing because the interface
mapping occurred too late.

The above serves to illustrate the issues.

(i) The result character length expression is:
length = tricky_helper ((/(.TRUE., i=1, size (la))/)) + c_size

This contains an inquiry about a procedure variable, which must be
expanded in the caller's scope, using the actual argument values for
the procedure.  This is performed by the new function trans-expr.c
(gfc_map_intrinsic_function).

It should be noted that my attempts to make this implementation of
LBOUND and UBOUND compliant with the standard failed, in the case
where the size in the dimension concerned is zero.  This failure comes
about because expressions like gfc_log2int (gfc_gt (*, *, *)) return
not zero or one but zero and the numeric value of the greater-than.
The only way that I can see to deal with this is to write a hidden
intrinsic gfc_expr* gfc_cond ('cond', 'value') = <'cond' ?  'value' :
'zero'>.  I have added a TODO to this effect.

(ii) When this character length is expanded, we get:
length = tricky_helper ((/(.TRUE., i=1, size (ugly (size (ia_ik1))))/)) + c_size

The mapping of this procedure requires the actual argument expression
so that the expressions for the result characteristics can be mapped
onto the formal arguments and hence to the caller's actual arguments.
This necessitates the addition of the 'expr' field to the mapping
structure.  The function is mapped in gfc_map_fcn_formal_to_actual.
Note that the backend_decl is not available here, so expression
substitution has to be introduced to the mapping mechanism as well as
symtree substitution.  Note, as well, that the specific function
'ugly' has to be set as referenced in the caller's scope.

(iii) The array constructor has an iterator variable that is not
declared in the caller's scope.  This is dealt with by making a
temporary, when no backend_decl is present.

(iv) Since the mapping mechanism can now mix tree expressions and
frontend expressions, this open ups up the solution to PR33888, where
a mapping is done for the elemental character length, purely in
frontend expressions.  This is the purpose of trans-expr.c
(get_elemental_fcn_charlen).

With this introduction, the patch and the ChangeLogs should be
comprehensible.  The testcases are the contributors'.  I might just
reorder these so that the patch is tested more systematically but they
will do for now.

This patch has only been regtested on Cygwin_NT/amd64, so it might
have some of the usual problems.  Also, it has not been tested on CP2K
or tonto-2.3 yet.  I will be in a position to remedy all of this next
week but if somebody could give the patch a spin on a more lively
system, I would be grateful.

OK for trunk?

Paul

[-- Attachment #2: Change.Logs --]
[-- Type: application/octet-stream, Size: 2323 bytes --]

2007-12-13  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-13  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.

[-- Attachment #3: patch_1213.diff --]
[-- Type: application/octet-stream, Size: 23891 bytes --]

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 130724)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_trans_array_constructor_value (stmtb
*** 1225,1234 ****
  
  	  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;
  
  	  /* Make a temporary, store the current value in that
  	     and return it, once the loop is done.  */
--- 1225,1245 ----
  
  	  loopbody = gfc_finish_block (&body);
  
! 	  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 exxpression 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.  */
*************** gfc_get_dataptr_offset (stmtblock_t *blo
*** 4491,4496 ****
--- 4502,4548 ----
  }
  
  
+ /* 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
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4624,4629 ****
--- 4676,4685 ----
  	{
  	  /* 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
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 130724)
--- gcc/fortran/trans-expr.c	(working copy)
*************** along with GCC; see the file COPYING3.  
*** 34,39 ****
--- 34,40 ----
  #include "langhooks.h"
  #include "flags.h"
  #include "gfortran.h"
+ #include "arith.h"
  #include "trans.h"
  #include "trans-const.h"
  #include "trans-types.h"
*************** along with GCC; see the file COPYING3.  
*** 43,49 ****
  #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 *,
  						 gfc_expr *);
  
  /* Copy the scalarization loop variables.  */
--- 44,50 ----
  #include "dependency.h"
  
  static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
! static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
  						 gfc_expr *);
  
  /* Copy the scalarization loop variables.  */
*************** gfc_free_interface_mapping (gfc_interfac
*** 1417,1422 ****
--- 1418,1424 ----
      {
        nextsym = sym->next;
        gfc_free_symbol (sym->new->n.sym);
+       gfc_free_expr (sym->expr);
        gfc_free (sym->new);
        gfc_free (sym);
      }
*************** gfc_set_interface_mapping_bounds (stmtbl
*** 1521,1527 ****
  
  void
  gfc_add_interface_mapping (gfc_interface_mapping * mapping,
! 			   gfc_symbol * sym, gfc_se * se)
  {
    gfc_interface_sym_mapping *sm;
    tree desc;
--- 1523,1530 ----
  
  void
  gfc_add_interface_mapping (gfc_interface_mapping * mapping,
! 			   gfc_symbol * sym, gfc_se * se,
! 			   gfc_expr *expr)
  {
    gfc_interface_sym_mapping *sm;
    tree desc;
*************** gfc_add_interface_mapping (gfc_interface
*** 1539,1544 ****
--- 1542,1548 ----
    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;
*************** gfc_add_interface_mapping (gfc_interface
*** 1551,1576 ****
    sm->next = mapping->syms;
    sm->old = sym;
    sm->new = new_symtree;
    mapping->syms = sm;
  
    /* Stabilize the argument's value.  */
!   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);
  
        /* 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)
  	{
  	  se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
  	  new_sym->ts.cl->backend_decl = se->string_length;
  	}
      }
  
    /* Use the passed value as-is if the argument is a function.  */
    if (sym->attr.flavor == FL_PROCEDURE)
      value = se->expr;
--- 1555,1586 ----
    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.  */
!   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 && 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;
*************** gfc_apply_interface_mapping_to_ref (gfc_
*** 1706,1726 ****
  }
  
  
  /* 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
  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;
  
    /* Copying an expression does not copy its length, so do that here.  */
    if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
--- 1716,1874 ----
  }
  
  
+ /* 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 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
+ 	d = 0;
+ 
+       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 void
  gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
  				     gfc_expr * expr)
  {
    gfc_interface_sym_mapping *sym;
    gfc_actual_arglist *actual;
  
    if (!expr)
!     return;
  
    /* Copying an expression does not copy its length, so do that here.  */
    if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
*************** gfc_apply_interface_mapping_to_expr (gfc
*** 1733,1749 ****
    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;
  
!   /* ...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:
--- 1881,1901 ----
    gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
  
    /* ...and to the expression's symbol, if it has one.  */
!   /* 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.  */
    switch (expr->expr_type)
      {
      case EXPR_VARIABLE:
      case EXPR_CONSTANT:
      case EXPR_NULL:
      case EXPR_SUBSTRING:
*************** gfc_apply_interface_mapping_to_expr (gfc
*** 1755,1781 ****
        break;
  
      case EXPR_FUNCTION:
        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;
! 	}
  
        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);
        break;
  
      case EXPR_ARRAY:
--- 1907,1928 ----
        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.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;
! 	    gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
! 	    expr->value.function.esym->result = sym->new->n.sym;
! 	  }
        break;
  
      case EXPR_ARRAY:
*************** gfc_apply_interface_mapping_to_expr (gfc
*** 1783,1789 ****
        gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
        break;
      }
!   return seen_result;
  }
  
  
--- 1930,1937 ----
        gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
        break;
      }
! 
!   return;
  }
  
  
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2351,2357 ****
  	}
  
        if (fsym && need_interface_mapping)
! 	gfc_add_interface_mapping (&mapping, fsym, &parmse);
  
        gfc_add_block_to_block (&se->pre, &parmse.pre);
        gfc_add_block_to_block (&post, &parmse.post);
--- 2499,2505 ----
  	}
  
        if (fsym && need_interface_mapping)
! 	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);
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c	(revision 130724)
--- gcc/fortran/dump-parse-tree.c	(working copy)
*************** gfc_show_symbol (gfc_symbol *sym)
*** 731,736 ****
--- 731,747 ----
  }
  
  
+ /* 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.  */
  
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 130724)
--- gcc/fortran/gfortran.h	(working copy)
*************** void gfc_show_namelist (gfc_namelist *);
*** 2364,2369 ****
--- 2364,2370 ----
  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 */
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 130724)
--- gcc/fortran/trans.h	(working copy)
*************** typedef struct gfc_interface_sym_mapping
*** 695,700 ****
--- 695,701 ----
    struct gfc_interface_sym_mapping *next;
    gfc_symbol *old;
    gfc_symtree *new;
+   gfc_expr *expr;
  }
  gfc_interface_sym_mapping;
  
*************** gfc_interface_mapping;
*** 716,722 ****
  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 *);
  void gfc_finish_interface_mapping (gfc_interface_mapping *,
  				   stmtblock_t *, stmtblock_t *);
  void gfc_apply_interface_mapping (gfc_interface_mapping *,
--- 717,723 ----
  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_expr *);
  void gfc_finish_interface_mapping (gfc_interface_mapping *,
  				   stmtblock_t *, stmtblock_t *);
  void gfc_apply_interface_mapping (gfc_interface_mapping *,
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 130724)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_generic_f0 (gfc_expr *expr, gfc_
*** 1425,1430 ****
--- 1425,1432 ----
  	  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;
  	}
  
Index: gcc/testsuite/gfortran.dg/mapping_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/mapping_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/mapping_1.f90	(revision 0)
***************
*** 0 ****
--- 1,70 ----
+ ! { 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" } }
Index: gcc/testsuite/gfortran.dg/mapping_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/mapping_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/mapping_2.f90	(revision 0)
***************
*** 0 ****
--- 1,32 ----
+ ! { 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(size(h4)) 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" } }
Index: gcc/testsuite/gfortran.dg/mapping_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/mapping_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/mapping_3.f90	(revision 0)
***************
*** 0 ****
--- 1,33 ----
+ ! { 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

Re: [Patch, fortran] PR31213 , PR33888 and PR33998 - formal actual mapping problems

[Tobias Burnus]

Paul Richard Thomas wrote:
> The attached patch builds upon Richard Sandiford's interface mapping
> mechanism

!             /* If the iterator appears in a specification exxpression in
!                an interface mapping, we need to make a temp for the loop

s/exxpression/expression/ as Dominique already noted.


+         if (expr->ts.type == BT_CHARACTER
+               && expr->ts.cl->length->expr_type != EXPR_CONSTANT)

Indention looks wrong.


+          character(0) h4(1:minval([(1,i=1,0)],1))

As written, this gives a huge array size. As Dominique remarked:

> The original pr33998 had the line:
>
>         character(0) sv1(size(x,1):size(h4)) 



+       /* TODO These implementations of lbound and ubound do not limit
if the
+          size < 0, according to 13.14.53 and 13.14.113.  */

You should mention which Fortran standard you quote (F95 or F2003; it is
F95). At least when there is also F2008 it will get a bit confusing.


+    case GFC_ISYM_LBOUND:
+    case GFC_ISYM_UBOUND:
[...]
+      if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+       d = mpz_get_si (arg2->value.integer) - 1;
+      else
+       d = 0;
+
+      if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
+       new_expr = gfc_copy_expr (sym->as->lower[d]);

I do not understand the arg2 == NULL case; arg2 is the dimension, but
why is new_expr equal to dimension 1 and not an array with the ubounds
of all dimensions? Probably I just have not yet fully understood the patch.


Otherwise the patch looks ok and as far as I tested fixes all test cases
from the PRs.


Tobias

Re: [Patch, fortran] PR31213 , PR33888 and PR33998 - formal actual mapping problems

[Paul Richard Thomas]

Tobias,

Thanks for the review.

> s/exxpression/expression/ as Dominique already noted.

Fixed.

>
>
> +         if (expr->ts.type == BT_CHARACTER
> +               && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
>
> Indention looks wrong.

It is in fact OK.

>
>
> +          character(0) h4(1:minval([(1,i=1,0)],1))
>
> As written, this gives a huge array size. As Dominique remarked:
>
> > The original pr33998 had the line:
> >
> >         character(0) sv1(size(x,1):size(h4))

Will change both.
>
>
>
> +       /* TODO These implementations of lbound and ubound do not limit
> if the
> +          size < 0, according to 13.14.53 and 13.14.113.  */
>
> You should mention which Fortran standard you quote (F95 or F2003; it is
> F95). At least when there is also F2008 it will get a bit confusing.

Done.

> I do not understand the arg2 == NULL case; arg2 is the dimension, but
> why is new_expr equal to dimension 1 and not an array with the ubounds
> of all dimensions? Probably I just have not yet fully understood the patch.

I do not think that this is reachable.  I added this as a soggy,
harmless way of bailing out.  I'll put a gcc_unreachable and a TODO to
the effect that should the appliciations for this extension to the
mapping mechanism be extended, the array should result.
>
>
> Otherwise the patch looks ok and as far as I tested fixes all test cases
> from the PRs.

Great.  With the above modifications, I will commit it tomorrow morning.

Again, thanks

Paul


-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy