OSDN Git Service

2010-04-06 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 6 Apr 2010 12:46:19 +0000 (12:46 +0000)
committerMasaki Muranaka <monaka@monami-software.com>
Sun, 23 May 2010 00:45:17 +0000 (09:45 +0900)
        PR fortran/43178
        * trans-array.c (gfc_conv_expr_descriptor): Update
        gfc_trans_scalar_assign call.
        (has_default_initializer): New function.
        (gfc_trans_deferred_array): Nullify less often.
        * trans-expr.c (gfc_conv_subref_array_arg,
        gfc_trans_subcomponent_assign): Update call to
        gfc_trans_scalar_assign.
        (gfc_trans_scalar_assign): Add parameter and pass it on.
        (gfc_trans_assignment_1): Optionally, do not dealloc before
        assignment.
        * trans-openmp.c (gfc_trans_omp_array_reduction): Update
        call to gfc_trans_scalar_assign.
        * trans-decl.c (gfc_get_symbol_decl): Do not always apply
        initializer to static variables.
        (gfc_init_default_dt): Add dealloc parameter and pass it on.
        * trans-stmt.c (forall_make_variable_temp,
        generate_loop_for_temp_to_lhs, generate_loop_for_rhs_to_temp,
        gfc_trans_forall_1, gfc_trans_where_assign, gfc_trans_where_3
        gfc_trans_allocate): Update gfc_trans_assignment call.
        * trans.h (gfc_trans_scalar_assign, gfc_init_default_dt,
        gfc_init_default_dt, gfc_trans_assignment): Add bool dealloc
        parameter to prototype.

2010-04-06  Tobias Burnus  <burnus@net-b.de>

        PR fortran/43178
        * gfortran.dg/alloc_comp_basics_1.f90: Update
        * scan-tree-dump-times.
        * gfortran.dg/alloc_comp_constructor_1.f90: Ditto.
        * gfortran.dg/auto_dealloc_1.f90: Ditto.

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

gcc/fortran/ChangeLog
gcc/fortran/trans-array.c
gcc/fortran/trans-expr.c
gcc/testsuite/ChangeLog

index 53884cc..97a2fca 100644 (file)
@@ -1,3 +1,29 @@
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/43178
+       * trans-array.c (gfc_conv_expr_descriptor): Update
+       gfc_trans_scalar_assign call.
+       (has_default_initializer): New function.
+       (gfc_trans_deferred_array): Nullify less often.
+       * trans-expr.c (gfc_conv_subref_array_arg,
+       gfc_trans_subcomponent_assign): Update call to
+       gfc_trans_scalar_assign.
+       (gfc_trans_scalar_assign): Add parameter and pass it on.
+       (gfc_trans_assignment_1): Optionally, do not dealloc before
+       assignment.
+       * trans-openmp.c (gfc_trans_omp_array_reduction): Update
+       call to gfc_trans_scalar_assign.
+       * trans-decl.c (gfc_get_symbol_decl): Do not always apply
+       initializer to static variables.
+       (gfc_init_default_dt): Add dealloc parameter and pass it on.
+       * trans-stmt.c (forall_make_variable_temp,
+       generate_loop_for_temp_to_lhs, generate_loop_for_rhs_to_temp,
+       gfc_trans_forall_1, gfc_trans_where_assign, gfc_trans_where_3
+       gfc_trans_allocate): Update gfc_trans_assignment call.
+       * trans.h (gfc_trans_scalar_assign, gfc_init_default_dt,
+       gfc_init_default_dt, gfc_trans_assignment): Add bool dealloc
+       parameter to prototype.
+
 2010-03-31  Paul Thomas  <pault@gcc.gnu.org>
 
        * ioparm.def : Update copyright.
index 1f6021a..75516ce 100644 (file)
@@ -80,10 +80,12 @@ along with GCC; see the file COPYING3.  If not see
 #include "system.h"
 #include "coretypes.h"
 #include "tree.h"
+#include "gimple.h"
+#include "ggc.h"
 #include "toplev.h"
+#include "real.h"
 #include "flags.h"
 #include "gfortran.h"
-#include "constructor.h"
 #include "trans.h"
 #include "trans-stmt.h"
 #include "trans-types.h"
@@ -92,7 +94,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "dependency.h"
 
 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
-static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
+static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
 
 /* The contents of this structure aren't actually used, just the address.  */
 static gfc_ss gfc_ss_terminator_var;
@@ -722,7 +724,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
 
   /* Initialize the descriptor.  */
   type =
-    gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1,
+    gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
                               GFC_ARRAY_UNKNOWN, true);
   desc = gfc_create_var (type, "atmp");
   GFC_DECL_PACKED_ARRAY (desc) = 1;
@@ -1012,9 +1014,8 @@ gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
    of array constructor C.  */
 
 static bool
-gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
+gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
 {
-  gfc_constructor *c;
   gfc_iterator *i;
   mpz_t val;
   mpz_t len;
@@ -1025,7 +1026,7 @@ gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
   mpz_init (val);
 
   dynamic = false;
-  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+  for (; c; c = c->next)
     {
       i = c->iterator;
       if (i && gfc_iterator_has_dynamic_bounds (i))
@@ -1230,7 +1231,7 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
 
 static void
 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
-                                  tree desc, gfc_constructor_base base,
+                                  tree desc, gfc_constructor * c,
                                   tree * poffset, tree * offsetvar,
                                   bool dynamic)
 {
@@ -1238,13 +1239,12 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
   stmtblock_t body;
   gfc_se se;
   mpz_t size;
-  gfc_constructor *c;
 
   tree shadow_loopvar = NULL_TREE;
   gfc_saved_var saved_loopvar;
 
   mpz_init (size);
-  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+  for (; c; c = c->next)
     {
       /* If this is an iterator or an array, the offset must be a variable.  */
       if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
@@ -1289,7 +1289,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
          n = 0;
          while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
            {
-             p = gfc_constructor_next (p);
+             p = p->next;
              n++;
            }
          if (n < 4)
@@ -1305,13 +1305,14 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
          else
            {
              /* Collect multiple scalar constants into a constructor.  */
-             VEC(constructor_elt,gc) *v = NULL;
+             tree list;
              tree init;
              tree bound;
              tree tmptype;
              HOST_WIDE_INT idx = 0;
 
              p = c;
+             list = NULL_TREE;
               /* Count the number of consecutive scalar constants.  */
              while (p && !(p->iterator
                            || p->expr->expr_type != EXPR_CONSTANT))
@@ -1328,12 +1329,10 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
                                (gfc_get_pchar_type (p->expr->ts.kind),
                                 se.expr);
 
-                  CONSTRUCTOR_APPEND_ELT (v,
-                                          build_int_cst (gfc_array_index_type,
-                                                         idx++),
-                                          se.expr);
+                 list = tree_cons (build_int_cst (gfc_array_index_type,
+                                                  idx++), se.expr, list);
                  c = p;
-                 p = gfc_constructor_next (p);
+                 p = p->next;
                }
 
              bound = build_int_cst (NULL_TREE, n - 1);
@@ -1342,7 +1341,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
                                          gfc_index_zero_node, bound);
              tmptype = build_array_type (type, tmptype);
 
-             init = build_constructor (tmptype, v);
+             init = build_constructor_from_list (tmptype, nreverse (list));
              TREE_CONSTANT (init) = 1;
              TREE_STATIC (init) = 1;
              /* Create a static variable to hold the data.  */
@@ -1586,14 +1585,13 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
    Returns TRUE if all elements are character constants.  */
 
 bool
-get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
 {
-  gfc_constructor *c;
   bool is_const;
-
+  
   is_const = TRUE;
 
-  if (gfc_constructor_first (base) == NULL)
+  if (c == NULL)
     {
       if (len)
        *len = build_int_cstu (gfc_charlen_type_node, 0);
@@ -1603,8 +1601,7 @@ get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len
   /* Loop over all constructor elements to find out is_const, but in len we
      want to store the length of the first, not the last, element.  We can
      of course exit the loop as soon as is_const is found to be false.  */
-  for (c = gfc_constructor_first (base);
-       c && is_const; c = gfc_constructor_next (c))
+  for (; c && is_const; c = c->next)
     {
       switch (c->expr->expr_type)
        {
@@ -1644,18 +1641,17 @@ get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len
    return zero.  Note, an empty or NULL array constructor returns zero.  */
 
 unsigned HOST_WIDE_INT
-gfc_constant_array_constructor_p (gfc_constructor_base base)
+gfc_constant_array_constructor_p (gfc_constructor * c)
 {
   unsigned HOST_WIDE_INT nelem = 0;
 
-  gfc_constructor *c = gfc_constructor_first (base);
   while (c)
     {
       if (c->iterator
          || c->expr->rank > 0
          || c->expr->expr_type != EXPR_CONSTANT)
        return 0;
-      c = gfc_constructor_next (c);
+      c = c->next;
       nelem++;
     }
   return nelem;
@@ -1669,18 +1665,18 @@ gfc_constant_array_constructor_p (gfc_constructor_base base)
 tree
 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
 {
-  tree tmptype, init, tmp;
+  tree tmptype, list, init, tmp;
   HOST_WIDE_INT nelem;
   gfc_constructor *c;
   gfc_array_spec as;
   gfc_se se;
   int i;
-  VEC(constructor_elt,gc) *v = NULL;
 
   /* First traverse the constructor list, converting the constants
      to tree to build an initializer.  */
   nelem = 0;
-  c = gfc_constructor_first (expr->value.constructor);
+  list = NULL_TREE;
+  c = expr->value.constructor;
   while (c)
     {
       gfc_init_se (&se, NULL);
@@ -1690,9 +1686,9 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
       else if (POINTER_TYPE_P (type))
        se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
                                       se.expr);
-      CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
-                              se.expr);
-      c = gfc_constructor_next (c);
+      list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
+                       se.expr, list);
+      c = c->next;
       nelem++;
     }
 
@@ -1706,22 +1702,20 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
   as.type = AS_EXPLICIT;
   if (!expr->shape)
     {
-      as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
-      as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
-                                     NULL, nelem - 1);
+      as.lower[0] = gfc_int_expr (0);
+      as.upper[0] = gfc_int_expr (nelem - 1);
     }
   else
     for (i = 0; i < expr->rank; i++)
       {
        int tmp = (int) mpz_get_si (expr->shape[i]);
-        as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
-        as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
-                                       NULL, tmp - 1);
+       as.lower[i] = gfc_int_expr (0);
+       as.upper[i] = gfc_int_expr (tmp - 1);
       }
 
   tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
 
-  init = build_constructor (tmptype, v);
+  init = build_constructor_from_list (tmptype, nreverse (list));
 
   TREE_CONSTANT (init) = 1;
   TREE_STATIC (init) = 1;
@@ -1813,7 +1807,7 @@ constant_array_constructor_loop_size (gfc_loopinfo * loop)
 static void
 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
 {
-  gfc_constructor_base c;
+  gfc_constructor *c;
   tree offset;
   tree offsetvar;
   tree desc;
@@ -2052,10 +2046,9 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
          break;
 
        case GFC_SS_REFERENCE:
-         /* Scalar argument to elemental procedure.  Evaluate this
-            now.  */
+         /* Scalar reference.  Evaluate this now.  */
          gfc_init_se (&se, NULL);
-         gfc_conv_expr (&se, ss->expr);
+         gfc_conv_expr_reference (&se, ss->expr);
          gfc_add_block_to_block (&loop->pre, &se.pre);
          gfc_add_block_to_block (&loop->post, &se.post);
 
@@ -2323,6 +2316,10 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
       && se->loop->ss->loop_chain->expr->symtree)
     name = se->loop->ss->loop_chain->expr->symtree->name;
 
+  if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
+      && se->loop->ss->loop_chain->expr->symtree)
+    name = se->loop->ss->loop_chain->expr->symtree->name;
+
   if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
     {
       if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
@@ -2334,9 +2331,6 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
          name = "unnamed constant";
     }
 
-  if (TREE_CODE (descriptor) == VAR_DECL)
-    name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
-
   /* If upper bound is present, include both bounds in the error message.  */
   if (check_upper)
     {
@@ -2433,7 +2427,6 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
                                          gfc_conv_array_data (desc));
          index = gfc_build_array_ref (data, index, NULL);
          index = gfc_evaluate_now (index, &se->pre);
-         index = fold_convert (gfc_array_index_type, index);
 
          /* Do any bounds checking on the final info->descriptor index.  */
          index = gfc_trans_array_bound_check (se, info->descriptor,
@@ -2538,9 +2531,6 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
   gfc_se indexse;
   gfc_se tmpse;
 
-  if (ar->dimen == 0)
-    return;
-
   /* Handle scalarized references separately.  */
   if (ar->type != AR_ELEMENT)
     {
@@ -3365,15 +3355,13 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
              if (size[n])
                {
                  tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
-                 asprintf (&msg, "Array bound mismatch for dimension %d "
-                           "of array '%s' (%%ld/%%ld)",
+                 asprintf (&msg, "%s, size mismatch for dimension %d "
+                           "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
                            info->dim[n]+1, ss->expr->symtree->name);
-
                  gfc_trans_runtime_check (true, false, tmp3, &inner,
                                           &ss->expr->where, msg,
                        fold_convert (long_integer_type_node, tmp),
                        fold_convert (long_integer_type_node, size[n]));
-
                  gfc_free (msg);
                }
              else
@@ -3566,6 +3554,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
   tree tmp;
   gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
   bool dynamic[GFC_MAX_DIMENSIONS];
+  gfc_constructor *c;
   mpz_t *cshape;
   mpz_t i;
 
@@ -3590,7 +3579,6 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
 
          if (ss->type == GFC_SS_CONSTRUCTOR)
            {
-             gfc_constructor_base base;
              /* An unknown size constructor will always be rank one.
                 Higher rank constructors will either have known shape,
                 or still be wrapped in a call to reshape.  */
@@ -3600,8 +3588,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
                 can be determined at compile time.  Prefer not to otherwise,
                 since the general case involves realloc, and it's better to
                 avoid that overhead if possible.  */
-             base = ss->expr->value.constructor;
-             dynamic[n] = gfc_get_array_constructor_size (&i, base);
+             c = ss->expr->value.constructor;
+             dynamic[n] = gfc_get_array_constructor_size (&i, c);
              if (!dynamic[n] || !loopspec[n])
                loopspec[n] = ss;
              continue;
@@ -3817,7 +3805,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
 /*GCC ARRAYS*/
 
 static tree
-gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
+gfc_array_init_size (tree descriptor, int rank, tree * poffset,
                     gfc_expr ** lower, gfc_expr ** upper,
                     stmtblock_t * pblock)
 {
@@ -3915,43 +3903,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
       stride = gfc_evaluate_now (stride, pblock);
     }
 
-  for (n = rank; n < rank + corank; n++)
-    {
-      ubound = upper[n];
-
-      /* Set lower bound.  */
-      gfc_init_se (&se, NULL);
-      if (lower == NULL || lower[n] == NULL)
-       {
-         gcc_assert (n == rank + corank - 1);
-         se.expr = gfc_index_one_node;
-       }
-      else
-       {
-          if (ubound || n == rank + corank - 1)
-            {
-             gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
-             gfc_add_block_to_block (pblock, &se.pre);
-            }
-          else
-            {
-              se.expr = gfc_index_one_node;
-              ubound = lower[n];
-            }
-       }
-      gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
-                                     se.expr);
-
-      if (n < rank + corank - 1)
-       {
-         gfc_init_se (&se, NULL);
-         gcc_assert (ubound);
-         gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
-         gfc_add_block_to_block (pblock, &se.pre);
-         gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
-       }
-    }
-
   /* The stride is the number of elements in the array, so multiply by the
      size of an element to get the total size.  */
   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
@@ -4000,15 +3951,14 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
   gfc_expr **lower;
   gfc_expr **upper;
   gfc_ref *ref, *prev_ref = NULL;
-  bool allocatable_array, coarray;
+  bool allocatable_array;
 
   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->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
+      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
       prev_ref = ref;
       ref = ref->next;
     }
@@ -4017,39 +3967,16 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
     return false;
 
   if (!prev_ref)
-    {
-      allocatable_array = expr->symtree->n.sym->attr.allocatable;
-      coarray = expr->symtree->n.sym->attr.codimension;
-    }
+    allocatable_array = expr->symtree->n.sym->attr.allocatable;
   else
-    {
-      allocatable_array = prev_ref->u.c.component->attr.allocatable;
-      coarray = prev_ref->u.c.component->attr.codimension;
-    }
-
-  /* Return if this is a scalar coarray.  */
-  if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
-      || (prev_ref && !prev_ref->u.c.component->attr.dimension))
-    {
-      gcc_assert (coarray);
-      return false;
-    }
+    allocatable_array = prev_ref->u.c.component->attr.allocatable;
 
   /* Figure out the size of the array.  */
   switch (ref->u.ar.type)
     {
     case AR_ELEMENT:
-      if (!coarray)
-       {
-         lower = NULL;
-         upper = ref->u.ar.start;
-         break;
-       }
-      /* Fall through.  */
-
-    case AR_SECTION:
-      lower = ref->u.ar.start;
-      upper = ref->u.ar.end;
+      lower = NULL;
+      upper = ref->u.ar.start;
       break;
 
     case AR_FULL:
@@ -4059,14 +3986,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
       upper = ref->u.ar.as->upper;
       break;
 
+    case AR_SECTION:
+      lower = ref->u.ar.start;
+      upper = ref->u.ar.end;
+      break;
+
     default:
       gcc_unreachable ();
       break;
     }
 
-  size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
-                             ref->u.ar.as->corank, &offset, lower, upper,
-                             &se->pre);
+  size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
+                             lower, upper, &se->pre);
 
   /* Allocate memory to store the data.  */
   pointer = gfc_conv_descriptor_data_get (se->expr);
@@ -4131,10 +4062,11 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
 {
   gfc_constructor *c;
   tree tmp;
+  mpz_t maxval;
   gfc_se se;
   HOST_WIDE_INT hi;
   unsigned HOST_WIDE_INT lo;
-  tree index;
+  tree index, range;
   VEC(constructor_elt,gc) *v = NULL;
 
   switch (expr->expr_type)
@@ -4169,8 +4101,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
 
     case EXPR_ARRAY:
       /* Create a vector of all the elements.  */
-      for (c = gfc_constructor_first (expr->value.constructor);
-          c; c = gfc_constructor_next (c))
+      for (c = expr->value.constructor; c; c = c->next)
         {
           if (c->iterator)
             {
@@ -4183,17 +4114,46 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
                               gfc_option.flag_max_array_constructor);
              return NULL_TREE;
            }
-          if (mpz_cmp_si (c->offset, 0) != 0)
-            index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
+          if (mpz_cmp_si (c->n.offset, 0) != 0)
+            index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
           else
             index = NULL_TREE;
+         mpz_init (maxval);
+          if (mpz_cmp_si (c->repeat, 0) != 0)
+            {
+              tree tmp1, tmp2;
+
+              mpz_set (maxval, c->repeat);
+              mpz_add (maxval, c->n.offset, maxval);
+              mpz_sub_ui (maxval, maxval, 1);
+              tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+              if (mpz_cmp_si (c->n.offset, 0) != 0)
+                {
+                  mpz_add_ui (maxval, c->n.offset, 1);
+                  tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+                }
+              else
+                tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
+
+              range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
+            }
+          else
+            range = NULL;
+         mpz_clear (maxval);
 
           gfc_init_se (&se, NULL);
          switch (c->expr->expr_type)
            {
            case EXPR_CONSTANT:
              gfc_conv_constant (&se, c->expr);
-             CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+              if (range == NULL_TREE)
+               CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+              else
+                {
+                  if (index != NULL_TREE)
+                   CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+                 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+                }
              break;
 
            case EXPR_STRUCTURE:
@@ -4207,7 +4167,14 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
                 for one reason or another, assuming that if they are
                 standard defying the frontend will catch them.  */
              gfc_conv_expr (&se, c->expr);
-             CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+             if (range == NULL_TREE)
+               CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+             else
+               {
+                 if (index != NULL_TREE)
+                 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+                 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+               }
              break;
            }
         }
@@ -4641,26 +4608,15 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
            {
              /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)).  */
              char * msg;
-             tree temp;
-
-             temp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                                 ubound, lbound);
-             temp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
-                                 gfc_index_one_node, temp);
 
-             stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+             tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+                                ubound, lbound);
+              stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
                                     dubound, dlbound);
-             stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
-                                    gfc_index_one_node, stride2);
-
-              tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
-             asprintf (&msg, "Dimension %d of array '%s' has extent "
-                       "%%ld instead of %%ld", n+1, sym->name);
-
-             gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg, 
-                       fold_convert (long_integer_type_node, temp),
-                       fold_convert (long_integer_type_node, stride2));
-
+              tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
+             asprintf (&msg, "%s for dimension %d of array '%s'",
+                       gfc_msg_bounds, n+1, sym->name);
+             gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
              gfc_free (msg);
            }
        }
@@ -5265,6 +5221,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       gfc_trans_scalarizing_loops (&loop, &block);
 
       desc = loop.temp_ss->data.info.descriptor;
+
+      gcc_assert (is_gimple_lvalue (desc));
     }
   else if (expr->expr_type == EXPR_FUNCTION)
     {
@@ -5302,7 +5260,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
        {
          /* Otherwise make a new one.  */
          parmtype = gfc_get_element_type (TREE_TYPE (desc));
-         parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
+         parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
                                                loop.from, loop.to, 0,
                                                GFC_ARRAY_UNKNOWN, false);
          parm = gfc_create_var (parmtype, "parm");
@@ -6218,6 +6176,25 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
 }
 
 
+/* Check for default initializer; sym->value is not enough as it is also
+   set for EXPR_NULL of allocatables.  */
+
+static bool
+has_default_initializer (gfc_symbol *der)
+{
+  gfc_component *c;
+
+  gcc_assert (der->attr.flavor == FL_DERIVED);
+  for (c = der->components; c; c = c->next)
+    if ((c->ts.type != BT_DERIVED && c->initializer)
+        || (c->ts.type == BT_DERIVED
+            && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
+      break;
+
+  return c != NULL;
+}
+
+
 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
    Do likewise, recursively if necessary, with the allocatable components of
    derived types.  */
@@ -6284,8 +6261,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
       if (!sym->attr.save
          && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
        {
-         if (sym->value == NULL
-             || !gfc_has_default_initializer (sym->ts.u.derived))
+         if (sym->value == NULL || !has_default_initializer (sym->ts.u.derived))
            {
              rank = sym->as ? sym->as->rank : 0;
              tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
@@ -6385,13 +6361,6 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
        continue;
 
       ar = &ref->u.ar;
-
-      if (ar->as->rank == 0)
-       {
-         /* Scalar coarray.  */
-         continue;
-       }
-
       switch (ar->type)
        {
        case AR_ELEMENT:
index b9ea557..7e95ce1 100644 (file)
@@ -2386,7 +2386,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
 
   if (intent != INTENT_OUT)
     {
-      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
+      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
       gfc_add_expr_to_block (&body, tmp);
       gcc_assert (rse.ss == gfc_ss_terminator);
       gfc_trans_scalarizing_loops (&loop, &body);
@@ -2484,7 +2484,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
 
   gcc_assert (lse.ss == gfc_ss_terminator);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
   gfc_add_expr_to_block (&body, tmp);
   
   /* Generate the copying loops.  */
@@ -4111,7 +4111,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 
   gfc_conv_expr (&rse, expr);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
+  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
   gfc_add_expr_to_block (&body, tmp);
 
   gcc_assert (rse.ss == gfc_ss_terminator);
@@ -4369,7 +4369,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
       if (cm->ts.type == BT_CHARACTER)
        lse.string_length = cm->ts.u.cl->backend_decl;
       lse.expr = dest;
-      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
+      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
       gfc_add_expr_to_block (&block, tmp);
     }
   return gfc_finish_block (&block);
@@ -4897,11 +4897,12 @@ gfc_conv_string_parameter (gfc_se * se)
 
 
 /* Generate code for assignment of scalar variables.  Includes character
-   strings and derived types with allocatable components.  */
+   strings and derived types with allocatable components.
+   If you know that the LHS has no allocations, set dealloc to false.  */
 
 tree
 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
-                        bool l_is_temp, bool r_is_var)
+                        bool l_is_temp, bool r_is_var, bool dealloc)
 {
   stmtblock_t block;
   tree tmp;
@@ -4949,7 +4950,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
         the same as the rhs.  This must be done following the assignment
         to prevent deallocating data that could be used in the rhs
         expression.  */
-      if (!l_is_temp)
+      if (!l_is_temp && dealloc)
        {
          tmp = gfc_evaluate_now (lse->expr, &lse->pre);
          tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
@@ -5279,10 +5280,13 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
 
 
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
-   assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.  */
+   assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
+   init_flag indicates initialization expressions and dealloc that no
+   deallocate prior assignment is needed (if in doubt, set true).  */
 
 static tree
-gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+                       bool dealloc)
 {
   gfc_se lse;
   gfc_se rse;
@@ -5399,7 +5403,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
                       && expr2->expr_type != EXPR_VARIABLE
                       && !gfc_is_constant_expr (expr2)
                       && expr1->rank && !expr2->rank);
-  if (scalar_to_array)
+  if (scalar_to_array && dealloc)
     {
       tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
       gfc_add_expr_to_block (&loop.post, tmp);
@@ -5408,7 +5412,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
                                 l_is_temp || init_flag,
                                 (expr2->expr_type == EXPR_VARIABLE)
-                                   || scalar_to_array);
+                                   || scalar_to_array, dealloc);
   gfc_add_expr_to_block (&body, tmp);
 
   if (lss == gfc_ss_terminator)
@@ -5445,7 +5449,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
            rse.string_length = string_length;
 
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
-                                        false, false);
+                                        false, false, dealloc);
          gfc_add_expr_to_block (&body, tmp);
        }
 
@@ -5503,7 +5507,8 @@ copyable_array_p (gfc_expr * expr)
 /* Translate an assignment.  */
 
 tree
-gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+                     bool dealloc)
 {
   tree tmp;
 
@@ -5546,19 +5551,19 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
     }
 
   /* Fallback to the scalarizer to generate explicit loops.  */
-  return gfc_trans_assignment_1 (expr1, expr2, init_flag);
+  return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
 }
 
 tree
 gfc_trans_init_assign (gfc_code * code)
 {
-  return gfc_trans_assignment (code->expr1, code->expr2, true);
+  return gfc_trans_assignment (code->expr1, code->expr2, true, false);
 }
 
 tree
 gfc_trans_assign (gfc_code * code)
 {
-  return gfc_trans_assignment (code->expr1, code->expr2, false);
+  return gfc_trans_assignment (code->expr1, code->expr2, false, true);
 }
 
 
index 31e53ed..e6fc3c0 100644 (file)
@@ -1,3 +1,10 @@
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/43178
+       * gfortran.dg/alloc_comp_basics_1.f90: Update scan-tree-dump-times.
+       * gfortran.dg/alloc_comp_constructor_1.f90: Ditto.
+       * gfortran.dg/auto_dealloc_1.f90: Ditto.
+
 2010-04-06  Richard Guenther  <rguenther@suse.de>
 
        PR tree-optimization/43627