re PR fortran/29786 (Initialization of overlapping variables: Not implemented)

2007-06-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29786
	PR fortran/30875
	* trans-common.c (get_init_field): New function.
	(create_common): Call get_init_field for overlapping
	initializers in equivalence blocks.
	* resolve.c (resolve_equivalence_derived, resolve_equivalence):
	Remove constraints on initializers in equivalence blocks.
	* target-memory.c (expr_to_char, gfc_merge_initializers):
	New functions.
	(encode_derived): Add the bit offset to the byte offset to get
	the total offset to the field.
	* target-memory.h : Add prototype for gfc_merge_initializers.


2007-06-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29786
	* gfortran.dg/equiv_7.f90: New test.
	* gfortran.dg/equiv_constraint_7.f90: Change error message.


	PR fortran/30875
	* gfortran.dg/equiv_constraint_5.f90: Correct code and error.

From-SVN: r125628

9 files changed, 396 insertions, 64 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 32fb0238647..bb56decbe8b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2007-06-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29786
+	PR fortran/30875
+	* trans-common.c (get_init_field): New function.
+	(create_common): Call get_init_field for overlapping
+	initializers in equivalence blocks.
+	* resolve.c (resolve_equivalence_derived, resolve_equivalence):
+	Remove constraints on initializers in equivalence blocks.
+	* target-memory.c (expr_to_char, gfc_merge_initializers):
+	New functions.
+	(encode_derived): Add the bit offset to the byte offset to get
+	the total offset to the field.
+	* target-memory.h : Add prototype for gfc_merge_initializers.
+
 2007-06-11  Rafael Avila de Espindola  <espindola@google.com>
 
 	* trans-types.c (gfc_signed_type): Remove.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 74aa9152540..99797aa7ec3 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6992,14 +6992,6 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
 		     sym->name, &e->where);
 	  return FAILURE;
 	}
-
-      if (c->initializer)
-	{
-	  gfc_error ("Derived type variable '%s' at %L with default "
-		     "initializer cannot be an EQUIVALENCE object",
-		     sym->name, &e->where);
-	  return FAILURE;
-	}
     }
   return SUCCESS;
 }
@@ -7122,21 +7114,6 @@ resolve_equivalence (gfc_equiv *eq)
 	      break;
 	}
 
-      /* An equivalence statement cannot have more than one initialized
-	 object.  */
-      if (sym->value)
-	{
-	  if (value_name != NULL)
-	    {
-	      gfc_error ("Initialized objects '%s' and '%s' cannot both "
-			 "be in the EQUIVALENCE statement at %L",
-			 value_name, sym->name, &e->where);
-	      continue;
-	    }
-	  else
-	    value_name = sym->name;
-	}
-
       /* Shall not equivalence common block variables in a PURE procedure.  */
       if (sym->ns->proc_name
 	  && sym->ns->proc_name->attr.pure
diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index e23574417bd..561a8f11beb 100644
--- a/gcc/fortran/target-memory.c
+++ b/gcc/fortran/target-memory.c
@@ -198,8 +198,11 @@ encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
   cmp = source->ts.derived->components;
   for (;ctr; ctr = ctr->next, cmp = cmp->next)
     {
-      gcc_assert (ctr->expr && cmp);
-      ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
+      gcc_assert (cmp);
+      if (!ctr->expr)
+	continue;
+      ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+	    + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
       gfc_target_encode_expr (ctr->expr, &buffer[ptr],
 			      buffer_size - ptr);
     }
@@ -491,3 +494,105 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
 
   return result->representation.length;
 }
+
+
+/* --------------------------------------------------------------- */ 
+/* Two functions used by trans-common.c to write overlapping
+   equivalence initializers to a buffer.  This is added to the union
+   and the original initializers freed.  */
+
+
+/* Writes the values of a constant expression to a char buffer. If another
+   unequal initializer has already been written to the buffer, this is an
+   error.  */
+
+static size_t
+expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
+{
+  int i;
+  int ptr;
+  gfc_constructor *ctr;
+  gfc_component *cmp;
+  unsigned char *buffer;
+
+  if (e == NULL)
+    return 0;
+
+  /* Take a derived type, one component at a time, using the offsets from the backend
+     declaration.  */
+  if (e->ts.type == BT_DERIVED)
+    {
+      ctr = e->value.constructor;
+      cmp = e->ts.derived->components;
+      for (;ctr; ctr = ctr->next, cmp = cmp->next)
+	{
+	  gcc_assert (cmp && cmp->backend_decl);
+	  if (!ctr->expr)
+	    continue;
+	    ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+			+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
+	  expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len);
+	}
+      return len;
+    }
+
+  /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
+     to the target, in a buffer and check off the initialized part of the buffer.  */
+  len = gfc_target_expr_size (e);
+  buffer = (unsigned char*)alloca (len);
+  len = gfc_target_encode_expr (e, buffer, len);
+
+    for (i = 0; i < (int)len; i++)
+    {
+      if (chk[i] && (buffer[i] != data[i]))
+	{
+	  gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
+		     "at %L", &e->where);
+	  return 0;
+	}
+      chk[i] = 0xFF;
+    }
+
+  memcpy (data, buffer, len);
+  return len;
+}
+
+
+/* Writes the values from the equivalence initializers to a char* array
+   that will be written to the constructor to make the initializer for
+   the union declaration.  */
+
+size_t
+gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
+			unsigned char *chk, size_t length)
+{
+  size_t len = 0;
+  gfc_constructor * c;
+
+  switch (e->expr_type)
+    {
+    case EXPR_CONSTANT:
+    case EXPR_STRUCTURE:
+      len = expr_to_char (e, &data[0], &chk[0], length);
+
+      break;
+
+    case EXPR_ARRAY:
+      for (c = e->value.constructor; c; c = c->next)
+	{
+	  size_t elt_size = gfc_target_expr_size (c->expr);
+
+	  if (c->n.offset)
+	    len = elt_size * (size_t)mpz_get_si (c->n.offset);
+
+	  len = len + gfc_merge_initializers (ts, c->expr, &data[len],
+					      &chk[len], length - len);
+	}
+      break;
+
+    default:
+      return 0;
+    }
+
+  return len;
+}
diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h
index 8e35e69bd0b..b8f6d044e36 100644
--- a/gcc/fortran/target-memory.h
+++ b/gcc/fortran/target-memory.h
@@ -41,4 +41,9 @@ int gfc_interpret_character (unsigned char *, size_t, gfc_expr *);
 int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *);
 int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *);
 
+/* Merge overlapping equivalence initializers for trans-common.c. */
+size_t gfc_merge_initializers (gfc_typespec, gfc_expr *,
+			       unsigned char *, unsigned char *,
+			       size_t);
+
 #endif /* GFC_TARGET_MEMORY_H  */
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index bde7ea577cd..e39ec5962a0 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -106,6 +106,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "trans.h"
 #include "trans-types.h"
 #include "trans-const.h"
+#include "target-memory.h"
 
 
 /* Holds a single variable in an equivalence set.  */
@@ -413,6 +414,110 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
 }
 
 
+/* Return a field that is the size of the union, if an equivalence has
+   overlapping initializers.  Merge the initializers into a single
+   initializer for this new field, then free the old ones.  */ 
+
+static tree
+get_init_field (segment_info *head, tree union_type, tree *field_init,
+		record_layout_info rli)
+{
+  segment_info *s;
+  HOST_WIDE_INT length = 0;
+  HOST_WIDE_INT offset = 0;
+  unsigned HOST_WIDE_INT known_align, desired_align;
+  bool overlap = false;
+  tree tmp, field;
+  tree init;
+  unsigned char *data, *chk;
+  VEC(constructor_elt,gc) *v = NULL;
+
+  tree type = unsigned_char_type_node;
+  int i;
+
+  /* Obtain the size of the union and check if there are any overlapping
+     initializers.  */
+  for (s = head; s; s = s->next)
+    {
+      HOST_WIDE_INT slen = s->offset + s->length;
+      if (s->sym->value)
+	{
+	  if (s->offset < offset)
+            overlap = true;
+	  offset = slen;
+	}
+      length = length < slen ? slen : length;
+    }
+
+  if (!overlap)
+    return NULL_TREE;
+
+  /* Now absorb all the initializer data into a single vector,
+     whilst checking for overlapping, unequal values.  */
+  data = (unsigned char*)gfc_getmem ((size_t)length);
+  chk = (unsigned char*)gfc_getmem ((size_t)length);
+
+  /* TODO - change this when default initialization is implemented.  */
+  memset (data, '\0', (size_t)length);
+  memset (chk, '\0', (size_t)length);
+  for (s = head; s; s = s->next)
+    if (s->sym->value)
+      gfc_merge_initializers (s->sym->ts, s->sym->value,
+			      &data[s->offset],
+			      &chk[s->offset],
+			     (size_t)s->length);
+  
+  for (i = 0; i < length; i++)
+    CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
+
+  gfc_free (data);
+  gfc_free (chk);
+
+  /* Build a char[length] array to hold the initializers.  Much of what
+     follows is borrowed from build_field, above.  */
+
+  tmp = build_int_cst (gfc_array_index_type, length - 1);
+  tmp = build_range_type (gfc_array_index_type,
+			  gfc_index_zero_node, tmp);
+  tmp = build_array_type (type, tmp);
+  field = build_decl (FIELD_DECL, NULL_TREE, tmp);
+  gfc_set_decl_location (field, &gfc_current_locus);
+
+  known_align = BIGGEST_ALIGNMENT;
+
+  desired_align = update_alignment_for_field (rli, field, known_align);
+  if (desired_align > known_align)
+    DECL_PACKED (field) = 1;
+
+  DECL_FIELD_CONTEXT (field) = union_type;
+  DECL_FIELD_OFFSET (field) = size_int (0);
+  DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
+  SET_DECL_OFFSET_ALIGN (field, known_align);
+
+  rli->offset = size_binop (MAX_EXPR, rli->offset,
+                            size_binop (PLUS_EXPR,
+                                        DECL_FIELD_OFFSET (field),
+                                        DECL_SIZE_UNIT (field)));
+
+  init = build_constructor (TREE_TYPE (field), v);
+  TREE_CONSTANT (init) = 1;
+  TREE_INVARIANT (init) = 1;
+
+  *field_init = init;
+
+  for (s = head; s; s = s->next)
+    {
+      if (s->sym->value == NULL)
+	continue;
+
+      gfc_free_expr (s->sym->value);
+      s->sym->value = NULL;
+    }
+
+  return field;
+}
+
+
 /* Declare memory for the common block or local equivalence, and create
    backend declarations for all of the elements.  */
 
@@ -422,6 +527,8 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
   segment_info *s, *next_s;
   tree union_type;
   tree *field_link;
+  tree field;
+  tree field_init;
   record_layout_info rli;
   tree decl;
   bool is_init = false;
@@ -440,6 +547,20 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
   rli = start_record_layout (union_type);
   field_link = &TYPE_FIELDS (union_type);
 
+  /* Check for overlapping initializers and replace them with a single,
+     artificial field that contains all the data.  */
+  if (saw_equiv)
+    field = get_init_field (head, union_type, &field_init, rli);
+  else
+    field = NULL_TREE;
+
+  if (field != NULL_TREE)
+    {
+      is_init = true;
+      *field_link = field;
+      field_link = &TREE_CHAIN (field);
+    }
+
   for (s = head; s; s = s->next)
     {
       build_field (s, union_type, rli);
@@ -456,6 +577,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
       if (s->sym->attr.save)
         is_saved = true;
     }
+
   finish_record_layout (rli, true);
 
   if (com)
@@ -469,29 +591,23 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
       HOST_WIDE_INT offset = 0;
       VEC(constructor_elt,gc) *v = NULL;
 
-      for (s = head; s; s = s->next)
-        {
-          if (s->sym->value)
-            {
-              if (s->offset < offset)
-                {
-		    /* We have overlapping initializers.  It could either be
-		       partially initialized arrays (legal), or the user
-		       specified multiple initial values (illegal).
-		       We don't implement this yet, so bail out.  */
-                  gfc_todo_error ("Initialization of overlapping variables");
-                }
-	      /* Add the initializer for this field.  */
-	      tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
-					  TREE_TYPE (s->field),
-					  s->sym->attr.dimension,
-					  s->sym->attr.pointer
-					  || s->sym->attr.allocatable);
-
-	      CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
-              offset = s->offset + s->length;
-            }
-        }
+      if (field != NULL_TREE && field_init != NULL_TREE)
+	CONSTRUCTOR_APPEND_ELT (v, field, field_init);
+      else
+	for (s = head; s; s = s->next)
+	  {
+	    if (s->sym->value)
+	      {
+		/* Add the initializer for this field.  */
+		tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
+		    TREE_TYPE (s->field), s->sym->attr.dimension,
+		    s->sym->attr.pointer || s->sym->attr.allocatable);
+
+		CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
+		offset = s->offset + s->length;
+	      }
+	  }
+
       gcc_assert (!VEC_empty (constructor_elt, v));
       ctor = build_constructor (union_type, v);
       TREE_CONSTANT (ctor) = 1;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 23922411cc6..1e401362aec 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2007-06-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29786
+	* gfortran.dg/equiv_7.f90: New test.
+	* gfortran.dg/equiv_constraint_7.f90: Change error message.
+
+	PR fortran/30875
+	* gfortran.dg/equiv_constraint_5.f90: Correct code and error.
+
 2007-06-11  Andreas Tobler  <a.tobler@schweiz.org>
 
 	* gcc.dg/setjmp-3.c: Rename raise to raise0.
diff --git a/gcc/testsuite/gfortran.dg/equiv_7.f90 b/gcc/testsuite/gfortran.dg/equiv_7.f90
new file mode 100644
index 00000000000..51beba72787
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/equiv_7.f90
@@ -0,0 +1,92 @@
+! { dg-do run }
+! { dg-options "-std=gnu" }
+! Tests the fix for PR29786, in which initialization of overlapping
+! equivalence elements caused a compile error.
+!
+! Contributed by Bernhard Fischer <aldot@gcc.gnu.org>
+!
+block data
+  common /global/ ca (4)
+  integer(4) ca, cb
+  equivalence (cb, ca(3))
+  data (ca(i), i = 1, 2) /42,43/, ca(4) /44/
+  data cb /99/
+end block data
+
+  call int4_int4
+  call real4_real4
+  call complex_real
+  call check_block_data
+  call derived_types         ! Thanks to Tobias Burnus for this:)
+!
+! This came up in PR29786 comment #9
+!
+  if (d1mach (1) .ne. transfer ((/0_4, 1048576_4/), 1d0)) call abort ()
+  if (d1mach (2) .ne. transfer ((/-1_4,2146435071_4/), 1d0)) call abort ()
+!
+contains
+  subroutine int4_int4
+      integer(4)         a(4)
+      integer(4)         b
+      equivalence (b,a(3))
+      data b/3/
+      data (a(i), i=1,2) /1,2/, a(4) /4/
+      if (any (a .ne. (/1, 2, 3, 4/))) call abort ()
+  end subroutine int4_int4
+  subroutine real4_real4
+      real(4)         a(4)
+      real(4)         b
+      equivalence (b,a(3))
+      data b/3.0_4/
+      data (a(i), i=1,2) /1.0_4, 2.0_4/, &
+            a(4) /4.0_4/
+      if (sum (abs (a -  &
+          (/1.0_4, 2.0_4, 3.0_4, 4.0_4/))) > 1.0e-6) call abort ()
+  end subroutine real4_real4
+  subroutine complex_real
+      complex(4)         a(4)
+      real(4)            b(2)
+      equivalence (b,a(3))
+      data b(1)/3.0_4/, b(2)/4.0_4/
+      data (a(i), i=1,2) /(0.0_4, 1.0_4),(2.0_4,0.0_4)/, &
+            a(4) /(0.0_4,5.0_4)/
+      if (sum (abs (a - (/(0.0_4, 1.0_4),(2.0_4, 0.0_4), &
+          (3.0_4, 4.0_4),(0.0_4, 5.0_4)/)))  > 1.0e-6) call abort ()
+  end subroutine complex_real
+  subroutine check_block_data
+      common /global/ ca (4)
+      equivalence (ca(3), cb)
+      integer(4) ca
+      if (any (ca .ne. (/42, 43, 99, 44/))) call abort ()
+  end subroutine check_block_data
+  function d1mach(i)
+    implicit none
+    double precision d1mach,dmach(5)
+    integer i,large(4),small(4)
+    equivalence ( dmach(1), small(1) )
+    equivalence ( dmach(2), large(1) )
+    data small(1),small(2) / 0,   1048576/
+    data large(1),large(2) /-1,2146435071/
+    d1mach = dmach(i) 
+  end function d1mach
+    subroutine derived_types
+      TYPE T1
+        sequence
+        character (3) :: chr
+        integer :: i = 1
+        integer :: j
+        END TYPE T1
+      TYPE T2
+        sequence
+        character (3) :: chr = "wxy"
+        integer :: i = 1
+        integer :: j = 4
+      END TYPE T2
+      TYPE(T1) :: a1
+      TYPE(T2) :: a2
+      EQUIVALENCE(a1,a2)         ! { dg-warning="mixed|components" }
+      if (a1%chr .ne. "wxy") call abort ()
+      if (a1%i .ne. 1) call abort ()
+      if (a1%j .ne. 4) call abort ()
+      end subroutine derived_types
+end
diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90
index 1eefa8121a4..1f7dddc846b 100644
--- a/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90
+++ b/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90
@@ -1,18 +1,31 @@
 ! { dg-do compile }
 ! { dg-options "-O0" }
-! PR20902 - Structure with default initializer cannot be equivalence memeber.
+! PR20902 - Overlapping initializers in an equivalence block must
+! have the same value.
+!
+! The code was replaced completely after the fix for PR30875, which
+! is a repeat of the original and comes from the same contributor.
+! The fix for 20902 was wrong.
+!
 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
-TYPE T1
- sequence
- integer :: i=1
-END TYPE T1
-TYPE T2
- sequence
- integer :: i      ! drop original initializer to pick up error below.
-END TYPE T2
-TYPE(T1) :: a1
-TYPE(T2) :: a2
-EQUIVALENCE(a1,a2) ! { dg-error "initializer cannot be an EQUIVALENCE" }
-write(6,*) a1,a2
+!
+  TYPE T1
+    sequence
+    integer :: i=1
+  END TYPE T1
+  TYPE T2           ! OK because initializers are equal
+    sequence
+    integer :: i=1
+  END TYPE T2
+  TYPE T3
+    sequence
+    integer :: i=2 ! { dg-error "Overlapping unequal initializers" }
+  END TYPE T3
+  TYPE(T1) :: a1
+  TYPE(T2) :: a2
+  TYPE(T3) :: a3
+  EQUIVALENCE (a1, a2)
+  EQUIVALENCE (a1, a3)
+  write(6, *) a1, a2, a3
 END
 
diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90
index 207b7d318a0..872e05b90fc 100644
--- a/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90
+++ b/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90
@@ -1,11 +1,11 @@
 ! { dg-do compile }
 ! { dg-options "-O0" }
-! PR20890 - Equivalence cannot contain more than one initialized variables.
+! PR20890 - Equivalence cannot contain overlapping unequal initializers.
 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
 ! Started out being in BLOCK DATA; however, blockdata variables must be in
 ! COMMON and therefore cannot have F95 style initializers....
  MODULE DATA
-  INTEGER :: I=1,J=2
-  EQUIVALENCE(I,J)  ! { dg-error "cannot both be in the EQUIVALENCE" }
+  INTEGER :: I=1,J=2  ! { dg-error "Overlapping unequal initializers" }
+  EQUIVALENCE(I,J)
  END MODULE DATA
  END