[gfortran] Fix common block alignment (PR17675)

[Paul Brook <paul at codesourcery dot com>]

The attached patch fixed common and equivalence block alignment issues, as 
described in PR17675. I think the behaviour is the same as g77. when possible 
padding is inserted at the start of the block to ensure correct alignment. If 
this is not sufficient then additional padding is inserted immediately before 
subsequent unaligned members. it also verifies that equivalences do not 
violate alignment constraints.

We were getting common block layout wrong when multiple variables in the same 
common block were related via equivalence statement. The patch fixes this and 
verifies that the variables end up where we expect them.

Tested on i686-linux.
Applied to mainline.

Paul

2005-01-09  Paul Brook  <paul@codesourcery.com>

 PR fortran/17675
 * trans-common.c (current_common, current_offset): Remove.
 (create_common): Add head argument.
 (align_segment): New function.
 (apply_segment_offset): New function.
 (translate_common): Merge code from new_segment.  Handle alignment.
 (new_segment): Remove.
 (finish_equivalences): Ensure proper alignment.
testsuite/
 * gfortran.dg/common_2.f90: New file.
 * gfortran.dg/common_3.f90: New file.

Index: trans-common.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-common.c,v
retrieving revision 1.18
diff -c -p -r1.18 trans-common.c
*** trans-common.c	16 Sep 2004 16:00:43 -0000	1.18
--- trans-common.c	9 Jan 2005 19:44:22 -0000
*************** typedef struct segment_info
*** 116,123 ****
    struct segment_info *next;
  } segment_info;
  
! static segment_info *current_segment, *current_common;
! static HOST_WIDE_INT current_offset;
  static gfc_namespace *gfc_common_ns = NULL;
  
  #define BLANK_COMMON_NAME "__BLNK__"
--- 116,122 ----
    struct segment_info *next;
  } segment_info;
  
! static segment_info * current_segment;
  static gfc_namespace *gfc_common_ns = NULL;
  
  #define BLANK_COMMON_NAME "__BLNK__"
*************** build_common_decl (gfc_common_head *com,
*** 354,360 ****
     backend declarations for all of the elements.  */
  
  static void
! create_common (gfc_common_head *com)
  {
    segment_info *s, *next_s;
    tree union_type;
--- 353,359 ----
     backend declarations for all of the elements.  */
  
  static void
! create_common (gfc_common_head *com, segment_info * head)
  {
    segment_info *s, *next_s;
    tree union_type;
*************** create_common (gfc_common_head *com)
*** 368,374 ****
    rli = start_record_layout (union_type);
    field_link = &TYPE_FIELDS (union_type);
  
!   for (s = current_common; s; s = s->next)
      {
        build_field (s, union_type, rli);
  
--- 367,373 ----
    rli = start_record_layout (union_type);
    field_link = &TYPE_FIELDS (union_type);
  
!   for (s = head; s; s = s->next)
      {
        build_field (s, union_type, rli);
  
*************** create_common (gfc_common_head *com)
*** 393,399 ****
        HOST_WIDE_INT offset = 0;
  
        list = NULL_TREE;
!       for (s = current_common; s; s = s->next)
          {
            if (s->sym->value)
              {
--- 392,398 ----
        HOST_WIDE_INT offset = 0;
  
        list = NULL_TREE;
!       for (s = head; s; s = s->next)
          {
            if (s->sym->value)
              {
*************** create_common (gfc_common_head *com)
*** 427,433 ****
      }
  
    /* Build component reference for each variable.  */
!   for (s = current_common; s; s = next_s)
      {
        s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field),
  				     decl, s->field, NULL_TREE);
--- 426,432 ----
      }
  
    /* Build component reference for each variable.  */
!   for (s = head; s; s = next_s)
      {
        s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field),
  				     decl, s->field, NULL_TREE);
*************** add_equivalences (void)
*** 699,727 ****
  }
  
  
! /* Given a seed symbol, create a new segment consisting of that symbol
!    and all of the symbols equivalenced with that symbol.  */
  
  static void
! new_segment (gfc_common_head *common, gfc_symbol *sym)
  {
  
!   current_segment = get_segment_info (sym, current_offset);
  
!   /* The offset of the next common variable.  */
!   current_offset += current_segment->length;
  
!   /* Add all object directly or indirectly equivalenced with this common
!      variable.  */
!   add_equivalences ();
  
!   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);
  
!   /* Add these to the common block.  */
!   current_common = add_segments (current_common, current_segment);
  }
  
  
--- 698,846 ----
  }
  
  
! /* Returns the offset neccessary 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;
! 
!   common_segment = NULL;
!   current_offset = 0;
!   max_align = 1;
  
!   /* 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 ();
! 
! 	  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);
! 	  apply_segment_offset (current_segment, offset);
! 
! 	  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);
  }
  
  
*************** finish_equivalences (gfc_namespace *ns)
*** 732,738 ****
  {
    gfc_equiv *z, *y;
    gfc_symbol *sym;
-   segment_info *v;
    HOST_WIDE_INT min_offset;
  
    for (z = ns->equiv; z; z = z->next)
--- 851,856 ----
*************** finish_equivalences (gfc_namespace *ns)
*** 746,792 ****
          /* All objects directly or indirectly equivalenced with this symbol.  */
          add_equivalences ();
  
!         /* Calculate the minimal offset.  */
!         min_offset = current_segment->offset;
  
!         /* Adjust the offset of each equivalence object.  */
!         for (v = current_segment; v; v = v->next)
! 	  v->offset -= min_offset;
  
!         current_common = current_segment;
!         create_common (NULL);
          break;
        }
  }
  
  
- /* Translate a single common block.  */
- 
- static void
- translate_common (gfc_common_head *common, gfc_symbol *var_list)
- {
-   gfc_symbol *sym;
- 
-   current_common = NULL;
-   current_offset = 0;
- 
-   /* Add symbols to the segment.  */
-   for (sym = var_list; sym; sym = sym->common_next)
-     {
-       if (! sym->equiv_built)
- 	new_segment (common, sym);
-     }
- 
-   create_common (common);
- }
- 
- 
  /* Work function for translating a named common block.  */
  
  static void
  named_common (gfc_symtree *st)
  {
- 
    translate_common (st->n.common, st->n.common->head);
  }
  
--- 864,889 ----
          /* All objects directly or indirectly equivalenced with this symbol.  */
          add_equivalences ();
  
!         /* Bias the offsets to to start at zero.  */
!         min_offset = -current_segment->offset;
  
! 	/* Ensure the block is properly aligned.  */
! 	min_offset += align_segment (NULL);
  
! 	apply_segment_offset (current_segment, min_offset);
! 
! 	/* Create the decl.  */
!         create_common (NULL, current_segment);
          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);
  }