re PR fortran/17675 ([Regression w.r.t. g77] Alignment constraints not honored in EQUIVALENCE)

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.

From-SVN: r93122

gcc/fortran/ChangeLog

+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.
+
 2005-01-08  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
 
 	* trans-const.c: Don't include unused math.h.

gcc/fortran/trans-common.c

@@ -116,8 +116,7 @@ typedef struct segment_info
   struct segment_info *next;
 } segment_info;
 
-static segment_info *current_segment, *current_common;
-static HOST_WIDE_INT current_offset;
+static segment_info * current_segment;
 static gfc_namespace *gfc_common_ns = NULL;
 
 #define BLANK_COMMON_NAME "__BLNK__"
@@ -354,7 +353,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
    backend declarations for all of the elements.  */
 
 static void
-create_common (gfc_common_head *com)
+create_common (gfc_common_head *com, segment_info * head)
 {
   segment_info *s, *next_s;
   tree union_type;
@@ -368,7 +367,7 @@ create_common (gfc_common_head *com)
   rli = start_record_layout (union_type);
   field_link = &TYPE_FIELDS (union_type);
 
-  for (s = current_common; s; s = s->next)
+  for (s = head; s; s = s->next)
     {
       build_field (s, union_type, rli);
 
@@ -393,7 +392,7 @@ create_common (gfc_common_head *com)
       HOST_WIDE_INT offset = 0;
 
       list = NULL_TREE;
-      for (s = current_common; s; s = s->next)
+      for (s = head; s; s = s->next)
         {
           if (s->sym->value)
             {
@@ -427,7 +426,7 @@ create_common (gfc_common_head *com)
     }
 
   /* Build component reference for each variable.  */
-  for (s = current_common; s; s = next_s)
+  for (s = head; s; s = next_s)
     {
       s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field),
 				     decl, s->field, NULL_TREE);
@@ -699,29 +698,149 @@ add_equivalences (void)
 }
 
 
-/* Given a seed symbol, create a new segment consisting of that symbol
-   and all of the symbols equivalenced with that symbol.  */
+/* 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
-new_segment (gfc_common_head *common, gfc_symbol *sym)
+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);
 
-  current_segment = get_segment_info (sym, current_offset);
+	  /* Add all objects directly or indirectly equivalenced with this
+	     symbol.  */
+	  add_equivalences ();
 
-  /* The offset of the next common variable.  */
-  current_offset += current_segment->length;
+	  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 all object directly or indirectly equivalenced with this common
-     variable.  */
-  add_equivalences ();
+	  offset = align_segment (&align);
+	  apply_segment_offset (current_segment, offset);
 
-  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 (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);
+	    }
 
-  /* Add these to the common block.  */
-  current_common = add_segments (current_common, current_segment);
+	  /* 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);
 }
 
 
@@ -732,7 +851,6 @@ finish_equivalences (gfc_namespace *ns)
 {
   gfc_equiv *z, *y;
   gfc_symbol *sym;
-  segment_info *v;
   HOST_WIDE_INT min_offset;
 
   for (z = ns->equiv; z; z = z->next)
@@ -746,47 +864,26 @@ finish_equivalences (gfc_namespace *ns)
         /* All objects directly or indirectly equivalenced with this symbol.  */
         add_equivalences ();
 
-        /* Calculate the minimal offset.  */
-        min_offset = current_segment->offset;
+        /* Bias the offsets to to start at zero.  */
+        min_offset = -current_segment->offset;
+
+	/* Ensure the block is properly aligned.  */
+	min_offset += align_segment (NULL);
 
-        /* Adjust the offset of each equivalence object.  */
-        for (v = current_segment; v; v = v->next)
-	  v->offset -= min_offset;
+	apply_segment_offset (current_segment, min_offset);
 
-        current_common = current_segment;
-        create_common (NULL);
+	/* Create the decl.  */
+        create_common (NULL, current_segment);
         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);
 }
 

gcc/testsuite/ChangeLog

+2005-01-09  Paul Brook  <paul@codesourcery.com>
+
+	* gfortran.dg/common_2.f90: New file.
+	* gfortran.dg/common_3.f90: New file.
+
 2005-01-09  Zdenek Dvorak  <dvorakz@suse.cz>
 
 	* gcc.dg/tree-ssa/loop-4.c: Fix outcome.

gcc/testsuite/gfortran.dg/common_2.f90

+! { dg-do run }
+! The equivalence was causing us to miss out c when laying out the common
+! block.
+program common_2
+  common /block/ a, b, c, d
+  integer a, b, c, d, n
+  dimension n(4)
+  equivalence (a, n(1))
+  equivalence (c, n(3))
+  a = 1
+  b = 2
+  c = 3
+  d = 4
+  if (any (n .ne. (/1, 2, 3, 4/))) call abort
+end program

gcc/testsuite/gfortran.dg/common_3.f90

+! { dg-do compile }
+! Check that equivalences match common block layout.
+program common_3
+  common /block/ a, b, c, d ! { dg-error "not match ordering" "" }
+  integer a, b, c, d, n
+  dimension n(4)
+  equivalence (a, n(1))
+  equivalence (c, n(4))
+end program