Пример #1
0
static void
finish_equivalences (gfc_namespace *ns)
{
  gfc_equiv *z, *y;
  gfc_symbol *sym;
  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.  */
        create_common (NULL, current_segment, true);
        break;
      }
}
Пример #2
0
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;
      }
}
Пример #3
0
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;
  bool saw_equiv;

  common_segment = NULL;
  offset = 0;
  current_offset = 0;
  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);

	  if (gfc_option.flag_align_commons)
	    offset = align_segment (&align);

	  if (offset)
	    {
	      /* The required offset conflicts with previous alignment
		 requirements.  Insert padding immediately before this
		 segment.  */
	      if (gfc_option.warn_align_commons)
		{
		  if (strcmp (common->name, BLANK_COMMON_NAME))
		    gfc_warning ("Padding of %d bytes required before '%s' in "
				 "COMMON '%s' at %L; reorder elements or use "
				 "-fno-align-commons", (int)offset,
				 s->sym->name, common->name, &common->where);
		  else
		    gfc_warning ("Padding of %d bytes required before '%s' in "
				 "COMMON at %L; reorder elements or use "
				 "-fno-align-commons", (int)offset,
				 s->sym->name, &common->where);
		}
	    }

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

	  /* 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 == NULL)
    {
      gfc_error ("COMMON '%s' at %L does not exist",
		 common->name, &common->where);
      return;
    }

  if (common_segment->offset != 0 && gfc_option.warn_align_commons)
    {
      if (strcmp (common->name, BLANK_COMMON_NAME))
	gfc_warning ("COMMON '%s' at %L requires %d bytes of padding; "
		     "reorder elements or use -fno-align-commons",
		     common->name, &common->where, (int)common_segment->offset);
      else
	gfc_warning ("COMMON at %L requires %d bytes of padding; "
		     "reorder elements or use -fno-align-commons",
		     &common->where, (int)common_segment->offset);
    }

  create_common (common, common_segment, saw_equiv);
}
Пример #4
0
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)
    {
      if (sym->equiv_built)
	{
	  /* Symbol has already been added via an equivalence.  */
	  current_segment = common_segment;
	  s = find_segment_info (sym);

	  /* 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", 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, common_segment->offset);
    }

  create_common (common, common_segment, saw_equiv);
}