array.c

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

      if (p->expr)
        gfc_free_expr (p->expr);
      if (p->iterator != NULL)
	gfc_free_iterator (p->iterator, 1);
      mpz_clear (p->n.offset);
      mpz_clear (p->repeat);
      gfc_free (p);
    }
}


/* Given an expression node that might be an array constructor and a
   symbol, make sure that no iterators in this or child constructors
   use the symbol as an implied-DO iterator.  Returns nonzero if a
   duplicate was found.  */

static int
check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master)
{
  gfc_expr *e;

  for (; c; c = c->next)
    {
      e = c->expr;

      if (e->expr_type == EXPR_ARRAY
	  && check_duplicate_iterator (e->value.constructor, master))
	return 1;

      if (c->iterator == NULL)
	continue;

      if (c->iterator->var->symtree->n.sym == master)
	{
	  gfc_error
	    ("DO-iterator '%s' at %L is inside iterator of the same name",
	     master->name, &c->where);

	  return 1;
	}
    }

  return 0;
}


/* Forward declaration because these functions are mutually recursive.  */
static match match_array_cons_element (gfc_constructor **);

/* Match a list of array elements.  */

static match
match_array_list (gfc_constructor ** result)
{
  gfc_constructor *p, *head, *tail, *new;
  gfc_iterator iter;
  locus old_loc;
  gfc_expr *e;
  match m;
  int n;

  old_loc = gfc_current_locus;

  if (gfc_match_char ('(') == MATCH_NO)
    return MATCH_NO;

  memset (&iter, '\0', sizeof (gfc_iterator));
  head = NULL;

  m = match_array_cons_element (&head);
  if (m != MATCH_YES)
    goto cleanup;

  tail = head;

  if (gfc_match_char (',') != MATCH_YES)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  for (n = 1;; n++)
    {
      m = gfc_match_iterator (&iter, 0);
      if (m == MATCH_YES)
	break;
      if (m == MATCH_ERROR)
	goto cleanup;

      m = match_array_cons_element (&new);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	{
	  if (n > 2)
	    goto syntax;
	  m = MATCH_NO;
	  goto cleanup;		/* Could be a complex constant */
	}

      tail->next = new;
      tail = new;

      if (gfc_match_char (',') != MATCH_YES)
	{
	  if (n > 2)
	    goto syntax;
	  m = MATCH_NO;
	  goto cleanup;
	}
    }

  if (gfc_match_char (')') != MATCH_YES)
    goto syntax;

  if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
    {
      m = MATCH_ERROR;
      goto cleanup;
    }

  e = gfc_get_expr ();
  e->expr_type = EXPR_ARRAY;
  e->where = old_loc;
  e->value.constructor = head;

  p = gfc_get_constructor ();
  p->where = gfc_current_locus;
  p->iterator = gfc_get_iterator ();
  *p->iterator = iter;

  p->expr = e;
  *result = p;

  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in array constructor at %C");
  m = MATCH_ERROR;

cleanup:
  gfc_free_constructor (head);
  gfc_free_iterator (&iter, 0);
  gfc_current_locus = old_loc;
  return m;
}


/* Match a single element of an array constructor, which can be a
   single expression or a list of elements.  */

static match
match_array_cons_element (gfc_constructor ** result)
{
  gfc_constructor *p;
  gfc_expr *expr;
  match m;

  m = match_array_list (result);
  if (m != MATCH_NO)
    return m;

  m = gfc_match_expr (&expr);
  if (m != MATCH_YES)
    return m;

  p = gfc_get_constructor ();
  p->where = gfc_current_locus;
  p->expr = expr;

  *result = p;
  return MATCH_YES;
}


/* Match an array constructor.  */

match
gfc_match_array_constructor (gfc_expr ** result)
{
  gfc_constructor *head, *tail, *new;
  gfc_expr *expr;
  locus where;
  match m;
  const char *end_delim;

  if (gfc_match (" (/") == MATCH_NO)
    {
      if (gfc_match (" [") == MATCH_NO)
        return MATCH_NO;
      else
        {
          if (gfc_notify_std (GFC_STD_F2003, "New in Fortran 2003: [...] "
                              "style array constructors at %C") == FAILURE)
            return MATCH_ERROR;
          end_delim = " ]";
        }
    }
  else
    end_delim = " /)";

  where = gfc_current_locus;
  head = tail = NULL;

  if (gfc_match (end_delim) == MATCH_YES)
    {
      gfc_error ("Empty array constructor at %C is not allowed");
      goto cleanup;
    }

  for (;;)
    {
      m = match_array_cons_element (&new);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;

      if (head == NULL)
	head = new;
      else
	tail->next = new;

      tail = new;

      if (gfc_match_char (',') == MATCH_NO)
	break;
    }

  if (gfc_match (end_delim) == MATCH_NO)
    goto syntax;

  expr = gfc_get_expr ();

  expr->expr_type = EXPR_ARRAY;

  expr->value.constructor = head;
  /* Size must be calculated at resolution time.  */

  expr->where = where;
  expr->rank = 1;

  *result = expr;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in array constructor at %C");

cleanup:
  gfc_free_constructor (head);
  return MATCH_ERROR;
}



/************** Check array constructors for correctness **************/

/* Given an expression, compare it's type with the type of the current
   constructor.  Returns nonzero if an error was issued.  The
   cons_state variable keeps track of whether the type of the
   constructor being read or resolved is known to be good, bad or just
   starting out.  */

static gfc_typespec constructor_ts;
static enum
{ CONS_START, CONS_GOOD, CONS_BAD }
cons_state;

static int
check_element_type (gfc_expr * expr)
{

  if (cons_state == CONS_BAD)
    return 0;			/* Suppress further errors */

  if (cons_state == CONS_START)
    {
      if (expr->ts.type == BT_UNKNOWN)
	cons_state = CONS_BAD;
      else
	{
	  cons_state = CONS_GOOD;
	  constructor_ts = expr->ts;
	}

      return 0;
    }

  if (gfc_compare_types (&constructor_ts, &expr->ts))
    return 0;

  gfc_error ("Element in %s array constructor at %L is %s",
	     gfc_typename (&constructor_ts), &expr->where,
	     gfc_typename (&expr->ts));

  cons_state = CONS_BAD;
  return 1;
}


/* Recursive work function for gfc_check_constructor_type().  */

static try
check_constructor_type (gfc_constructor * c)
{
  gfc_expr *e;

  for (; c; c = c->next)
    {
      e = c->expr;

      if (e->expr_type == EXPR_ARRAY)
	{
	  if (check_constructor_type (e->value.constructor) == FAILURE)
	    return FAILURE;

	  continue;
	}

      if (check_element_type (e))
	return FAILURE;
    }

  return SUCCESS;
}


/* Check that all elements of an array constructor are the same type.
   On FAILURE, an error has been generated.  */

try
gfc_check_constructor_type (gfc_expr * e)
{
  try t;

  cons_state = CONS_START;
  gfc_clear_ts (&constructor_ts);

  t = check_constructor_type (e->value.constructor);
  if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
    e->ts = constructor_ts;

  return t;
}



typedef struct cons_stack
{
  gfc_iterator *iterator;
  struct cons_stack *previous;
}
cons_stack;

static cons_stack *base;

static try check_constructor (gfc_constructor *, try (*)(gfc_expr *));

/* Check an EXPR_VARIABLE expression in a constructor to make sure
   that that variable is an iteration variables.  */

try
gfc_check_iter_variable (gfc_expr * expr)
{

  gfc_symbol *sym;
  cons_stack *c;

  sym = expr->symtree->n.sym;

  for (c = base; c; c = c->previous)
    if (sym == c->iterator->var->symtree->n.sym)
      return SUCCESS;

  return FAILURE;
}


/* Recursive work function for gfc_check_constructor().  This amounts
   to calling the check function for each expression in the
   constructor, giving variables with the names of iterators a pass.  */

static try
check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *))
{
  cons_stack element;
  gfc_expr *e;
  try t;

  for (; c; c = c->next)
    {
      e = c->expr;

      if (e->expr_type != EXPR_ARRAY)
	{
	  if ((*check_function) (e) == FAILURE)
	    return FAILURE;
	  continue;
	}

      element.previous = base;
      element.iterator = c->iterator;

      base = &element;
      t = check_constructor (e->value.constructor, check_function);
      base = element.previous;

      if (t == FAILURE)
	return FAILURE;
    }

  /* Nothing went wrong, so all OK.  */
  return SUCCESS;
}


/* Checks a constructor to see if it is a particular kind of
   expression -- specification, restricted, or initialization as
   determined by the check_function.  */

try
gfc_check_constructor (gfc_expr * expr, try (*check_function) (gfc_expr *))
{
  cons_stack *base_save;
  try t;

  base_save = base;
  base = NULL;

  t = check_constructor (expr->value.constructor, check_function);
  base = base_save;

  return t;
}



/**************** Simplification of array constructors ****************/

iterator_stack *iter_stack;

typedef struct
{
  gfc_constructor *new_head, *new_tail;
  int extract_count, extract_n;
  gfc_expr *extracted;
  mpz_t *count;

  mpz_t *offset;
  gfc_component *component;
  mpz_t *repeat;

  try (*expand_work_function) (gfc_expr *);
}
expand_info;

static expand_info current_expand;

static try expand_constructor (gfc_constructor *);


/* Work function that counts the number of elements present in a
   constructor.  */

static try
count_elements (gfc_expr * e)
{
  mpz_t result;

  if (e->rank == 0)
    mpz_add_ui (*current_expand.count, *current_expand.count, 1);
  else
    {
      if (gfc_array_size (e, &result) == FAILURE)
	{
	  gfc_free_expr (e);
	  return FAILURE;
	}

      mpz_add (*current_expand.count, *current_expand.count, result);
      mpz_clear (result);
    }

  gfc_free_expr (e);
  return SUCCESS;
}


/* Work function that extracts a particular element from an array
   constructor, freeing the rest.  */

static try
extract_element (gfc_expr * e)
{

  if (e->rank != 0)
    {				/* Something unextractable */
      gfc_free_expr (e);
      return FAILURE;
    }

  if (current_expand.extract_count == current_expand.extract_n)
    current_expand.extracted = e;
  else
    gfc_free_expr (e);

  current_expand.extract_count++;
  return SUCCESS;
}


/* Work function that constructs a new constructor out of the old one,
   stringing new elements together.  */

static try
expand (gfc_expr * e)
{

  if (current_expand.new_head == NULL)
    current_expand.new_head = current_expand.new_tail =
      gfc_get_constructor ();
  else
    {
      current_expand.new_tail->next = gfc_get_constructor ();
      current_expand.new_tail = current_expand.new_tail->next;
    }

  current_expand.new_tail->where = e->where;
  current_expand.new_tail->expr = e;

  mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
  current_expand.new_tail->n.component = current_expand.component;
  mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
  return SUCCESS;
}


/* Given an initialization expression that is a variable reference,
   substitute the current value of the iteration variable.  */

void
gfc_simplify_iterator_var (gfc_expr * e)
{
  iterator_stack *p;

  for (p = iter_stack; p; p = p->prev)
    if (e->symtree == p->variable)
      break;

  if (p == NULL)
    return;		/* Variable not found */

  gfc_replace_expr (e, gfc_int_expr (0));

  mpz_set (e->value.integer, p->value);

  return;
}


/* Expand an expression with that is inside of a constructor,
   recursing into other constructors if present.  */

static try
expand_expr (gfc_expr * e)
{

  if (e->expr_type == EXPR_ARRAY)
    return expand_constructor (e->value.constructor);

  e = gfc_copy_expr (e);

  if (gfc_simplify_expr (e, 1) == FAILURE)
    {
      gfc_free_expr (e);
      return FAILURE;
    }

  return current_expand.expand_work_function (e);
}


static try
expand_iterator (gfc_constructor * c)
{
  gfc_expr *start, *end, *step;
  iterator_stack frame;
  mpz_t trip;
  try t;

  end = step = NULL;

  t = FAILURE;

  mpz_init (trip);
  mpz_init (frame.value);

  start = gfc_copy_expr (c->iterator->start);
  if (gfc_simplify_expr (start, 1) == FAILURE)
    goto cleanup;

  if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
    goto cleanup;

  end = gfc_copy_expr (c->iterator->end);
  if (gfc_simplify_expr (end, 1) == FAILURE)
    goto cleanup;

  if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
    goto cleanup;

  step = gfc_copy_expr (c->iterator->step);
  if (gfc_simplify_expr (step, 1) == FAILURE)
    goto cleanup;

  if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
    goto cleanup;

  if (mpz_sgn (step->value.integer) == 0)
    {
      gfc_error ("Iterator step at %L cannot be zero", &step->where);
      goto cleanup;
    }

  /* Calculate the trip count of the loop.  */
  mpz_sub (trip, end->value.integer, start->value.integer);
  mpz_add (trip, trip, step->value.integer);
  mpz_tdiv_q (trip, trip, step->value.integer);

  mpz_set (frame.value, start->value.integer);

  frame.prev = iter_stack;
  frame.variable = c->iterator->var->symtree;
  iter_stack = &frame;

  while (mpz_sgn (trip) > 0)
    {
      if (expand_expr (c->expr) == FAILURE)
	goto cleanup;

      mpz_add (frame.value, frame.value, step->value.integer);
      mpz_sub_ui (trip, trip, 1);
    }

  t = SUCCESS;

cleanup:
  gfc_free_expr (start);
  gfc_free_expr (end);
  gfc_free_expr (step);

  mpz_clear (trip);
  mpz_clear (frame.value);

  iter_stack = frame.prev;

  return t;
}


/* Expand a constructor into constant constructors without any
   iterators, calling the work function for each of the expanded
   expressions.  The work function needs to either save or free the
   passed expression.  */

static try
expand_constructor (gfc_constructor * c)
{
  gfc_expr *e;

  for (; c; c = c->next)
    {
      if (c->iterator != NULL)
	{
	  if (expand_iterator (c) == FAILURE)
	    return FAILURE;
	  continue;
	}

      e = c->expr;

      if (e->expr_type == EXPR_ARRAY)
	{
	  if (expand_constructor (e->value.constructor) == FAILURE)