trans-array.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

  gfc_trans_scalarizing_loops (&loop, &body);
  gfc_add_block_to_block (&loop.pre, &loop.post);
  tmp = gfc_finish_block (&loop.pre);
  gfc_add_expr_to_block (pblock, tmp);

  gfc_cleanup_loop (&loop);
}


/* Assign the values to the elements of an array constructor.  DYNAMIC
   is true if descriptor DESC only contains enough data for the static
   size calculated by gfc_get_array_constructor_size.  When true, memory
   for the dynamic parts must be allocated using realloc.  */

static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
				   tree desc, gfc_constructor * c,
				   tree * poffset, tree * offsetvar,
				   bool dynamic)
{
  tree tmp;
  stmtblock_t body;
  gfc_se se;
  mpz_t size;

  mpz_init (size);
  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))
	gfc_put_offset_into_var (pblock, poffset, offsetvar);

      gfc_start_block (&body);

      if (c->expr->expr_type == EXPR_ARRAY)
	{
	  /* Array constructors can be nested.  */
	  gfc_trans_array_constructor_value (&body, type, desc,
					     c->expr->value.constructor,
					     poffset, offsetvar, dynamic);
	}
      else if (c->expr->rank > 0)
	{
	  gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
						poffset, offsetvar, dynamic);
	}
      else
	{
	  /* This code really upsets the gimplifier so don't bother for now.  */
	  gfc_constructor *p;
	  HOST_WIDE_INT n;
	  HOST_WIDE_INT size;

	  p = c;
	  n = 0;
	  while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
	    {
	      p = p->next;
	      n++;
	    }
	  if (n < 4)
	    {
	      /* Scalar values.  */
	      gfc_init_se (&se, NULL);
	      gfc_trans_array_ctor_element (&body, desc, *poffset,
					    &se, c->expr);

	      *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
				      *poffset, gfc_index_one_node);
	    }
	  else
	    {
	      /* Collect multiple scalar constants into a constructor.  */
	      tree list;
	      tree init;
	      tree bound;
	      tree tmptype;

	      p = c;
	      list = NULL_TREE;
              /* Count the number of consecutive scalar constants.  */
	      while (p && !(p->iterator
			    || p->expr->expr_type != EXPR_CONSTANT))
		{
		  gfc_init_se (&se, NULL);
		  gfc_conv_constant (&se, p->expr);
		  if (p->expr->ts.type == BT_CHARACTER
		      && POINTER_TYPE_P (type))
		    {
		      /* For constant character array constructors we build
			 an array of pointers.  */
		      se.expr = gfc_build_addr_expr (pchar_type_node,
						     se.expr);
		    }
		    
		  list = tree_cons (NULL_TREE, se.expr, list);
		  c = p;
		  p = p->next;
		}

	      bound = build_int_cst (NULL_TREE, n - 1);
              /* Create an array type to hold them.  */
	      tmptype = build_range_type (gfc_array_index_type,
					  gfc_index_zero_node, bound);
	      tmptype = build_array_type (type, tmptype);

	      init = build_constructor_from_list (tmptype, nreverse (list));
	      TREE_CONSTANT (init) = 1;
	      TREE_INVARIANT (init) = 1;
	      TREE_STATIC (init) = 1;
	      /* Create a static variable to hold the data.  */
	      tmp = gfc_create_var (tmptype, "data");
	      TREE_STATIC (tmp) = 1;
	      TREE_CONSTANT (tmp) = 1;
	      TREE_INVARIANT (tmp) = 1;
	      DECL_INITIAL (tmp) = init;
	      init = tmp;

	      /* Use BUILTIN_MEMCPY to assign the values.  */
	      tmp = gfc_conv_descriptor_data_get (desc);
	      tmp = gfc_build_indirect_ref (tmp);
	      tmp = gfc_build_array_ref (tmp, *poffset);
	      tmp = gfc_build_addr_expr (NULL, tmp);
	      init = gfc_build_addr_expr (NULL, init);

	      size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
	      bound = build_int_cst (NULL_TREE, n * size);
	      tmp = gfc_chainon_list (NULL_TREE, tmp);
	      tmp = gfc_chainon_list (tmp, init);
	      tmp = gfc_chainon_list (tmp, bound);
	      tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
					     tmp);
	      gfc_add_expr_to_block (&body, tmp);

	      *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
				      *poffset, build_int_cst (NULL_TREE, n));
	    }
	  if (!INTEGER_CST_P (*poffset))
            {
              gfc_add_modify_expr (&body, *offsetvar, *poffset);
              *poffset = *offsetvar;
            }
	}

      /* The frontend should already have done any expansions possible
	 at compile-time.  */
      if (!c->iterator)
	{
	  /* Pass the code as is.  */
	  tmp = gfc_finish_block (&body);
	  gfc_add_expr_to_block (pblock, tmp);
	}
      else
	{
	  /* Build the implied do-loop.  */
	  tree cond;
	  tree end;
	  tree step;
	  tree loopvar;
	  tree exit_label;
	  tree loopbody;
	  tree tmp2;

	  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;

	  /* Initialize the loop.  */
	  gfc_init_se (&se, NULL);
	  gfc_conv_expr_val (&se, c->iterator->start);
	  gfc_add_block_to_block (pblock, &se.pre);
	  gfc_add_modify_expr (pblock, loopvar, se.expr);

	  gfc_init_se (&se, NULL);
	  gfc_conv_expr_val (&se, c->iterator->end);
	  gfc_add_block_to_block (pblock, &se.pre);
	  end = gfc_evaluate_now (se.expr, pblock);

	  gfc_init_se (&se, NULL);
	  gfc_conv_expr_val (&se, c->iterator->step);
	  gfc_add_block_to_block (pblock, &se.pre);
	  step = gfc_evaluate_now (se.expr, pblock);

	  /* If this array expands dynamically, and the number of iterations
	     is not constant, we won't have allocated space for the static
	     part of C->EXPR's size.  Do that now.  */
	  if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
	    {
	      /* Get the number of iterations.  */
	      tmp = gfc_get_iteration_count (loopvar, end, step);

	      /* Get the static part of C->EXPR's size.  */
	      gfc_get_array_constructor_element_size (&size, c->expr);
	      tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);

	      /* Grow the array by TMP * TMP2 elements.  */
	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
	      gfc_grow_array (pblock, desc, tmp);
	    }

	  /* Generate the loop body.  */
	  exit_label = gfc_build_label_decl (NULL_TREE);
	  gfc_start_block (&body);

	  /* Generate the exit condition.  Depending on the sign of
	     the step variable we have to generate the correct
	     comparison.  */
	  tmp = fold_build2 (GT_EXPR, boolean_type_node, step, 
			     build_int_cst (TREE_TYPE (step), 0));
	  cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
			      build2 (GT_EXPR, boolean_type_node,
				      loopvar, end),
			      build2 (LT_EXPR, boolean_type_node,
				      loopvar, end));
	  tmp = build1_v (GOTO_EXPR, exit_label);
	  TREE_USED (exit_label) = 1;
	  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
	  gfc_add_expr_to_block (&body, tmp);

	  /* The main loop body.  */
	  gfc_add_expr_to_block (&body, loopbody);

	  /* Increase loop variable by step.  */
	  tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
	  gfc_add_modify_expr (&body, loopvar, tmp);

	  /* Finish the loop.  */
	  tmp = gfc_finish_block (&body);
	  tmp = build1_v (LOOP_EXPR, tmp);
	  gfc_add_expr_to_block (pblock, tmp);

	  /* Add the exit label.  */
	  tmp = build1_v (LABEL_EXPR, exit_label);
	  gfc_add_expr_to_block (pblock, tmp);
	}
    }
  mpz_clear (size);
}


/* Figure out the string length of a variable reference expression.
   Used by get_array_ctor_strlen.  */

static void
get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
{
  gfc_ref *ref;
  gfc_typespec *ts;

  /* Don't bother if we already know the length is a constant.  */
  if (*len && INTEGER_CST_P (*len))
    return;

  ts = &expr->symtree->n.sym->ts;
  for (ref = expr->ref; ref; ref = ref->next)
    {
      switch (ref->type)
	{
	case REF_ARRAY:
	  /* Array references don't change the string length.  */
	  break;

	case COMPONENT_REF:
	  /* Use the length of the component.  */
	  ts = &ref->u.c.component->ts;
	  break;

	default:
	  /* TODO: Substrings are tricky because we can't evaluate the
	     expression more than once.  For now we just give up, and hope
	     we can figure it out elsewhere.  */
	  return;
	}
    }

  *len = ts->cl->backend_decl;
}


/* Figure out the string length of a character array constructor.
   Returns TRUE if all elements are character constants.  */

static bool
get_array_ctor_strlen (gfc_constructor * c, tree * len)
{
  bool is_const;
  
  is_const = TRUE;
  for (; c; c = c->next)
    {
      switch (c->expr->expr_type)
	{
	case EXPR_CONSTANT:
	  if (!(*len && INTEGER_CST_P (*len)))
	    *len = build_int_cstu (gfc_charlen_type_node,
				   c->expr->value.character.length);
	  break;

	case EXPR_ARRAY:
	  if (!get_array_ctor_strlen (c->expr->value.constructor, len))
	    is_const = FALSE;
	  break;

	case EXPR_VARIABLE:
	  is_const = false;
	  get_array_ctor_var_strlen (c->expr, len);
	  break;

	default:
	  is_const = FALSE;
	  /* TODO: For now we just ignore anything we don't know how to
	     handle, and hope we can figure it out a different way.  */
	  break;
	}
    }

  return is_const;
}


/* Array constructors are handled by constructing a temporary, then using that
   within the scalarization loop.  This is not optimal, but seems by far the
   simplest method.  */

static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
{
  gfc_constructor *c;
  tree offset;
  tree offsetvar;
  tree desc;
  tree type;
  bool const_string;
  bool dynamic;

  ss->data.info.dimen = loop->dimen;

  c = ss->expr->value.constructor;
  if (ss->expr->ts.type == BT_CHARACTER)
    {
      const_string = get_array_ctor_strlen (c, &ss->string_length);
      if (!ss->string_length)
	gfc_todo_error ("complex character array constructors");

      type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
      if (const_string)
	type = build_pointer_type (type);
    }
  else
    {
      const_string = TRUE;
      type = gfc_typenode_for_spec (&ss->expr->ts);
    }

  /* See if the constructor determines the loop bounds.  */
  dynamic = false;
  if (loop->to[0] == NULL_TREE)
    {
      mpz_t size;

      /* We should have a 1-dimensional, zero-based loop.  */
      gcc_assert (loop->dimen == 1);
      gcc_assert (integer_zerop (loop->from[0]));

      /* Split the constructor size into a static part and a dynamic part.
	 Allocate the static size up-front and record whether the dynamic
	 size might be nonzero.  */
      mpz_init (size);
      dynamic = gfc_get_array_constructor_size (&size, c);
      mpz_sub_ui (size, size, 1);
      loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
      mpz_clear (size);
    }

  gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
                                 &ss->data.info, type, dynamic, true);

  desc = ss->data.info.descriptor;
  offset = gfc_index_zero_node;
  offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
  TREE_USED (offsetvar) = 0;
  gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
				     &offset, &offsetvar, dynamic);

  /* If the array grows dynamically, the upper bound of the loop variable
     is determined by the array's final upper bound.  */
  if (dynamic)
    loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);

  if (TREE_USED (offsetvar))
    pushdecl (offsetvar);
  else
    gcc_assert (INTEGER_CST_P (offset));
#if 0
  /* Disable bound checking for now because it's probably broken.  */
  if (flag_bounds_check)
    {
      gcc_unreachable ();
    }
#endif
}


/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
   called after evaluating all of INFO's vector dimensions.  Go through
   each such vector dimension and see if we can now fill in any missing
   loop bounds.  */

static void
gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
{
  gfc_se se;
  tree tmp;
  tree desc;
  tree zero;
  int n;
  int dim;

  for (n = 0; n < loop->dimen; n++)
    {
      dim = info->dim[n];
      if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
	  && loop->to[n] == NULL)
	{
	  /* Loop variable N indexes vector dimension DIM, and we don't
	     yet know the upper bound of loop variable N.  Set it to the
	     difference between the vector's upper and lower bounds.  */
	  gcc_assert (loop->from[n] == gfc_index_zero_node);
	  gcc_assert (info->subscript[dim]
		      && info->subscript[dim]->type == GFC_SS_VECTOR);

	  gfc_init_se (&se, NULL);
	  desc = info->subscript[dim]->data.info.descriptor;
	  zero = gfc_rank_cst[0];
	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
			     gfc_conv_descriptor_ubound (desc, zero),
			     gfc_conv_descriptor_lbound (desc, zero));
	  tmp = gfc_evaluate_now (tmp, &loop->pre);
	  loop->to[n] = tmp;
	}
    }
}


/* Add the pre and post chains for all the scalar expressions in a SS chain
   to loop.  This is called after the loop parameters have been calculated,
   but before the actual scalarizing loops.  */

static void
gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
{
  gfc_se se;
  int n;

  /* TODO: This can generate bad code if there are ordering dependencies.
     eg. a callee allocated function and an unknown size constructor.  */
  gcc_assert (ss != NULL);

  for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
    {
      gcc_assert (ss);

      switch (ss->type)
	{
	case GFC_SS_SCALAR:
	  /* Scalar expression.  Evaluate this now.  This includes elemental
	     dimension indices, but not array section bounds.  */
	  gfc_init_se (&se, NULL);
          gfc_conv_expr (&se, ss->expr);
          gfc_add_block_to_block (&loop->pre, &se.pre);

          if (ss->expr->ts.type != BT_CHARACTER)
            {