Untabified and resubmitted: Patch to gfortran PR13742

[Victor Leikehman <LEI at il dot ibm dot com>]

This patch fixes gfortran PR 13742 ("Initial values
for COMMON or EQUIVALENCE").  In fact, 13742 combines two defects:
    (1) Initializing variables inside COMMON block is forbidden and
        should be rejected.
and,
    (2) Initializing variables inside EQUIVALENCE is allowed and
        should be supported.

This patch fixes both (1) and (2), supporting the most common forms
of initialization, including the form used in SPEC FP 187.facerec
benchmark.

      Victor
--
      Victor Leikehman
      IBM Research Labs in Haifa, Israel

===================================================================
subroutine test0s
  character*10 :: x = "abcdefghij"
  character*10 :: y
  equivalence (x,y)

  character*10 :: xs(10)
  character*10 :: ys(10)
  equivalence (xs,ys)
  data xs /10*"abcdefghij"/

  if (y.ne."abcdefghij") call abort
  if (ys(1).ne."abcdefghij") call abort
  if (ys(10).ne."abcdefghij") call abort
end

subroutine test0
  integer :: x = 123
  integer :: y
  equivalence (x,y)
  if (y.ne.123) call abort
end

subroutine test1
  integer :: a(3)
  integer :: x = 1
  integer :: y
  integer :: z = 3
  equivalence (a(1), x)
  equivalence (a(3), z)
  if (x.ne.1) call abort
  if (z.ne.3) call abort
  if (a(1).ne.1) call abort
  if (a(3).ne.3) call abort
end

subroutine test2
  integer :: x
  integer :: z
  integer :: a(3) = 123
  equivalence (a(1), x)
  equivalence (a(3), z)
  if (x.ne.123) call abort
  if (z.ne.123) call abort
end

subroutine test3
  integer :: x
  integer :: y !  = 2 ! not yet supported initialization of y here
  integer :: z
  integer :: a(3)
  equivalence (a(1),x), (a(2),y), (a(3),z)
  data a(1) /1/, a(3) /3/
  if (x.ne.1) call abort
!  if (y.ne.2) call abort
  if (z.ne.3) call abort
end

subroutine test4
  integer a(2)
  integer b(2)
  integer c
  equivalence (a(2),b(1)), (b(2),c)
  data a/1,2/
  data c/3/
  if (b(1).ne.2) call abort
  if (b(2).ne.3) call abort
end

!!$subroutine test5
!!$  integer a(2)
!!$  integer b(2)
!!$  integer c
!!$  equivalence (a(2),b(1)), (b(2),c)
!!$  data a(1)/1/
!!$  data b(1)/2/
!!$  data c/3/
!!$  if (a(2).ne.2) call abort
!!$  if (b(2).ne.3) call abort
!!$  print *, "Passed test5"
!!$end

program main
  call test0s
  call test0
  call test1
  call test2
  call test3
  call test4
!!$  call test5
end
===================================================================
! Bad input, should be rejected by the compiler.
SUBROUTINE FOO()
COMMON /A/ X
REAL :: X = 12345
END

PROGRAM MAIN
COMMON /A/ X
PRINT *, X
END
===================================================================
--- trans-common.c.orig 2004-05-02 13:31:28.000000000 +0300
+++ trans-common.c      2004-05-05 10:32:57.000000000 +0300
@@ -96,6 +96,7 @@ Boston, MA 02111-1307, USA.  */
 #include "trans.h"
 #include "trans-types.h"
 #include "trans-const.h"
+#include <assert.h>


 typedef struct segment_info
@@ -179,13 +180,18 @@ static tree
 build_equiv_decl (tree union_type, bool is_init)
 {
   tree decl;
+
+  if (is_init)
+    {
+      decl = gfc_create_var (union_type, "equiv");
+      TREE_STATIC (decl) = 1;
+      return decl;
+    }
+
   decl = build_decl (VAR_DECL, NULL, union_type);
   DECL_ARTIFICIAL (decl) = 1;

-  if (is_init)
-    DECL_COMMON (decl) = 0;
-  else
-    DECL_COMMON (decl) = 1;
+  DECL_COMMON (decl) = 1;

   TREE_ADDRESSABLE (decl) = 1;
   TREE_USED (decl) = 1;
@@ -300,13 +306,61 @@ create_common (gfc_symbol *sym)
     }
   finish_record_layout (rli, true);

-  if (is_init)
-    gfc_todo_error ("initial values for COMMON or EQUIVALENCE");
-
   if (sym)
-    decl = build_common_decl (sym, union_type, is_init);
+    {
+      if (is_init)
+        gfc_error ("Variables in COMMON block should not"
+                   " have initializers");
+      decl = build_common_decl (sym, union_type, is_init);
+    }
   else
-    decl = build_equiv_decl (union_type, is_init);
+    {
+      tree list, ctor, t;
+      gfc_se se;
+
+      decl = build_equiv_decl (union_type, is_init);
+      if (is_init)
+        {
+          int offset = 0;
+          list = NULL_TREE;
+          for (h = current_common; h; h = h->next)
+            {
+              if (h->sym->value)
+                {
+                  if (h->offset < offset)
+                    gfc_error ("Unsupported form of initialization"
+                               " of EQUIVALENCEd variables");
+                  if (h->sym->attr.dimension)
+                    {
+                      t = gfc_conv_array_initializer (TREE_TYPE
(h->field),
+                                                      h->sym->value);
+                      list = tree_cons (h->field, t, list);
+                    }
+                  else
+                    {
+                      gfc_init_se (&se, NULL);
+                      gfc_conv_expr (&se, h->sym->value);
+                      list = tree_cons (h->field, se.expr, list);
+                    }
+                  offset = h->offset + h->length;
+                }
+            }
+          assert (list);
+          ctor = build1 (CONSTRUCTOR, union_type, nreverse(list));
+          TREE_CONSTANT (ctor) = 1;
+          TREE_INVARIANT (ctor) = 1;
+          TREE_STATIC (ctor) = 1;
+
+          /* Sanity check */
+          for (t = CONSTRUCTOR_ELTS (ctor); t; t = TREE_CHAIN (t))
+            {
+              tree field = TREE_PURPOSE (t);
+              assert (TREE_CODE (field) == FIELD_DECL);
+            }
+
+          DECL_INITIAL (decl) = ctor;
+        }
+    }

   /* Build component reference for each variable.  */
   for (h = current_common; h; h = next_s)
===================================================================