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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@82452 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3bc1809..fa09538 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+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.
+
 2004-05-30  Steven G. Kargl  <kargls@comcast.net>
 
        * iresolve.c (gfc_resolve_random_number): Clean up conditional.

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 32dfdc4..7bd912e 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -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

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 092daa7..a1a8d46 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1182,6 +1182,24 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 }
 
 
+/* 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_expr * expr)
   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, gfc_se * rse, bt type)
       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
     {

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 8df85d7..bbaa19d 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -2121,8 +2121,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
   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, forall_info * nested_forall_info)
   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, forall_info * nested_forall_info)
       /* 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, forall_info * nested_forall_info)
       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, forall_info * nested_forall_info)
   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)
     {

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ada575f..1c205ef 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -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 (void);
 /* 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);
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0535cfe..6d0c44b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2004-05-30  Paul Brook  <paul@codesourcery.com>
+
+       PR fortran/15620
+       * gfortran.fortran-torture/execute/st_function_1.f90: New test.
+       * gfortran.fortran-torture/execute/st_function_2.f90: New test.
+
 2004-05-30  Steven G. Kargl  <kargls@comcast.net>
 
        * gfortran.fortran-torture/execute/random_1.f90: New test.

diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90
new file mode 100644 (file)
index 0000000..0387a5f
--- /dev/null
+++ b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90
@@ -0,0 +1,23 @@
+! Check that character valued statement functions honour length parameters
+program st_function_1
+  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

diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90
new file mode 100644 (file)
index 0000000..2dec735
--- /dev/null
+++ b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90
@@ -0,0 +1,21 @@
+! PR15620
+! Check that evaluating a statement function doesn't affect the value of
+! its dummy argument variables.
+program st_function_2
+  integer fn, a, b
+  fn(a, b) = a + b
+  if (foo(1) .ne. 43) call abort
+
+  ! Check that values aren't modified when avaluating the arguments.
+  a = 1
+  b = 5
+  if (fn (b + 2, a + 3) .ne. 11) call abort
+contains
+function foo (x) 
+  integer z, y, foo, x 
+  bar(z) = z*z 
+  z = 42 
+  t = bar(x) 
+  foo = t + z 
+end function 
+end program