re PR fortran/47592 (Multiple function invocation with ALLOCATE (SOURCE=REPEAT('x...

2011-02-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47592
	* trans-stmt.c (gfc_trans_allocate): For deferred character
	length allocations with SOURCE, store to the values and string
	length to avoid calculating twice.  Replace gfc_start_block
	with gfc_init_block to avoid unnecessary contexts and to keep
	declarations of temporaries where they should be. Tidy up the
	code a bit.

2011-02-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47592
	* gfortran.dg/allocate_with_source_1 : New test.

From-SVN: r169862

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b936715b36a051a8d3ade8edcc41a439658941a9..7fc66e0e60fb638b1c98a451991a458918136066 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2011-02-06  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/47592
+       * trans-stmt.c (gfc_trans_allocate): For deferred character
+       length allocations with SOURCE, store to the values and string
+       length to avoid calculating twice.  Replace gfc_start_block
+       with gfc_init_block to avoid unnecessary contexts and to keep
+       declarations of temporaries where they should be. Tidy up the
+       code a bit.
+
 2011-02-05  Janne Blomqvist  <jb@gcc.gnu.org>
 
        PR fortran/42434

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 2ac6989a2e6614df836fcee9dd01001adac4f355..6ddb2cab3ed7347c8a6fdeaffd7f224bee19a4c4 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4451,14 +4451,20 @@ gfc_trans_allocate (gfc_code * code)
   tree pstat;
   tree error_label;
   tree memsz;
+  tree expr3;
+  tree slen3;
   stmtblock_t block;
+  stmtblock_t post;
+  gfc_expr *sz;
+  gfc_se se_sz;
 
   if (!code->ext.alloc.list)
     return NULL_TREE;
 
   pstat = stat = error_label = tmp = memsz = NULL_TREE;
 
-  gfc_start_block (&block);
+  gfc_init_block (&block);
+  gfc_init_block (&post);
 
   /* Either STAT= and/or ERRMSG is present.  */
   if (code->expr1 || code->expr2)
@@ -4472,6 +4478,9 @@ gfc_trans_allocate (gfc_code * code)
       TREE_USED (error_label) = 1;
     }
 
+  expr3 = NULL_TREE;
+  slen3 = NULL_TREE;
+
   for (al = code->ext.alloc.list; al != NULL; al = al->next)
     {
       expr = gfc_copy_expr (al->expr);
@@ -4480,7 +4489,6 @@ gfc_trans_allocate (gfc_code * code)
        gfc_add_data_component (expr);
 
       gfc_init_se (&se, NULL);
-      gfc_start_block (&se.pre);
 
       se.want_pointer = 1;
       se.descriptor_only = 1;
@@ -4495,8 +4503,6 @@ gfc_trans_allocate (gfc_code * code)
            {
              if (code->expr3->ts.type == BT_CLASS)
                {
-                 gfc_expr *sz;
-                 gfc_se se_sz;
                  sz = gfc_copy_expr (code->expr3);
                  gfc_add_vptr_component (sz);
                  gfc_add_size_component (sz);
@@ -4514,7 +4520,6 @@ gfc_trans_allocate (gfc_code * code)
              if (!code->expr3->ts.u.cl->backend_decl)
                {
                  /* Convert and use the length expression.  */
-                 gfc_se se_sz;
                  gfc_init_se (&se_sz, NULL);
                  if (code->expr3->expr_type == EXPR_VARIABLE
                        || code->expr3->expr_type == EXPR_CONSTANT)
@@ -4522,7 +4527,8 @@ gfc_trans_allocate (gfc_code * code)
                      gfc_conv_expr (&se_sz, code->expr3);
                      memsz = se_sz.string_length;
                    }
-                 else if (code->expr3->ts.u.cl
+                 else if (code->expr3->mold
+                            && code->expr3->ts.u.cl
                             && code->expr3->ts.u.cl->length)
                    {
                      gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
@@ -4531,20 +4537,21 @@ gfc_trans_allocate (gfc_code * code)
                      gfc_add_block_to_block (&se.pre, &se_sz.post);
                      memsz = se_sz.expr;
                    }
-                 else if (code->ext.alloc.ts.u.cl
-                            && code->ext.alloc.ts.u.cl->length)
-                   {
-                     gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
-                     memsz = se_sz.expr;
-                   }
                  else
                    {
-                     /* This is likely to be inefficient.  */
-                     gfc_conv_expr (&se_sz, code->expr3);
-                     gfc_add_block_to_block (&se.pre, &se_sz.pre);
-                     se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
-                     gfc_add_block_to_block (&se.pre, &se_sz.post);
-                     memsz = se_sz.string_length;
+                     /* This is would be inefficient and possibly could
+                        generate wrong code if the result were not stored
+                        in expr3/slen3.  */
+                     if (slen3 == NULL_TREE)
+                       {
+                         gfc_conv_expr (&se_sz, code->expr3);
+                         gfc_add_block_to_block (&se.pre, &se_sz.pre);
+                         expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
+                         gfc_add_block_to_block (&post, &se_sz.post);
+                         slen3 = gfc_evaluate_now (se_sz.string_length,
+                                                   &se.pre);
+                       }
+                     memsz = slen3;
                    }
                }
              else
@@ -4580,31 +4587,13 @@ gfc_trans_allocate (gfc_code * code)
                                       TREE_TYPE (tmp), tmp,
                                       fold_convert (TREE_TYPE (tmp), memsz));
            }
+
          /* Allocate - for non-pointers with re-alloc checking.  */
-         {
-           gfc_ref *ref;
-           bool allocatable;
-
-           ref = expr->ref;
-
-           /* Find the last reference in the chain.  */
-           while (ref && ref->next != NULL)
-             {
-               gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
-               ref = ref->next;
-             }
-
-           if (!ref)
-             allocatable = expr->symtree->n.sym->attr.allocatable;
-           else
-             allocatable = ref->u.c.component->attr.allocatable;
-
-           if (allocatable)
-             tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz,
-                                                   pstat, expr);
-           else
-             tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
-         }
+         if (gfc_expr_attr (expr).allocatable)
+           tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz,
+                                                 pstat, expr);
+         else
+           tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
 
          tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
                                 se.expr,
@@ -4629,11 +4618,9 @@ gfc_trans_allocate (gfc_code * code)
              tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
              gfc_add_expr_to_block (&se.pre, tmp);
            }
-
        }
 
-      tmp = gfc_finish_block (&se.pre);
-      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&block, &se.pre);
 
       if (code->expr3 && !code->expr3->mold)
        {
@@ -4668,6 +4655,13 @@ gfc_trans_allocate (gfc_code * code)
              gfc_add_block_to_block (&call.pre, &call.post);
              tmp = gfc_finish_block (&call.pre);
            }
+         else if (expr3 != NULL_TREE)
+           {
+             tmp = build_fold_indirect_ref_loc (input_location, se.expr);
+             gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
+                                    slen3, expr3, code->expr3->ts.kind);
+             tmp = NULL_TREE;
+           }
          else
            {
              /* Switch off automatic reallocation since we have just done
@@ -4799,6 +4793,9 @@ gfc_trans_allocate (gfc_code * code)
       gfc_add_expr_to_block (&block, tmp);
     }
 
+  gfc_add_block_to_block (&block, &se.post);
+  gfc_add_block_to_block (&block, &post);
+
   return gfc_finish_block (&block);
 }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 61110da51f2430a9f1d99933958394c780745c4e..7bb00576f21a6f911e80441c8abceaaf1231f251 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-02-06  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/47592
+       * gfortran.dg/allocate_with_source_1 : New test.
+
 2011-02-05  Jakub Jelinek  <jakub@redhat.com>
 
        PR middle-end/47610

diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_1.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_1.f90
new file mode 100644 (file)
index 0000000..d386bb3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_1.f90
@@ -0,0 +1,29 @@
+! { dg-do run }
+! Test the fix for PR47592, in which the SOURCE expression was
+! being called twice.
+!
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
+!
+module foo
+  implicit none
+contains
+  function bar()
+    integer bar
+    integer :: i=9
+    i = i + 1
+    bar = i
+  end function bar
+end module foo
+
+program note7_35
+  use foo
+  implicit none
+  character(:), allocatable :: name
+  character(:), allocatable :: src
+  integer n
+  n = 10
+  allocate(name, SOURCE=repeat('x',bar()))
+  if (name .ne. 'xxxxxxxxxx') call abort
+  if (len (name) .ne. 10 ) call abort
+end program note7_35
+! { dg-final { cleanup-modules "foo" } }