From e6f385f8258148890a097878a618b694be663db6 Mon Sep 17 00:00:00 2001

From: Mark Eggleston <markeggleston@codethink.com>

Date: Tue, 11 Sep 2018 12:50:11 +0100

Subject: [PATCH 15/16] Allow automatics in equivalence

If a variable with an automatic attribute appears in an

equivalence statement the storage should be allocated on

the stack.

Note: most of this patch was provided by Jeff Law <law@redhat.com>.

---

 gcc/fortran/gfortran.h                        |  1 +

 gcc/fortran/symbol.c                          |  4 +-

 gcc/fortran/trans-common.c                    | 75 +++++++++++++++++++++++++--

 gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 | 36 +++++++++++++

 gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 | 38 ++++++++++++++

 gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 | 63 ++++++++++++++++++++++

 6 files changed, 210 insertions(+), 7 deletions(-)

 create mode 100644 gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90

 create mode 100644 gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90

 create mode 100644 gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h

index 23d01b10728..eb2a29fea5f 100644

--- a/gcc/fortran/gfortran.h

+++ b/gcc/fortran/gfortran.h

@@ -2993,6 +2993,7 @@ bool gfc_merge_new_implicit (gfc_typespec *);

 void gfc_set_implicit_none (bool, bool, locus *);

 void gfc_check_function_type (gfc_namespace *);

 bool gfc_is_intrinsic_typename (const char *);

+bool check_conflict (symbol_attribute *, const char *, locus *);

 gfc_typespec *gfc_get_default_type (const char *, gfc_namespace *);

 bool gfc_set_default_type (gfc_symbol *, int, gfc_namespace *);

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c

index 4247b5b60c8..5fdb46c4b32 100644

--- a/gcc/fortran/symbol.c

+++ b/gcc/fortran/symbol.c

@@ -407,7 +407,7 @@ gfc_check_function_type (gfc_namespace *ns)

                                 goto conflict_std;\

                               }

-static bool

+bool

 check_conflict (symbol_attribute *attr, const char *name, locus *where)

 {

   static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",

@@ -544,7 +544,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)

   conf (allocatable, elemental);

   conf (in_common, automatic);

-  conf (in_equivalence, automatic);

   conf (result, automatic);

   conf (use_assoc, automatic);

   conf (dummy, automatic);

@@ -4261,6 +4260,7 @@ save_symbol (gfc_symbol *sym)

     return;

   if (sym->attr.in_common

+      || sym->attr.in_equivalence

       || sym->attr.dummy

       || sym->attr.result

       || sym->attr.flavor != FL_VARIABLE)

diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c

index debdbd98ac0..a5fb230bb1b 100644

--- a/gcc/fortran/trans-common.c

+++ b/gcc/fortran/trans-common.c

@@ -339,7 +339,7 @@ build_field (segment_info *h, tree union_type, record_layout_info rli)

 /* Get storage for local equivalence.  */

 static tree

-build_equiv_decl (tree union_type, bool is_init, bool is_saved)

+build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto)

 {

   tree decl;

   char name[18];

@@ -359,8 +359,8 @@ build_equiv_decl (tree union_type, bool is_init, bool is_saved)

   DECL_ARTIFICIAL (decl) = 1;

   DECL_IGNORED_P (decl) = 1;

-  if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))

-      || is_saved)

+  if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))

+      || is_saved))

     TREE_STATIC (decl) = 1;

   TREE_ADDRESSABLE (decl) = 1;

@@ -611,6 +611,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)

   tree decl;

   bool is_init = false;

   bool is_saved = false;

+  bool is_auto = false;

   /* Declare the variables inside the common block.

      If the current common block contains any equivalence object, then

@@ -654,6 +655,10 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)

       /* Has SAVE attribute.  */

       if (s->sym->attr.save)

         is_saved = true;

+

+      /* Has AUTOMATIC attribute.  */

+      if (s->sym->attr.automatic)

+	is_auto = true;

     }

   finish_record_layout (rli, true);

@@ -661,7 +666,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)

   if (com)

     decl = build_common_decl (com, union_type, is_init);

   else

-    decl = build_equiv_decl (union_type, is_init, is_saved);

+    decl = build_equiv_decl (union_type, is_init, is_saved, is_auto);

   if (is_init)

     {

@@ -948,6 +953,61 @@ add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)

     confirm_condition (f, eq1, n, eq2);

 }

+static void

+accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e)

+{

+  symbol_attribute attr = e->expr->symtree->n.sym->attr;

+

+  dummy_symbol->dummy |= attr.dummy;

+  dummy_symbol->pointer |= attr.pointer;

+  dummy_symbol->target |= attr.target;

+  dummy_symbol->external |= attr.external;

+  dummy_symbol->intrinsic |= attr.intrinsic;

+  dummy_symbol->allocatable |= attr.allocatable;

+  dummy_symbol->elemental |= attr.elemental;

+  dummy_symbol->recursive |= attr.recursive;

+  dummy_symbol->in_common |= attr.in_common;

+  dummy_symbol->result |= attr.result;

+  dummy_symbol->in_namelist |= attr.in_namelist;

+  dummy_symbol->optional |= attr.optional;

+  dummy_symbol->entry |= attr.entry;

+  dummy_symbol->function |= attr.function;

+  dummy_symbol->subroutine |= attr.subroutine;

+  dummy_symbol->dimension |= attr.dimension;

+  dummy_symbol->in_equivalence |= attr.in_equivalence;

+  dummy_symbol->use_assoc |= attr.use_assoc;

+  dummy_symbol->cray_pointer |= attr.cray_pointer;

+  dummy_symbol->cray_pointee |= attr.cray_pointee;

+  dummy_symbol->data |= attr.data;

+  dummy_symbol->value |= attr.value;

+  dummy_symbol->volatile_ |= attr.volatile_;

+  dummy_symbol->is_protected |= attr.is_protected;

+  dummy_symbol->is_bind_c |= attr.is_bind_c;

+  dummy_symbol->procedure |= attr.procedure;

+  dummy_symbol->proc_pointer |= attr.proc_pointer;

+  dummy_symbol->abstract |= attr.abstract;

+  dummy_symbol->asynchronous |= attr.asynchronous;

+  dummy_symbol->codimension |= attr.codimension;

+  dummy_symbol->contiguous |= attr.contiguous;

+  dummy_symbol->generic |= attr.generic;

+  dummy_symbol->automatic |= attr.automatic;

+  dummy_symbol->threadprivate |= attr.threadprivate;

+  dummy_symbol->omp_declare_target |= attr.omp_declare_target;

+  dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link;

+  dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin;

+  dummy_symbol->oacc_declare_create |= attr.oacc_declare_create;

+  dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr;

+  dummy_symbol->oacc_declare_device_resident

+    |= attr.oacc_declare_device_resident;

+

+  /* Not strictly correct, but probably close enough.  */

+  if (attr.save > dummy_symbol->save)

+    dummy_symbol->save = attr.save;

+  if (attr.intent > dummy_symbol->intent)

+    dummy_symbol->intent = attr.intent;

+  if (attr.access > dummy_symbol->access)

+    dummy_symbol->access = attr.access;

+}

 /* Given a segment element, search through the equivalence lists for unused

    conditions that involve the symbol.  Add these rules to the segment.  */

@@ -965,9 +1025,12 @@ find_equivalence (segment_info *n)

       eq = NULL;

       /* Search the equivalence list, including the root (first) element

-         for the symbol that owns the segment.  */

+	 for the symbol that owns the segment.  */

+      symbol_attribute dummy_symbol;

+      memset (&dummy_symbol, 0, sizeof (dummy_symbol));

       for (e2 = e1; e2; e2 = e2->eq)

 	{

+	  accumulate_equivalence_attributes (&dummy_symbol, e2);

 	  if (!e2->used && e2->expr->symtree->n.sym == n->sym)

 	    {

 	      eq = e2;

@@ -975,6 +1038,8 @@ find_equivalence (segment_info *n)

 	    }

 	}

+      check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where);

+

       /* Go to the next root element.  */

       if (eq == NULL)

 	continue;

diff --git a/gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 b/gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90

new file mode 100644

index 00000000000..61bfd0738c5

--- /dev/null

+++ b/gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90

@@ -0,0 +1,36 @@

+! { dg-compile }

+

+! Contributed by Mark Eggleston <mark.eggleston@codethink.com>

+program test

+  call suba(0)

+  call subb(0)

+  call suba(1)

+

+contains

+  subroutine suba(option) 

+    integer, intent(in) :: option

+    integer, automatic :: a ! { dg-error "AUTOMATIC at \\(1\\) is a DEC extension" }

+    integer :: b

+    integer :: c

+    equivalence (a, b)

+    if (option.eq.0) then

+      ! initialise a and c

+      a = 9

+      c = 99

+      if (a.ne.b) stop 1

+      if (loc(a).ne.loc(b)) stop 2

+    else

+      ! a should've been overwritten

+      if (a.eq.9) stop 3

+    end if

+  end subroutine suba

+

+  subroutine subb(dummy)

+    integer, intent(in) :: dummy

+    integer, automatic :: x ! { dg-error "AUTOMATIC at \\(1\\) is a DEC extension" }

+    integer :: y

+    x = 77

+    y = 7

+  end subroutine subb

+

+end program test

diff --git a/gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 b/gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90

new file mode 100644

index 00000000000..406e718604a

--- /dev/null

+++ b/gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90

@@ -0,0 +1,38 @@

+! { dg-run }

+! { dg-options "-fdec-static" }

+

+! Contributed by Mark Eggleston <mark.eggleston@codethink.com>

+

+program test

+  call suba(0)

+  call subb(0)

+  call suba(1)

+

+contains

+  subroutine suba(option) 

+    integer, intent(in) :: option

+    integer, automatic :: a

+    integer :: b

+    integer :: c

+    equivalence (a, b)

+    if (option.eq.0) then

+      ! initialise a and c

+      a = 9

+      c = 99

+      if (a.ne.b) stop 1

+      if (loc(a).ne.loc(b)) stop 2

+    else

+      ! a should've been overwritten

+      if (a.eq.9) stop 3

+    end if

+  end subroutine suba

+

+  subroutine subb(dummy)

+    integer, intent(in) :: dummy

+    integer, automatic :: x

+    integer :: y

+    x = 77

+    y = 7

+  end subroutine subb

+

+end program test

diff --git a/gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 b/gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90

new file mode 100644

index 00000000000..c67aa8c6ac1

--- /dev/null

+++ b/gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90

@@ -0,0 +1,63 @@

+! { dg-run }

+! { dg-options "-fdec-static -fno-automatic" }

+

+! Contributed by Mark Eggleston <mark.eggleston@codethink.com>

+

+! Storage is NOT on the static unless explicitly specified using the

+! DEC extension "automatic". The address of the first local variable

+! is used to determine that storage for the automatic local variable

+! is different to that of a local variable with no attributes. The

+! contents of the local variable in suba should be overwritten by the

+! call to subb. 

+!

+program test

+  integer :: dummy

+  integer, parameter :: address = kind(loc(dummy))

+  integer(address) :: ad1

+  integer(address) :: ad2

+  integer(address) :: ad3

+  logical :: ok

+

+  call suba(0, ad1)

+  call subb(0, ad2)

+  call suba(1, ad1)

+  call subc(0, ad3)

+  ok = (ad1.eq.ad3).and.(ad1.ne.ad2)

+  if (.not.ok) stop 4

+

+contains

+  subroutine suba(option, addr) 

+    integer, intent(in) :: option

+    integer(address), intent(out) :: addr

+    integer, automatic :: a

+    integer :: b

+    equivalence (a, b)

+    addr = loc(a)

+    if (option.eq.0) then

+      ! initialise a and c

+      a = 9

+      if (a.ne.b) stop 1

+      if (loc(a).ne.loc(b)) stop 2

+    else

+      ! a should've been overwritten

+      if (a.eq.9) stop 3

+    end if

+  end subroutine suba

+

+  subroutine subb(dummy, addr)

+    integer, intent(in) :: dummy

+    integer(address), intent(out) :: addr

+    integer :: x

+    addr = loc(x)

+    x = 77

+  end subroutine subb

+

+  subroutine subc(dummy, addr)

+    integer, intent(in) :: dummy

+    integer(address), intent(out) :: addr

+    integer, automatic :: y

+    addr = loc(y)

+    y = 77

+  end subroutine subc

+

+end program test

-- 

2.11.0