array.c

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

	    return FAILURE;

	  continue;
	}

      e = gfc_copy_expr (e);
      if (gfc_simplify_expr (e, 1) == FAILURE)
	{
	  gfc_free_expr (e);
	  return FAILURE;
	}
      current_expand.offset = &c->n.offset;
      current_expand.component = c->n.component;
      current_expand.repeat = &c->repeat;
      if (current_expand.expand_work_function (e) == FAILURE)
	return FAILURE;
    }
  return SUCCESS;
}


/* Top level subroutine for expanding constructors.  We only expand
   constructor if they are small enough.  */

try
gfc_expand_constructor (gfc_expr * e)
{
  expand_info expand_save;
  gfc_expr *f;
  try rc;

  f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
  if (f != NULL)
    {
      gfc_free_expr (f);
      return SUCCESS;
    }

  expand_save = current_expand;
  current_expand.new_head = current_expand.new_tail = NULL;

  iter_stack = NULL;

  current_expand.expand_work_function = expand;

  if (expand_constructor (e->value.constructor) == FAILURE)
    {
      gfc_free_constructor (current_expand.new_head);
      rc = FAILURE;
      goto done;
    }

  gfc_free_constructor (e->value.constructor);
  e->value.constructor = current_expand.new_head;

  rc = SUCCESS;

done:
  current_expand = expand_save;

  return rc;
}


/* Work function for checking that an element of a constructor is a
   constant, after removal of any iteration variables.  We return
   FAILURE if not so.  */

static try
constant_element (gfc_expr * e)
{
  int rv;

  rv = gfc_is_constant_expr (e);
  gfc_free_expr (e);

  return rv ? SUCCESS : FAILURE;
}


/* Given an array constructor, determine if the constructor is
   constant or not by expanding it and making sure that all elements
   are constants.  This is a bit of a hack since something like (/ (i,
   i=1,100000000) /) will take a while as* opposed to a more clever
   function that traverses the expression tree. FIXME.  */

int
gfc_constant_ac (gfc_expr * e)
{
  expand_info expand_save;
  try rc;

  iter_stack = NULL;
  expand_save = current_expand;
  current_expand.expand_work_function = constant_element;

  rc = expand_constructor (e->value.constructor);

  current_expand = expand_save;
  if (rc == FAILURE)
    return 0;

  return 1;
}


/* Returns nonzero if an array constructor has been completely
   expanded (no iterators) and zero if iterators are present.  */

int
gfc_expanded_ac (gfc_expr * e)
{
  gfc_constructor *p;

  if (e->expr_type == EXPR_ARRAY)
    for (p = e->value.constructor; p; p = p->next)
      if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
	return 0;

  return 1;
}


/*************** Type resolution of array constructors ***************/

/* Recursive array list resolution function.  All of the elements must
   be of the same type.  */

static try
resolve_array_list (gfc_constructor * p)
{
  try t;

  t = SUCCESS;

  for (; p; p = p->next)
    {
      if (p->iterator != NULL
	  && gfc_resolve_iterator (p->iterator, false) == FAILURE)
	t = FAILURE;

      if (gfc_resolve_expr (p->expr) == FAILURE)
	t = FAILURE;
    }

  return t;
}

/* Resolve character array constructor. If it is a constant character array and
   not specified character length, update character length to the maximum of
   its element constructors' length.  */

static void
resolve_character_array_constructor (gfc_expr * expr)
{
  gfc_constructor * p;
  int max_length;

  gcc_assert (expr->expr_type == EXPR_ARRAY);
  gcc_assert (expr->ts.type == BT_CHARACTER);

  max_length = -1;

  if (expr->ts.cl == NULL)
    {
      expr->ts.cl = gfc_get_charlen ();
      expr->ts.cl->next = gfc_current_ns->cl_list;
      gfc_current_ns->cl_list = expr->ts.cl;
    }

  if (expr->ts.cl->length == NULL)
    {
      /* Find the maximum length of the elements. Do nothing for variable array
	 constructor.  */
      for (p = expr->value.constructor; p; p = p->next)
	if (p->expr->expr_type == EXPR_CONSTANT)
	  max_length = MAX (p->expr->value.character.length, max_length);
	else
	  return;

      if (max_length != -1)
	{
	  /* Update the character length of the array constructor.  */
	  expr->ts.cl->length = gfc_int_expr (max_length);
	  /* Update the element constructors.  */
	  for (p = expr->value.constructor; p; p = p->next)
	    gfc_set_constant_character_len (max_length, p->expr);
	}
    }
}

/* Resolve all of the expressions in an array list.  */

try
gfc_resolve_array_constructor (gfc_expr * expr)
{
  try t;

  t = resolve_array_list (expr->value.constructor);
  if (t == SUCCESS)
    t = gfc_check_constructor_type (expr);
  if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
    resolve_character_array_constructor (expr);

  return t;
}


/* Copy an iterator structure.  */

static gfc_iterator *
copy_iterator (gfc_iterator * src)
{
  gfc_iterator *dest;

  if (src == NULL)
    return NULL;

  dest = gfc_get_iterator ();

  dest->var = gfc_copy_expr (src->var);
  dest->start = gfc_copy_expr (src->start);
  dest->end = gfc_copy_expr (src->end);
  dest->step = gfc_copy_expr (src->step);

  return dest;
}


/* Copy a constructor structure.  */

gfc_constructor *
gfc_copy_constructor (gfc_constructor * src)
{
  gfc_constructor *dest;
  gfc_constructor *tail;

  if (src == NULL)
    return NULL;

  dest = tail = NULL;
  while (src)
    {
      if (dest == NULL)
	dest = tail = gfc_get_constructor ();
      else
	{
	  tail->next = gfc_get_constructor ();
	  tail = tail->next;
	}
      tail->where = src->where;
      tail->expr = gfc_copy_expr (src->expr);
      tail->iterator = copy_iterator (src->iterator);
      mpz_set (tail->n.offset, src->n.offset);
      tail->n.component = src->n.component;
      mpz_set (tail->repeat, src->repeat);
      src = src->next;
    }

  return dest;
}


/* Given an array expression and an element number (starting at zero),
   return a pointer to the array element.  NULL is returned if the
   size of the array has been exceeded.  The expression node returned
   remains a part of the array and should not be freed.  Access is not
   efficient at all, but this is another place where things do not
   have to be particularly fast.  */

gfc_expr *
gfc_get_array_element (gfc_expr * array, int element)
{
  expand_info expand_save;
  gfc_expr *e;
  try rc;

  expand_save = current_expand;
  current_expand.extract_n = element;
  current_expand.expand_work_function = extract_element;
  current_expand.extracted = NULL;
  current_expand.extract_count = 0;

  iter_stack = NULL;

  rc = expand_constructor (array->value.constructor);
  e = current_expand.extracted;
  current_expand = expand_save;

  if (rc == FAILURE)
    return NULL;

  return e;
}


/********* Subroutines for determining the size of an array *********/

/* These are needed just to accommodate RESHAPE().  There are no
   diagnostics here, we just return a negative number if something
   goes wrong.  */


/* Get the size of single dimension of an array specification.  The
   array is guaranteed to be one dimensional.  */

static try
spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
{

  if (as == NULL)
    return FAILURE;

  if (dimen < 0 || dimen > as->rank - 1)
    gfc_internal_error ("spec_dimen_size(): Bad dimension");

  if (as->type != AS_EXPLICIT
      || as->lower[dimen]->expr_type != EXPR_CONSTANT
      || as->upper[dimen]->expr_type != EXPR_CONSTANT)
    return FAILURE;

  mpz_init (*result);

  mpz_sub (*result, as->upper[dimen]->value.integer,
	   as->lower[dimen]->value.integer);

  mpz_add_ui (*result, *result, 1);

  return SUCCESS;
}


try
spec_size (gfc_array_spec * as, mpz_t * result)
{
  mpz_t size;
  int d;

  mpz_init_set_ui (*result, 1);

  for (d = 0; d < as->rank; d++)
    {
      if (spec_dimen_size (as, d, &size) == FAILURE)
	{
	  mpz_clear (*result);
	  return FAILURE;
	}

      mpz_mul (*result, *result, size);
      mpz_clear (size);
    }

  return SUCCESS;
}


/* Get the number of elements in an array section.  */

static try
ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result)
{
  mpz_t upper, lower, stride;
  try t;

  if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
    gfc_internal_error ("ref_dimen_size(): Bad dimension");

  switch (ar->dimen_type[dimen])
    {
    case DIMEN_ELEMENT:
      mpz_init (*result);
      mpz_set_ui (*result, 1);
      t = SUCCESS;
      break;

    case DIMEN_VECTOR:
      t = gfc_array_size (ar->start[dimen], result);	/* Recurse! */
      break;

    case DIMEN_RANGE:
      mpz_init (upper);
      mpz_init (lower);
      mpz_init (stride);
      t = FAILURE;

      if (ar->start[dimen] == NULL)
	{
	  if (ar->as->lower[dimen] == NULL
	      || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
	    goto cleanup;
	  mpz_set (lower, ar->as->lower[dimen]->value.integer);
	}
      else
	{
	  if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
	    goto cleanup;
	  mpz_set (lower, ar->start[dimen]->value.integer);
	}

      if (ar->end[dimen] == NULL)
	{
	  if (ar->as->upper[dimen] == NULL
	      || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
	    goto cleanup;
	  mpz_set (upper, ar->as->upper[dimen]->value.integer);
	}
      else
	{
	  if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
	    goto cleanup;
	  mpz_set (upper, ar->end[dimen]->value.integer);
	}

      if (ar->stride[dimen] == NULL)
	mpz_set_ui (stride, 1);
      else
	{
	  if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
	    goto cleanup;
	  mpz_set (stride, ar->stride[dimen]->value.integer);
	}

      mpz_init (*result);
      mpz_sub (*result, upper, lower);
      mpz_add (*result, *result, stride);
      mpz_div (*result, *result, stride);

      /* Zero stride caught earlier.  */
      if (mpz_cmp_ui (*result, 0) < 0)
	mpz_set_ui (*result, 0);
      t = SUCCESS;

    cleanup:
      mpz_clear (upper);
      mpz_clear (lower);
      mpz_clear (stride);
      return t;

    default:
      gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
    }

  return t;
}


static try
ref_size (gfc_array_ref * ar, mpz_t * result)
{
  mpz_t size;
  int d;

  mpz_init_set_ui (*result, 1);

  for (d = 0; d < ar->dimen; d++)
    {
      if (ref_dimen_size (ar, d, &size) == FAILURE)
	{
	  mpz_clear (*result);
	  return FAILURE;
	}

      mpz_mul (*result, *result, size);
      mpz_clear (size);
    }

  return SUCCESS;
}


/* Given an array expression and a dimension, figure out how many
   elements it has along that dimension.  Returns SUCCESS if we were
   able to return a result in the 'result' variable, FAILURE
   otherwise.  */

try
gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
{
  gfc_ref *ref;
  int i;

  if (dimen < 0 || array == NULL || dimen > array->rank - 1)
    gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");

  switch (array->expr_type)
    {
    case EXPR_VARIABLE:
    case EXPR_FUNCTION:
      for (ref = array->ref; ref; ref = ref->next)
	{
	  if (ref->type != REF_ARRAY)
	    continue;

	  if (ref->u.ar.type == AR_FULL)
	    return spec_dimen_size (ref->u.ar.as, dimen, result);

	  if (ref->u.ar.type == AR_SECTION)
	    {
	      for (i = 0; dimen >= 0; i++)
		if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
		  dimen--;

	      return ref_dimen_size (&ref->u.ar, i - 1, result);
	    }
	}

      if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
	return FAILURE;

      break;

    case EXPR_ARRAY:
      if (array->shape == NULL) {
	/* Expressions with rank > 1 should have "shape" properly set */
	if ( array->rank != 1 )
	  gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
	return gfc_array_size(array, result);
      }

      /* Fall through */
    default:
      if (array->shape == NULL)
	return FAILURE;

      mpz_init_set (*result, array->shape[dimen]);

      break;
    }

  return SUCCESS;
}


/* Given an array expression, figure out how many elements are in the
   array.  Returns SUCCESS if this is possible, and sets the 'result'
   variable.  Otherwise returns FAILURE.  */

try
gfc_array_size (gfc_expr * array, mpz_t * result)
{
  expand_info expand_save;
  gfc_ref *ref;
  int i, flag;
  try t;

  switch (array->expr_type)
    {
    case EXPR_ARRAY:
      flag = gfc_suppress_error;
      gfc_suppress_error = 1;

      expand_save = current_expand;

      current_expand.count = result;
      mpz_init_set_ui (*result, 0);

      current_expand.expand_work_function = count_elements;
      iter_stack = NULL;

      t = expand_constructor (array->value.constructor);
      gfc_suppress_error = flag;

      if (t == FAILURE)
	mpz_clear (*result);
      current_expand = expand_save;
      return t;

    case EXPR_VARIABLE:
      for (ref = array->ref; ref; ref = ref->next)
	{
	  if (ref->type != REF_ARRAY)
	    continue;

	  if (ref->u.ar.type == AR_FULL)
	    return spec_size (ref->u.ar.as, result);

	  if (ref->u.ar.type == AR_SECTION)
	    return ref_size (&ref->u.ar, result);
	}

      return spec_size (array->symtree->n.sym->as, result);


    default:
      if (array->rank == 0 || array->shape == NULL)
	return FAILURE;

      mpz_init_set_ui (*result, 1);

      for (i = 0; i < array->rank; i++)
	mpz_mul (*result, *result, array->shape[i]);

      break;
    }

  return SUCCESS;
}


/* Given an array reference, return the shape of the reference in an
   array of mpz_t integers.  */

try
gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape)
{
  int d;
  int i;

  d = 0;

  switch (ar->type)
    {
    case AR_FULL:
      for (; d < ar->as->rank; d++)
	if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
	  goto cleanup;

      return SUCCESS;

    case AR_SECTION:
      for (i = 0; i < ar->dimen; i++)
	{
	  if (ar->dimen_type[i] != DIMEN_ELEMENT)
	    {
	      if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
		goto cleanup;
	      d++;
	    }
	}

      return SUCCESS;

    default:
      break;
    }

cleanup:
  for (d--; d >= 0; d--)
    mpz_clear (shape[d]);

  return FAILURE;
}


/* Given an array expression, find the array reference structure that
   characterizes the reference.  */

gfc_array_ref *
gfc_find_array_ref (gfc_expr * e)
{
  gfc_ref *ref;

  for (ref = e->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY
	&& (ref->u.ar.type == AR_FULL
	    || ref->u.ar.type == AR_SECTION))
      break;

  if (ref == NULL)
    gfc_internal_error ("gfc_find_array_ref(): No ref found");

  return &ref->u.ar;
}


/* Find out if an array shape is known at compile time.  */

int
gfc_is_compile_time_shape (gfc_array_spec *as)
{
  int i;

  if (as->type != AS_EXPLICIT)
    return 0;

  for (i = 0; i < as->rank; i++)
    if (!gfc_is_constant_expr (as->lower[i])
	|| !gfc_is_constant_expr (as->upper[i]))
      return 0;

  return 1;
}