array.c

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

/* Array things
   Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
   Contributed by Andy Vaught

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */

#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "match.h"

/* This parameter is the size of the largest array constructor that we
   will expand to an array constructor without iterators.
   Constructors larger than this will remain in the iterator form.  */

#define GFC_MAX_AC_EXPAND 65535


/**************** Array reference matching subroutines *****************/

/* Copy an array reference structure.  */

gfc_array_ref *
gfc_copy_array_ref (gfc_array_ref * src)
{
  gfc_array_ref *dest;
  int i;

  if (src == NULL)
    return NULL;

  dest = gfc_get_array_ref ();

  *dest = *src;

  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
    {
      dest->start[i] = gfc_copy_expr (src->start[i]);
      dest->end[i] = gfc_copy_expr (src->end[i]);
      dest->stride[i] = gfc_copy_expr (src->stride[i]);
    }

  dest->offset = gfc_copy_expr (src->offset);

  return dest;
}


/* Match a single dimension of an array reference.  This can be a
   single element or an array section.  Any modifications we've made
   to the ar structure are cleaned up by the caller.  If the init
   is set, we require the subscript to be a valid initialization
   expression.  */

static match
match_subscript (gfc_array_ref * ar, int init)
{
  match m;
  int i;

  i = ar->dimen;

  ar->c_where[i] = gfc_current_locus;
  ar->start[i] = ar->end[i] = ar->stride[i] = NULL;

  /* We can't be sure of the difference between DIMEN_ELEMENT and
     DIMEN_VECTOR until we know the type of the element itself at
     resolution time.  */

  ar->dimen_type[i] = DIMEN_UNKNOWN;

  if (gfc_match_char (':') == MATCH_YES)
    goto end_element;

  /* Get start element.  */
  if (init)
    m = gfc_match_init_expr (&ar->start[i]);
  else
    m = gfc_match_expr (&ar->start[i]);

  if (m == MATCH_NO)
    gfc_error ("Expected array subscript at %C");
  if (m != MATCH_YES)
    return MATCH_ERROR;

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

  /* Get an optional end element.  Because we've seen the colon, we
     definitely have a range along this dimension.  */
end_element:
  ar->dimen_type[i] = DIMEN_RANGE;

  if (init)
    m = gfc_match_init_expr (&ar->end[i]);
  else
    m = gfc_match_expr (&ar->end[i]);

  if (m == MATCH_ERROR)
    return MATCH_ERROR;

  /* See if we have an optional stride.  */
  if (gfc_match_char (':') == MATCH_YES)
    {
      m = init ? gfc_match_init_expr (&ar->stride[i])
	: gfc_match_expr (&ar->stride[i]);

      if (m == MATCH_NO)
	gfc_error ("Expected array subscript stride at %C");
      if (m != MATCH_YES)
	return MATCH_ERROR;
    }

  return MATCH_YES;
}


/* Match an array reference, whether it is the whole array or a
   particular elements or a section. If init is set, the reference has
   to consist of init expressions.  */

match
gfc_match_array_ref (gfc_array_ref * ar, gfc_array_spec * as, int init)
{
  match m;

  memset (ar, '\0', sizeof (ar));

  ar->where = gfc_current_locus;
  ar->as = as;

  if (gfc_match_char ('(') != MATCH_YES)
    {
      ar->type = AR_FULL;
      ar->dimen = 0;
      return MATCH_YES;
    }

  ar->type = AR_UNKNOWN;

  for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
    {
      m = match_subscript (ar, init);
      if (m == MATCH_ERROR)
	goto error;

      if (gfc_match_char (')') == MATCH_YES)
	goto matched;

      if (gfc_match_char (',') != MATCH_YES)
	{
	  gfc_error ("Invalid form of array reference at %C");
	  goto error;
	}
    }

  gfc_error ("Array reference at %C cannot have more than %d dimensions",
	     GFC_MAX_DIMENSIONS);

error:
  return MATCH_ERROR;

matched:
  ar->dimen++;

  return MATCH_YES;
}


/************** Array specification matching subroutines ***************/

/* Free all of the expressions associated with array bounds
   specifications.  */

void
gfc_free_array_spec (gfc_array_spec * as)
{
  int i;

  if (as == NULL)
    return;

  for (i = 0; i < as->rank; i++)
    {
      gfc_free_expr (as->lower[i]);
      gfc_free_expr (as->upper[i]);
    }

  gfc_free (as);
}


/* Take an array bound, resolves the expression, that make up the
   shape and check associated constraints.  */

static try
resolve_array_bound (gfc_expr * e, int check_constant)
{

  if (e == NULL)
    return SUCCESS;

  if (gfc_resolve_expr (e) == FAILURE
      || gfc_specification_expr (e) == FAILURE)
    return FAILURE;

  if (check_constant && gfc_is_constant_expr (e) == 0)
    {
      gfc_error ("Variable '%s' at %L in this context must be constant",
		 e->symtree->n.sym->name, &e->where);
      return FAILURE;
    }

  return SUCCESS;
}


/* Takes an array specification, resolves the expressions that make up
   the shape and make sure everything is integral.  */

try
gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
{
  gfc_expr *e;
  int i;

  if (as == NULL)
    return SUCCESS;

  for (i = 0; i < as->rank; i++)
    {
      e = as->lower[i];
      if (resolve_array_bound (e, check_constant) == FAILURE)
	return FAILURE;

      e = as->upper[i];
      if (resolve_array_bound (e, check_constant) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


/* Match a single array element specification.  The return values as
   well as the upper and lower bounds of the array spec are filled
   in according to what we see on the input.  The caller makes sure
   individual specifications make sense as a whole.


        Parsed       Lower   Upper  Returned
        ------------------------------------
          :          NULL    NULL   AS_DEFERRED (*)
          x           1       x     AS_EXPLICIT
          x:          x      NULL   AS_ASSUMED_SHAPE
          x:y         x       y     AS_EXPLICIT
          x:*         x      NULL   AS_ASSUMED_SIZE
          *           1      NULL   AS_ASSUMED_SIZE

  (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE.  This
  is fixed during the resolution of formal interfaces.

   Anything else AS_UNKNOWN.  */

static array_type
match_array_element_spec (gfc_array_spec * as)
{
  gfc_expr **upper, **lower;
  match m;

  lower = &as->lower[as->rank - 1];
  upper = &as->upper[as->rank - 1];

  if (gfc_match_char ('*') == MATCH_YES)
    {
      *lower = gfc_int_expr (1);
      return AS_ASSUMED_SIZE;
    }

  if (gfc_match_char (':') == MATCH_YES)
    return AS_DEFERRED;

  m = gfc_match_expr (upper);
  if (m == MATCH_NO)
    gfc_error ("Expected expression in array specification at %C");
  if (m != MATCH_YES)
    return AS_UNKNOWN;

  if (gfc_match_char (':') == MATCH_NO)
    {
      *lower = gfc_int_expr (1);
      return AS_EXPLICIT;
    }

  *lower = *upper;
  *upper = NULL;

  if (gfc_match_char ('*') == MATCH_YES)
    return AS_ASSUMED_SIZE;

  m = gfc_match_expr (upper);
  if (m == MATCH_ERROR)
    return AS_UNKNOWN;
  if (m == MATCH_NO)
    return AS_ASSUMED_SHAPE;

  return AS_EXPLICIT;
}


/* Matches an array specification, incidentally figuring out what sort
   it is.  */

match
gfc_match_array_spec (gfc_array_spec ** asp)
{
  array_type current_type;
  gfc_array_spec *as;
  int i;

  if (gfc_match_char ('(') != MATCH_YES)
    {
      *asp = NULL;
      return MATCH_NO;
    }

  as = gfc_get_array_spec ();

  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
    {
      as->lower[i] = NULL;
      as->upper[i] = NULL;
    }

  as->rank = 1;

  for (;;)
    {
      current_type = match_array_element_spec (as);

      if (as->rank == 1)
	{
	  if (current_type == AS_UNKNOWN)
	    goto cleanup;
	  as->type = current_type;
	}
      else
	switch (as->type)
	  {			/* See how current spec meshes with the existing */
	  case AS_UNKNOWN:
	    goto cleanup;

	  case AS_EXPLICIT:
	    if (current_type == AS_ASSUMED_SIZE)
	      {
		as->type = AS_ASSUMED_SIZE;
		break;
	      }

	    if (current_type == AS_EXPLICIT)
	      break;

	    gfc_error
	      ("Bad array specification for an explicitly shaped array"
	       " at %C");

	    goto cleanup;

	  case AS_ASSUMED_SHAPE:
	    if ((current_type == AS_ASSUMED_SHAPE)
		|| (current_type == AS_DEFERRED))
	      break;

	    gfc_error
	      ("Bad array specification for assumed shape array at %C");
	    goto cleanup;

	  case AS_DEFERRED:
	    if (current_type == AS_DEFERRED)
	      break;

	    if (current_type == AS_ASSUMED_SHAPE)
	      {
		as->type = AS_ASSUMED_SHAPE;
		break;
	      }

	    gfc_error ("Bad specification for deferred shape array at %C");
	    goto cleanup;

	  case AS_ASSUMED_SIZE:
	    gfc_error ("Bad specification for assumed size array at %C");
	    goto cleanup;
	  }

      if (gfc_match_char (')') == MATCH_YES)
	break;

      if (gfc_match_char (',') != MATCH_YES)
	{
	  gfc_error ("Expected another dimension in array declaration at %C");
	  goto cleanup;
	}

      if (as->rank >= GFC_MAX_DIMENSIONS)
	{
	  gfc_error ("Array specification at %C has more than %d dimensions",
		     GFC_MAX_DIMENSIONS);
	  goto cleanup;
	}

      as->rank++;
    }

  /* If a lower bounds of an assumed shape array is blank, put in one.  */
  if (as->type == AS_ASSUMED_SHAPE)
    {
      for (i = 0; i < as->rank; i++)
	{
	  if (as->lower[i] == NULL)
	    as->lower[i] = gfc_int_expr (1);
	}
    }
  *asp = as;
  return MATCH_YES;

cleanup:
  /* Something went wrong.  */
  gfc_free_array_spec (as);
  return MATCH_ERROR;
}


/* Given a symbol and an array specification, modify the symbol to
   have that array specification.  The error locus is needed in case
   something goes wrong.  On failure, the caller must free the spec.  */

try
gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc)
{

  if (as == NULL)
    return SUCCESS;

  if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
    return FAILURE;

  sym->as = as;

  return SUCCESS;
}


/* Copy an array specification.  */

gfc_array_spec *
gfc_copy_array_spec (gfc_array_spec * src)
{
  gfc_array_spec *dest;
  int i;

  if (src == NULL)
    return NULL;

  dest = gfc_get_array_spec ();

  *dest = *src;

  for (i = 0; i < dest->rank; i++)
    {
      dest->lower[i] = gfc_copy_expr (dest->lower[i]);
      dest->upper[i] = gfc_copy_expr (dest->upper[i]);
    }

  return dest;
}

/* Returns nonzero if the two expressions are equal.  Only handles integer
   constants.  */

static int
compare_bounds (gfc_expr * bound1, gfc_expr * bound2)
{
  if (bound1 == NULL || bound2 == NULL
      || bound1->expr_type != EXPR_CONSTANT
      || bound2->expr_type != EXPR_CONSTANT
      || bound1->ts.type != BT_INTEGER
      || bound2->ts.type != BT_INTEGER)
    gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");

  if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
    return 1;
  else
    return 0;
}

/* Compares two array specifications.  They must be constant or deferred
   shape.  */

int
gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2)
{
  int i;

  if (as1 == NULL && as2 == NULL)
    return 1;

  if (as1 == NULL || as2 == NULL)
    return 0;

  if (as1->rank != as2->rank)
    return 0;

  if (as1->rank == 0)
    return 1;

  if (as1->type != as2->type)
    return 0;

  if (as1->type == AS_EXPLICIT)
    for (i = 0; i < as1->rank; i++)
      {
	if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
	  return 0;

	if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
	  return 0;
      }

  return 1;
}


/****************** Array constructor functions ******************/

/* Start an array constructor.  The constructor starts with zero
   elements and should be appended to by gfc_append_constructor().  */

gfc_expr *
gfc_start_constructor (bt type, int kind, locus * where)
{
  gfc_expr *result;

  result = gfc_get_expr ();

  result->expr_type = EXPR_ARRAY;
  result->rank = 1;

  result->ts.type = type;
  result->ts.kind = kind;
  result->where = *where;
  return result;
}


/* Given an array constructor expression, append the new expression
   node onto the constructor.  */

void
gfc_append_constructor (gfc_expr * base, gfc_expr * new)
{
  gfc_constructor *c;

  if (base->value.constructor == NULL)
    base->value.constructor = c = gfc_get_constructor ();
  else
    {
      c = base->value.constructor;
      while (c->next)
	c = c->next;

      c->next = gfc_get_constructor ();
      c = c->next;
    }

  c->expr = new;

  if (new->ts.type != base->ts.type || new->ts.kind != base->ts.kind)
    gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
}


/* Given an array constructor expression, insert the new expression's
   constructor onto the base's one according to the offset.  */

void
gfc_insert_constructor (gfc_expr * base, gfc_constructor * c1)
{
  gfc_constructor *c, *pre;
  expr_t type;
  int t;

  type = base->expr_type;

  if (base->value.constructor == NULL)
    base->value.constructor = c1;
  else
    {
      c = pre = base->value.constructor;
      while (c)
        {
          if (type == EXPR_ARRAY)
            {
	      t = mpz_cmp (c->n.offset, c1->n.offset);
              if (t < 0)
                {
                  pre = c;
                  c = c->next;
                }
              else if (t == 0)
                {
                  gfc_error ("duplicated initializer");
                  break;
                }
              else
                break;
            }
          else
            {
              pre = c;
              c = c->next;
            }
        }

      if (pre != c)
        {
          pre->next = c1;
          c1->next = c;
        }
      else
        {
          c1->next = c;
          base->value.constructor = c1;
        }
    }
}


/* Get a new constructor.  */

gfc_constructor *
gfc_get_constructor (void)
{
  gfc_constructor *c;

  c = gfc_getmem (sizeof(gfc_constructor));
  c->expr = NULL;
  c->iterator = NULL;
  c->next = NULL;
  mpz_init_set_si (c->n.offset, 0);
  mpz_init_set_si (c->repeat, 0);
  return c;
}


/* Free chains of gfc_constructor structures.  */

void
gfc_free_constructor (gfc_constructor * p)
{
  gfc_constructor *next;

  if (p == NULL)
    return;

  for (; p; p = next)
    {
      next = p->next;