fortran: Fix setting of array lower bound for named arrays

This patch fixes a case of setting array low-bounds, found for particular uses
of SOURCE=/MOLD=. This adjusts the relevant part in gfc_trans_allocate() to
set e3_has_nodescriptor only for non-named arrays.

2021-12-03  Tobias Burnus  <tobias@codesourcery.com>

gcc/fortran/ChangeLog:

	* trans-stmt.c (gfc_trans_allocate): Set e3_has_nodescriptor to true
	only for non-named arrays.

gcc/testsuite/ChangeLog:

	* gfortran.dg/allocate_with_source_26.f90: Adjust testcase.
	* gfortran.dg/allocate_with_mold_4.f90: New testcase.

(cherry picked from commit 6262e3a22b3d86afc116480bc59a7bb30b0cfd40)

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 5f576424fc3c143846f06a39d1f383ff4bc2a0b4..0435547423589e8b6d5165c94a55b29ed6b7dba2 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -6640,16 +6640,13 @@ gfc_trans_allocate (gfc_code * code)
       else
        e3rhs = gfc_copy_expr (code->expr3);
 
-      // We need to propagate the bounds of the expr3 for source=/mold=;
-      // however, for nondescriptor arrays, we use internally a lower bound
-      // of zero instead of one, which needs to be corrected for the allocate obj
-      if (e3_is == E3_DESC)
-       {
-         symbol_attribute attr = gfc_expr_attr (code->expr3);
-         if (code->expr3->expr_type == EXPR_ARRAY ||
-             (!attr.allocatable && !attr.pointer))
-           e3_has_nodescriptor = true;
-       }
+      // We need to propagate the bounds of the expr3 for source=/mold=.
+      // However, for non-named arrays, the lbound has to be 1 and neither the
+      // bound used inside the called function even when returning an
+      // allocatable/pointer nor the zero used internally.
+      if (e3_is == E3_DESC
+         && code->expr3->expr_type != EXPR_VARIABLE)
+       e3_has_nodescriptor = true;
     }
 
   /* Loop over all objects to allocate.  */

diff --git a/gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90 b/gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90
new file mode 100644 (file)
index 0000000..d545fe1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90
@@ -0,0 +1,24 @@
+program A_M
+  implicit none
+  real, parameter :: C(5:10) = 5.0
+  real, dimension (:), allocatable :: A, B
+  allocate (A(6))
+  call Init (A)
+contains
+  subroutine Init ( A )
+    real, dimension ( -1 : ), intent ( in ) :: A
+    integer, dimension ( 1 ) :: lb_B
+
+    allocate (B, mold = A)
+    if (any (lbound (B) /= lbound (A))) stop 1
+    if (any (ubound (B) /= ubound (A))) stop 2
+    if (any (shape (B) /= shape (A))) stop 3
+    if (size (B) /= size (A)) stop 4
+    deallocate (B)
+    allocate (B, mold = C)
+    if (any (lbound (B) /= lbound (C))) stop 5
+    if (any (ubound (B) /= ubound (C))) stop 6
+    if (any (shape (B) /= shape (C))) stop 7
+    if (size (B) /= size (C)) stop 8
+end
+end 

diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90
index 28f24fc1e10adcb79f385f9a6f5a80153d201841..323c8a30b9ee070e1111b6e697ea11f25a3ece0a 100644 (file)
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90
@@ -34,23 +34,23 @@ program p
  if (lbound(p1, 1) /= 3 .or. ubound(p1, 1) /= 4 &
      .or. lbound(p2, 1) /= 3 .or. ubound(p2, 1) /= 4 &
      .or. lbound(p3, 1) /= 1 .or. ubound(p3, 1) /= 2 &
-     .or. lbound(p4, 1) /= 7 .or. ubound(p4, 1) /= 8 &
+     .or. lbound(p4, 1) /= 1 .or. ubound(p4, 1) /= 2 &
      .or. p1(3)%i /= 43 .or. p1(4)%i /= 56 &
      .or. p2(3)%i /= 43 .or. p2(4)%i /= 56 &
      .or. p3(1)%i /= 43 .or. p3(2)%i /= 56 &
-     .or. p4(7)%i /= 11 .or. p4(8)%i /= 12) then
+     .or. p4(1)%i /= 11 .or. p4(2)%i /= 12) then
    call abort()
  endif
 
  !write(*,*) lbound(a,1), ubound(a,1) ! prints 1 3
  !write(*,*) lbound(b,1), ubound(b,1) ! prints 1 3
- !write(*,*) lbound(c,1), ubound(c,1) ! prints 3 5
+ !write(*,*) lbound(c,1), ubound(c,1) ! prints 1 3
  !write(*,*) lbound(d,1), ubound(d,1) ! prints 1 5
  !write(*,*) lbound(e,1), ubound(e,1) ! prints 1 6
 
  if (lbound(a,1) /= 1 .or. ubound(a,1) /= 3 &
      .or. lbound(b,1) /= 1 .or. ubound(b,1) /= 3 &
-     .or. lbound(c,1) /= 3 .or. ubound(c,1) /= 5 &
+     .or. lbound(c,1) /= 1 .or. ubound(c,1) /= 3 & 
      .or. lbound(d,1) /= 1 .or. ubound(d,1) /= 5 &
      .or. lbound(e,1) /= 1 .or. ubound(e,1) /= 6) then
    call abort()