[gcc/devel/coarray_native] Made the ALLOCATED intrinsic work with scalar coarrays.

[gcc/devel/coarray_native] Made the ALLOCATED intrinsic work with scalar coarrays.

[Thomas König]

https://gcc.gnu.org/g:1a50de8778750f019e61a97ee6d3e8226c41a7f1

commit 1a50de8778750f019e61a97ee6d3e8226c41a7f1
Author: Thomas Koenig <tkoenig@gcc.gnu.org>
Date:   Sun Dec 20 20:38:10 2020 +0100

    Made the ALLOCATED intrinsic work with scalar coarrays.
    
    gcc/fortran/ChangeLog:
    
            * trans-array.c (gfc_conv_array_ref): Whitespace fix. Do not
            add offset if se->no_impl_this_image is set.
            * trans-intrinsic.c (gfc_conv_allocated): Set
            no_imp_this_image if checking the allocation status of
            a scalar.
            * trans.h (gfc_se): Add no_impl_this_image flag.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/caf-shared/scalar_alloc_1.f90: New test.
            * gfortran.dg/caf-shared/scalar_alloc_2.f90: New test.

Diff:
---
 gcc/fortran/trans-array.c                          |  5 +-
 gcc/fortran/trans-intrinsic.c                      |  1 +
 gcc/fortran/trans.h                                |  5 ++
 .../gfortran.dg/caf-shared/scalar_alloc_1.f90      | 69 ++++++++++++++++++++++
 .../gfortran.dg/caf-shared/scalar_alloc_2.f90      | 60 +++++++++++++++++++
 5 files changed, 138 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a5455fc5226..39e6b6d9051 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3716,7 +3716,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
   int eff_dimen;
 
   need_impl_this_image =
-      ar->dimen_type[ar->dimen + ar->codimen - 1] == DIMEN_THIS_IMAGE;
+    ar->dimen_type[ar->dimen + ar->codimen - 1] == DIMEN_THIS_IMAGE;
 
   if (flag_coarray == GFC_FCOARRAY_SHARED
       && !need_impl_this_image)
@@ -3865,7 +3865,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
       add_to_offset (&cst_offset, &offset, tmp);
     }
 
-  if (flag_coarray == GFC_FCOARRAY_SHARED && need_impl_this_image)
+  if (flag_coarray == GFC_FCOARRAY_SHARED && need_impl_this_image
+      && !se->no_impl_this_image)
     {
       tree off;
       tree co_stride = gfc_conv_array_stride (decl, eff_dimen + 1);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 7824dcf55a0..e93cd3a12c7 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -8832,6 +8832,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
 	{
 	  /* Allocatable scalar.  */
 	  arg1se.want_pointer = 1;
+	  arg1se.no_impl_this_image = 1;
 	  gfc_conv_expr (&arg1se, arg1->expr);
 	  tmp = arg1se.expr;
 	}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 95e4741906c..f3cf33b342f 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -98,6 +98,11 @@ typedef struct gfc_se
      arrays in gfc_conv_expr_descriptor.  */
   unsigned use_offset:1;
 
+  /* For shared coarrays, do not add the offset for the implied
+     this_image().  */
+
+  unsigned no_impl_this_image:1;
+
   unsigned want_coarray:1;
 
   /* Scalarization parameters.  */
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/scalar_alloc_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/scalar_alloc_1.f90
new file mode 100644
index 00000000000..8264e2cc085
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/scalar_alloc_1.f90
@@ -0,0 +1,69 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+!
+implicit none
+integer, allocatable :: A[:], B[:,:]
+integer :: n1, n2, n3
+
+if (allocated (a)) STOP 1
+if (allocated (b)) STOP 2
+
+allocate(a[*])
+a = 5 + this_image ()
+if (a[this_image ()] /= 5 + this_image ()) STOP 1
+
+a[this_image ()] = 8 - 2*this_image ()
+if (a[this_image ()] /= 8 - 2*this_image ()) STOP 2
+
+if (lcobound(a, dim=1) /= 1 .or. ucobound(a,dim=1) /= num_images()) &
+  STOP 3
+deallocate(a)
+
+allocate(a[4:*])
+a[this_image ()] = 8 - 2*this_image ()
+
+if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) &
+  STOP 4
+
+n1 = -1
+n2 = 5
+n3 = 3
+allocate (B[n1:n2, n3:*])
+if (any (lcobound(b) /= [-1, 3]) .or. lcobound(B, dim=2) /= n3) &
+  STOP 5
+call sub(A, B)
+
+if (allocated (a)) STOP 6
+if (.not.allocated (b)) STOP 7
+
+call two(.true.)
+call two(.false.)
+
+! automatically deallocate "B"
+contains
+  subroutine sub(x, y)
+    integer, allocatable :: x[:], y[:,:]
+
+    if (any (lcobound(y) /= [-1, 3]) .or. lcobound(y, dim=2) /= n3) &
+      STOP 8
+    if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) &
+      STOP 9
+    if (x[this_image ()] /= 8 - 2*this_image ()) STOP 3
+    deallocate(x)
+  end subroutine sub
+
+  subroutine two(init)
+    logical, intent(in) :: init
+    integer, allocatable, SAVE :: a[:]
+
+    if (init) then
+      if (allocated(a)) STOP 10
+      allocate(a[*])
+      a = 45
+   else
+      if (.not. allocated(a)) STOP 11
+      if (a /= 45) STOP 12
+      deallocate(a)
+    end if
+  end subroutine two
+end
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/scalar_alloc_2.f90 b/gcc/testsuite/gfortran.dg/caf-shared/scalar_alloc_2.f90
new file mode 100644
index 00000000000..8143f887af8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/scalar_alloc_2.f90
@@ -0,0 +1,60 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+! Check whether registering allocatable coarrays works
+!
+type position
+  real :: x, y, z
+end type position
+
+integer, allocatable :: a[:]
+type(position), allocatable :: p[:]
+
+allocate(a[*])
+a = 7
+
+allocate(p[*])
+p%x = 11
+p%y = 13
+p%z = 15
+
+if (a /= 7) STOP 1
+a = 88
+if (a /= 88) STOP 2
+
+if (p%x /= 11) STOP 3
+p%x = 17
+if (p%x /= 17) STOP 4
+
+ block
+   integer, allocatable :: b[:]
+
+   allocate(b[*])
+   b = 8494
+   
+   if (b /= 8494) STOP 5
+ end block
+
+if (a /= 88) STOP 6
+call test ()
+end
+
+subroutine test()
+  type velocity
+    real :: x, y, z
+  end type velocity
+
+  real, allocatable :: z[:]
+  type(velocity), allocatable :: v[:]
+
+  allocate(z[*])
+  z = sqrt(2.0)
+
+  allocate(v[*])
+  v%x = 21
+  v%y = 23
+  v%z = 25
+
+  if (z /= sqrt(2.0)) STOP 7
+  if (v%x /= 21) STOP 8
+
+end subroutine test