This patch by Tobias, fixes a case of setting array low-bounds, found
for particular uses of SOURCE=/MOLD=.
For example:
program A_M
implicit none
real, dimension (:), allocatable :: A, B
allocate (A(0:5))
call Init (A)
contains
subroutine Init ( A )
real, dimension ( 0 : ), intent ( in ) :: A
integer, dimension ( 1 ) :: lb_B
allocate (B, mold = A)
...
lb_B = lbound (B, dim=1) ! Error: lb_B assigned 1, instead of 0 like
lower-bound of A.
Referencing the Fortran standard:
"16.9.109 LBOUND (ARRAY [, DIM, KIND])"
states:
"If DIM is present, ARRAY is a whole array, and either ARRAY is
an assumed-size array of rank DIM or dimension DIM of ARRAY has
nonzero extent, the result has a value equal to the lower bound
for subscript DIM of ARRAY. Otherwise, if DIM is present, the
result value is 1."
And on what is a "whole array":
"9.5.2 Whole arrays"
"A whole array is a named array or a structure component ..."
The attached patch adjusts the relevant part in gfc_trans_allocate() to only set
e3_has_nodescriptor only for non-named arrays.
Tobias has tested this once, and I've tested this patch as well on our complete
set of
testsuites (which usually serves for OpenMP related stuff). Everything appears
well with no regressions.
Is this okay for trunk?
Thanks,
Chung-Lin
2021-11-29 Tobias Burnus <tob...@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.diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index bdf7957..982e1e0 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -6660,16 +6660,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
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 28f24fc..323c8a3 100644
--- 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()
