trans-common.c

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

    }
}


/* Given a symbol, find it in the current segment list. Returns NULL if
   not found.  */

static segment_info *
find_segment_info (gfc_symbol *symbol)
{
  segment_info *n;

  for (n = current_segment; n; n = n->next)
    {
      if (n->sym == symbol)
	return n;
    }

  return NULL;
}


/* Given an expression node, make sure it is a constant integer and return
   the mpz_t value.  */

static mpz_t *
get_mpz (gfc_expr *e)
{

  if (e->expr_type != EXPR_CONSTANT)
    gfc_internal_error ("get_mpz(): Not an integer constant");

  return &e->value.integer;
}


/* Given an array specification and an array reference, figure out the
   array element number (zero based). Bounds and elements are guaranteed
   to be constants.  If something goes wrong we generate an error and
   return zero.  */
 
static HOST_WIDE_INT
element_number (gfc_array_ref *ar)
{
  mpz_t multiplier, offset, extent, n;
  gfc_array_spec *as;
  HOST_WIDE_INT i, rank;

  as = ar->as;
  rank = as->rank;
  mpz_init_set_ui (multiplier, 1);
  mpz_init_set_ui (offset, 0);
  mpz_init (extent);
  mpz_init (n);

  for (i = 0; i < rank; i++)
    { 
      if (ar->dimen_type[i] != DIMEN_ELEMENT)
        gfc_internal_error ("element_number(): Bad dimension type");

      mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
 
      mpz_mul (n, n, multiplier);
      mpz_add (offset, offset, n);
 
      mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
      mpz_add_ui (extent, extent, 1);
 
      if (mpz_sgn (extent) < 0)
        mpz_set_ui (extent, 0);
 
      mpz_mul (multiplier, multiplier, extent);
    } 
 
  i = mpz_get_ui (offset);
 
  mpz_clear (multiplier);
  mpz_clear (offset);
  mpz_clear (extent);
  mpz_clear (n);
 
  return i;
}


/* Given a single element of an equivalence list, figure out the offset
   from the base symbol.  For simple variables or full arrays, this is
   simply zero.  For an array element we have to calculate the array
   element number and multiply by the element size. For a substring we
   have to calculate the further reference.  */

static HOST_WIDE_INT
calculate_offset (gfc_expr *e)
{
  HOST_WIDE_INT n, element_size, offset;
  gfc_typespec *element_type;
  gfc_ref *reference;

  offset = 0;
  element_type = &e->symtree->n.sym->ts;

  for (reference = e->ref; reference; reference = reference->next)
    switch (reference->type)
      {
      case REF_ARRAY:
        switch (reference->u.ar.type)
          {
          case AR_FULL:
	    break;

          case AR_ELEMENT:
	    n = element_number (&reference->u.ar);
	    if (element_type->type == BT_CHARACTER)
	      gfc_conv_const_charlen (element_type->cl);
	    element_size =
              int_size_in_bytes (gfc_typenode_for_spec (element_type));
	    offset += n * element_size;
	    break;

          default:
	    gfc_error ("Bad array reference at %L", &e->where);
          }
        break;
      case REF_SUBSTRING:
        if (reference->u.ss.start != NULL)
	  offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
        break;
      default:
        gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
                   &e->where);
    }
  return offset;
}


/* Add a new segment_info structure to the current segment.  eq1 is already
   in the list, eq2 is not.  */

static void
new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
{
  HOST_WIDE_INT offset1, offset2;
  segment_info *a;

  offset1 = calculate_offset (eq1->expr);
  offset2 = calculate_offset (eq2->expr);

  a = get_segment_info (eq2->expr->symtree->n.sym,
			v->offset + offset1 - offset2);
 
  current_segment = add_segments (current_segment, a);
}


/* Given two equivalence structures that are both already in the list, make
   sure that this new condition is not violated, generating an error if it
   is.  */

static void
confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
                   gfc_equiv *eq2)
{
  HOST_WIDE_INT offset1, offset2;

  offset1 = calculate_offset (eq1->expr);
  offset2 = calculate_offset (eq2->expr);

  if (s1->offset + offset1 != s2->offset + offset2)
    gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
	       "'%s' at %L", s1->sym->name, &s1->sym->declared_at,
	       s2->sym->name, &s2->sym->declared_at);
}


/* Process a new equivalence condition. eq1 is know to be in segment f.
   If eq2 is also present then confirm that the condition holds.
   Otherwise add a new variable to the segment list.  */

static void
add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
{
  segment_info *n;

  n = find_segment_info (eq2->expr->symtree->n.sym);

  if (n == NULL)
    new_condition (f, eq1, eq2);
  else
    confirm_condition (f, eq1, n, eq2);
}


/* Given a segment element, search through the equivalence lists for unused
   conditions that involve the symbol.  Add these rules to the segment.  */

static bool
find_equivalence (segment_info *n)
{
  gfc_equiv *e1, *e2, *eq;
  bool found;

  found = FALSE;

  for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
    {
      eq = NULL;

      /* Search the equivalence list, including the root (first) element
         for the symbol that owns the segment.  */
      for (e2 = e1; e2; e2 = e2->eq)
	{
	  if (!e2->used && e2->expr->symtree->n.sym == n->sym)
	    {
	      eq = e2;
	      break;
	    }
	}

      /* Go to the next root element.  */
      if (eq == NULL)
	continue;

      eq->used = 1;

      /* Now traverse the equivalence list matching the offsets.  */
      for (e2 = e1; e2; e2 = e2->eq)
	{
	  if (!e2->used && e2 != eq)
	    {
	      add_condition (n, eq, e2);
	      e2->used = 1;
	      found = TRUE;
	    }
	}
    }
  return found;
}


/* Add all symbols equivalenced within a segment.  We need to scan the
   segment list multiple times to include indirect equivalences.  */

static void
add_equivalences (bool *saw_equiv)
{
  segment_info *f;
  bool more;

  more = TRUE;
  while (more)
    {
      more = FALSE;
      for (f = current_segment; f; f = f->next)
	{
	  if (!f->sym->equiv_built)
	    {
	      f->sym->equiv_built = 1;
	      more = find_equivalence (f);
	      if (more)
		*saw_equiv = true;
	    }
	}
    }
}


/* Returns the offset necessary to properly align the current equivalence.
   Sets *palign to the required alignment.  */

static HOST_WIDE_INT
align_segment (unsigned HOST_WIDE_INT * palign)
{
  segment_info *s;
  unsigned HOST_WIDE_INT offset;
  unsigned HOST_WIDE_INT max_align;
  unsigned HOST_WIDE_INT this_align;
  unsigned HOST_WIDE_INT this_offset;

  max_align = 1;
  offset = 0;
  for (s = current_segment; s; s = s->next)
    {
      this_align = TYPE_ALIGN_UNIT (s->field);
      if (s->offset & (this_align - 1))
	{
	  /* Field is misaligned.  */
	  this_offset = this_align - ((s->offset + offset) & (this_align - 1));
	  if (this_offset & (max_align - 1))
	    {
	      /* Aligning this field would misalign a previous field.  */
	      gfc_error ("The equivalence set for variable '%s' "
			 "declared at %L violates alignment requirents",
			 s->sym->name, &s->sym->declared_at);
	    }
	  offset += this_offset;
	}
      max_align = this_align;
    }
  if (palign)
    *palign = max_align;
  return offset;
}


/* Adjust segment offsets by the given amount.  */

static void
apply_segment_offset (segment_info * s, HOST_WIDE_INT offset)
{
  for (; s; s = s->next)
    s->offset += offset;
}


/* Lay out a symbol in a common block.  If the symbol has already been seen
   then check the location is consistent.  Otherwise create segments
   for that symbol and all the symbols equivalenced with it.  */

/* Translate a single common block.  */

static void
translate_common (gfc_common_head *common, gfc_symbol *var_list)
{
  gfc_symbol *sym;
  segment_info *s;
  segment_info *common_segment;
  HOST_WIDE_INT offset;
  HOST_WIDE_INT current_offset;
  unsigned HOST_WIDE_INT align;
  unsigned HOST_WIDE_INT max_align;
  bool saw_equiv;

  common_segment = NULL;
  current_offset = 0;
  max_align = 1;
  saw_equiv = false;

  /* Add symbols to the segment.  */
  for (sym = var_list; sym; sym = sym->common_next)
    {
      current_segment = common_segment;
      s = find_segment_info (sym);

      /* Symbol has already been added via an equivalence.  Multiple
	 use associations of the same common block result in equiv_built
	 being set but no information about the symbol in the segment.  */
      if (s && sym->equiv_built)
	{
	  /* Ensure the current location is properly aligned.  */
	  align = TYPE_ALIGN_UNIT (s->field);
	  current_offset = (current_offset + align - 1) &~ (align - 1);

	  /* Verify that it ended up where we expect it.  */
	  if (s->offset != current_offset)
	    {
	      gfc_error ("Equivalence for '%s' does not match ordering of "
			 "COMMON '%s' at %L", sym->name,
			 common->name, &common->where);
	    }
	}
      else
	{
	  /* A symbol we haven't seen before.  */
	  s = current_segment = get_segment_info (sym, current_offset);

	  /* Add all objects directly or indirectly equivalenced with this
	     symbol.  */
	  add_equivalences (&saw_equiv);

	  if (current_segment->offset < 0)
	    gfc_error ("The equivalence set for '%s' cause an invalid "
		       "extension to COMMON '%s' at %L", sym->name,
		       common->name, &common->where);

	  offset = align_segment (&align);

	  if (offset & (max_align - 1))
	    {
	      /* The required offset conflicts with previous alignment
		 requirements.  Insert padding immediately before this
		 segment.  */
	      gfc_warning ("Padding of %d bytes required before '%s' in "
			   "COMMON '%s' at %L", (int)offset, s->sym->name,
			   common->name, &common->where);
	    }
	  else
	    {
	      /* Offset the whole common block.  */
	      apply_segment_offset (common_segment, offset);
	    }

	  /* Apply the offset to the new segments.  */
	  apply_segment_offset (current_segment, offset);
	  current_offset += offset;
	  if (max_align < align)
	    max_align = align;

	  /* Add the new segments to the common block.  */
	  common_segment = add_segments (common_segment, current_segment);
	}

      /* The offset of the next common variable.  */
      current_offset += s->length;
    }

  if (common_segment->offset != 0)
    {
      gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
		   common->name, &common->where, (int)common_segment->offset);
    }

  create_common (common, common_segment, saw_equiv);
}


/* Create a new block for each merged equivalence list.  */

static void
finish_equivalences (gfc_namespace *ns)
{
  gfc_equiv *z, *y;
  gfc_symbol *sym;
  gfc_common_head * c;
  HOST_WIDE_INT offset;
  unsigned HOST_WIDE_INT align;
  bool dummy;

  for (z = ns->equiv; z; z = z->next)
    for (y = z->eq; y; y = y->eq)
      {
        if (y->used) 
	  continue;
        sym = z->expr->symtree->n.sym;
        current_segment = get_segment_info (sym, 0);

        /* All objects directly or indirectly equivalenced with this symbol.  */
        add_equivalences (&dummy);

	/* Align the block.  */
	offset = align_segment (&align);

	/* Ensure all offsets are positive.  */
	offset -= current_segment->offset & ~(align - 1);

	apply_segment_offset (current_segment, offset);

	/* Create the decl. If this is a module equivalence, it has a unique
	   name, pointed to by z->module. This is written to a gfc_common_header
	   to push create_common into using build_common_decl, so that the
	   equivalence appears as an external symbol. Otherwise, a local
	   declaration is built using build_equiv_decl.*/
	if (z->module)
	  {
	    c = gfc_get_common_head ();
	    /* We've lost the real location, so use the location of the
	     enclosing procedure.  */
	    c->where = ns->proc_name->declared_at;
	    strcpy (c->name, z->module);
	  }
	else
	  c = NULL;

        create_common (c, current_segment, true);
        break;
      }
}


/* Work function for translating a named common block.  */

static void
named_common (gfc_symtree *st)
{
  translate_common (st->n.common, st->n.common->head);
}


/* Translate the common blocks in a namespace. Unlike other variables,
   these have to be created before code, because the backend_decl depends
   on the rest of the common block.  */

void
gfc_trans_common (gfc_namespace *ns)
{
  gfc_common_head *c;

  /* Translate the blank common block.  */
  if (ns->blank_common.head != NULL)
    {
      c = gfc_get_common_head ();
      /* We've lost the real location, so use the location of the
	 enclosing procedure.  */
      c->where = ns->proc_name->declared_at;
      strcpy (c->name, BLANK_COMMON_NAME);
      translate_common (c, ns->blank_common.head);
    }
 
  /* Translate all named common blocks.  */
  gfc_traverse_symtree (ns->common_root, named_common);

  /* Commit the newly created symbols for common blocks.  */
  gfc_commit_symbols ();

  /* Translate local equivalence.  */
  finish_equivalences (ns);
}