[gfortran] Fix PR15620

[Paul Brook <paul at codesourcery dot com>]

The attached patch fixes PR15620.
We were using the variables themselves when evaluating statement functions. 
This patch creates temporary variables and uses them in place of the dummy 
arguments. It also ensures that character values are truncated/extended to 
the correct length.

Tested on i686-linux.
Applied to mainline.

Paul

2004-05-30  Paul Brook  <paul@codesourcery.com>

	PR fortran/15620
	* trans-decl.c (gfc_shadow_sym, gfc_restore_sym): New functions.
	* trans-expr.c (gfc_trans_string_copy): New function.
	(gfc_conv_statement_function): Use them.  Create temp vars.  Enforce
	character lengths.
	(gfc_conv_string_parameter): Use gfc_trans_string_copy.
	* trans-stmt.c (gfc_trans_forall_1): Use gfc_{shadow,restore}_sym.
	* trans.h (struct gfc_saved_var): Define.
	(gfc_shadow_sym, gfc_restore_sym): Add prototypes.
testsuite/
	* gfortran.fortran-torture/execute/st_function_1.f90: New test.
	* gfortran.fortran-torture/execute/st_function_2.f90: New test.

Index: trans-decl.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.9
diff -u -p -r1.9 trans-decl.c
--- trans-decl.c	22 May 2004 13:31:07 -0000	1.9
+++ trans-decl.c	30 May 2004 14:25:36 -0000
@@ -866,6 +866,32 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 }
 
 
+/* Substitute a temporary variable in place of the real one.  */
+
+void
+gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
+{
+  save->attr = sym->attr;
+  save->decl = sym->backend_decl;
+
+  gfc_clear_attr (&sym->attr);
+  sym->attr.referenced = 1;
+  sym->attr.flavor = FL_VARIABLE;
+
+  sym->backend_decl = decl;
+}
+
+
+/* Restore the original variable.  */
+
+void
+gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
+{
+  sym->attr = save->attr;
+  sym->backend_decl = save->decl;
+}
+
+
 /* Get a basic decl for an external function.  */
 
 tree
Index: trans-expr.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.6
diff -u -p -r1.6 trans-expr.c
--- trans-expr.c	19 May 2004 00:34:55 -0000	1.6
+++ trans-expr.c	30 May 2004 14:27:28 -0000
@@ -1182,6 +1182,24 @@ gfc_conv_function_call (gfc_se * se, gfc
 }
 
 
+/* Generate code to copy a string.  */
+
+static void
+gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
+		       tree slen, tree src)
+{
+  tree tmp;
+
+  tmp = NULL_TREE;
+  tmp = gfc_chainon_list (tmp, dlen);
+  tmp = gfc_chainon_list (tmp, dest);
+  tmp = gfc_chainon_list (tmp, slen);
+  tmp = gfc_chainon_list (tmp, src);
+  tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
+  gfc_add_expr_to_block (block, tmp);
+}
+
+
 /* Translate a statement function.
    The value of a statement function reference is obtained by evaluating the
    expression using the values of the actual arguments for the values of the
@@ -1196,69 +1214,98 @@ gfc_conv_statement_function (gfc_se * se
   gfc_actual_arglist *args;
   gfc_se lse;
   gfc_se rse;
+  gfc_saved_var *saved_vars;
+  tree *temp_vars;
+  tree type;
+  tree tmp;
+  int n;
 
   sym = expr->symtree->n.sym;
   args = expr->value.function.actual;
   gfc_init_se (&lse, NULL);
   gfc_init_se (&rse, NULL);
 
+  n = 0;
   for (fargs = sym->formal; fargs; fargs = fargs->next)
+    n++;
+  saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
+  temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
+
+  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
     {
       /* Each dummy shall be specified, explicitly or implicitly, to be
          scalar.  */
       assert (fargs->sym->attr.dimension == 0);
       fsym = fargs->sym;
-      assert (fsym->backend_decl);
 
-      /* Convert non-pointer string dummy.  */
-      if (fsym->ts.type == BT_CHARACTER && !fsym->attr.pointer)
+      /* Create a temporary to hold the value.  */
+      type = gfc_typenode_for_spec (&fsym->ts);
+      temp_vars[n] = gfc_create_var (type, fsym->name);
+
+      if (fsym->ts.type == BT_CHARACTER)
         {
-          tree len1;
-          tree len2;
-          tree arg;
-          tree tmp;
-          tree type;
-          tree var;
+	  /* Copy string arguments.  */
+          tree arglen;
 
           assert (fsym->ts.cl && fsym->ts.cl->length
                   && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
 
-          type = gfc_get_character_type (fsym->ts.kind, fsym->ts.cl);
-          len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
-          var = gfc_build_addr_expr (build_pointer_type (type),
-				     fsym->backend_decl);
+          arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+          tmp = gfc_build_addr_expr (build_pointer_type (type),
+				     temp_vars[n]);
 
           gfc_conv_expr (&rse, args->expr);
           gfc_conv_string_parameter (&rse);
-          len2 = rse.string_length;
           gfc_add_block_to_block (&se->pre, &lse.pre);
           gfc_add_block_to_block (&se->pre, &rse.pre);
 
-          arg = NULL_TREE;
-          arg = gfc_chainon_list (arg, len1);
-          arg = gfc_chainon_list (arg, var);
-          arg = gfc_chainon_list (arg, len2);
-          arg = gfc_chainon_list (arg, rse.expr);
-          tmp = gfc_build_function_call (gfor_fndecl_copy_string, arg);
-          gfc_add_expr_to_block (&se->pre, tmp);
+	  gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
+				 rse.expr);
           gfc_add_block_to_block (&se->pre, &lse.post);
           gfc_add_block_to_block (&se->pre, &rse.post);
         }
       else
         {
           /* For everything else, just evaluate the expression.  */
-          if (fsym->attr.pointer == 1)
-            lse.want_pointer = 1;
-
           gfc_conv_expr (&lse, args->expr);
 
           gfc_add_block_to_block (&se->pre, &lse.pre);
-          gfc_add_modify_expr (&se->pre, fsym->backend_decl, lse.expr);
+          gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
           gfc_add_block_to_block (&se->pre, &lse.post);
         }
+
       args = args->next;
     }
+
+  /* Use the temporary variables in place of the real ones.  */
+  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
+    gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
+
   gfc_conv_expr (se, sym->value);
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      gfc_conv_const_charlen (sym->ts.cl);
+
+      /* Force the expression to the correct length.  */
+      if (!INTEGER_CST_P (se->string_length)
+	  || tree_int_cst_lt (se->string_length,
+			      sym->ts.cl->backend_decl))
+	{
+	  type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
+	  tmp = gfc_create_var (type, sym->name);
+	  tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
+	  gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
+				 se->string_length, se->expr);
+	  se->expr = tmp;
+	}
+      se->string_length = sym->ts.cl->backend_decl;
+    }
+
+  /* Resore the original variables.  */
+  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
+    gfc_restore_sym (fargs->sym, &saved_vars[n]);
+  gfc_free (saved_vars);
 }
 
 
@@ -1617,17 +1664,12 @@ gfc_conv_string_parameter (gfc_se * se)
 tree
 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
 {
-  tree tmp;
-  tree args;
   stmtblock_t block;
 
   gfc_init_block (&block);
 
-
   if (type == BT_CHARACTER)
     {
-      args = NULL_TREE;
-
       assert (lse->string_length != NULL_TREE
 	      && rse->string_length != NULL_TREE);
 
@@ -1637,13 +1679,8 @@ gfc_trans_scalar_assign (gfc_se * lse, g
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
 
-      args = gfc_chainon_list (args, lse->string_length);
-      args = gfc_chainon_list (args, lse->expr);
-      args = gfc_chainon_list (args, rse->string_length);
-      args = gfc_chainon_list (args, rse->expr);
-
-      tmp = gfc_build_function_call (gfor_fndecl_copy_string, args);
-      gfc_add_expr_to_block (&block, tmp);
+      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
+			     rse->string_length, rse->expr);
     }
   else
     {
Index: trans-stmt.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-stmt.c,v
retrieving revision 1.4
diff -u -p -r1.4 trans-stmt.c
--- trans-stmt.c	14 May 2004 13:00:04 -0000	1.4
+++ trans-stmt.c	30 May 2004 14:24:36 -0000
@@ -2121,8 +2121,7 @@ gfc_trans_forall_1 (gfc_code * code, for
   gfc_forall_iterator *fa;
   gfc_se se;
   gfc_code *c;
-  tree *saved_var_decl;
-  symbol_attribute *saved_var_attr;
+  gfc_saved_var *saved_vars;
   iter_info *this_forall, *iter_tmp;
   forall_info *info, *forall_tmp;
   temporary_list *temp;
@@ -2141,9 +2140,7 @@ gfc_trans_forall_1 (gfc_code * code, for
   end = (tree *) gfc_getmem (nvar * sizeof (tree));
   step = (tree *) gfc_getmem (nvar * sizeof (tree));
   varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
-  saved_var_decl = (tree *) gfc_getmem (nvar * sizeof (tree));
-  saved_var_attr = (symbol_attribute *)
-    gfc_getmem (nvar * sizeof (symbol_attribute));
+  saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
 
   /* Allocate the space for info.  */
   info = (forall_info *) gfc_getmem (sizeof (forall_info));
@@ -2155,20 +2152,11 @@ gfc_trans_forall_1 (gfc_code * code, for
       /* allocate space for this_forall.  */
       this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
 
-      /* Save the FORALL index's backend_decl.  */
-      saved_var_decl[n] = sym->backend_decl;
-
-      /* Save the attribute.  */
-      saved_var_attr[n] = sym->attr;
-
-      /* Set the proper attributes. */
-      gfc_clear_attr (&sym->attr);
-      sym->attr.referenced = 1;
-      sym->attr.flavor = FL_VARIABLE;
-
       /* Create a temporary variable for the FORALL index.  */
       tmp = gfc_typenode_for_spec (&sym->ts);
       var[n] = gfc_create_var (tmp, sym->name);
+      gfc_shadow_sym (sym, var[n], &saved_vars[n]);
+
       /* Record it in this_forall.  */
       this_forall->var = var[n];
 
@@ -2396,13 +2384,9 @@ gfc_trans_forall_1 (gfc_code * code, for
       c = c->next;
     }
 
-  /* Restore the index original backend_decl and the attribute.  */
-  for (fa = code->ext.forall_iterator, n=0; fa; fa = fa->next, n++)
-    {
-      gfc_symbol *sym = fa->var->symtree->n.sym;
-      sym->backend_decl = saved_var_decl[n];
-      sym->attr = saved_var_attr[n];
-    }
+  /* Restore the original index variables.  */
+  for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
+    gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
 
   /* Free the space for var, start, end, step, varexpr.  */
   gfc_free (var);
@@ -2410,8 +2394,7 @@ gfc_trans_forall_1 (gfc_code * code, for
   gfc_free (end);
   gfc_free (step);
   gfc_free (varexpr);
-  gfc_free (saved_var_decl);
-  gfc_free (saved_var_attr);
+  gfc_free (saved_vars);
 
   if (pmask)
     {
Index: trans.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans.h,v
retrieving revision 1.4
diff -u -p -r1.4 trans.h
--- trans.h	19 May 2004 00:34:55 -0000	1.4
+++ trans.h	30 May 2004 14:05:06 -0000
@@ -235,6 +235,16 @@ typedef struct gfc_loopinfo
 }
 gfc_loopinfo;
 
+
+/* Information about a symbol that has been shadowed by a temporary.  */
+typedef struct
+{
+  symbol_attribute attr;
+  tree decl;
+}
+gfc_saved_var;
+
+
 /* Advance the SS chain to the next term.  */
 void gfc_advance_se_ss_chain (gfc_se *);
 
@@ -364,6 +374,12 @@ void gfc_build_builtin_function_decls (v
 /* Return the variable decl for a symbol.  */
 tree gfc_get_symbol_decl (gfc_symbol *);
 
+/* Substitute a temporary variable in place of the real one.  */
+void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *);
+
+/* Restore the original variable.  */
+void gfc_restore_sym (gfc_symbol *, gfc_saved_var *);
+
 /* Allocate the lang-spcific part of a decl node.  */
 void gfc_allocate_lang_decl (tree);
 

! Check that character valued statement functions honour length parameters
program prog 
  character(8) :: foo
  character(15) :: bar
  character(6) :: p
  character (7) :: s
  foo(p) = p // "World"
  bar(p) = p // "World"
  
  ! Expression longer than function, actual arg shorter than dummy.
  call check (foo("Hello"), "Hello Wo")

  ! Expression shorter than function, actual arg longer than dummy.
  ! Result shorter than type
  s = "Hello"
  call check (bar(s), "Hello World    ")
contains
subroutine check(a, b)
  character (len=*) :: a, b

  if ((a .ne. b) .or. (len(a) .ne. len(b))) call abort ()
end subroutine
end program

Attachment: st_function_2.f90
Description: Text document